diff --git a/.github/workflows/check-stylish-haskell.yml b/.github/workflows/check-fourmolu.yml similarity index 64% rename from .github/workflows/check-stylish-haskell.yml rename to .github/workflows/check-fourmolu.yml index ed6796ebf0..5e56c5c46d 100644 --- a/.github/workflows/check-stylish-haskell.yml +++ b/.github/workflows/check-fourmolu.yml @@ -1,4 +1,4 @@ -name: Check Stylish Haskell +name: Check Fourmolu on: merge_group: @@ -19,64 +19,55 @@ concurrency: cancel-in-progress: true jobs: - check-stylish-haskell: + check-fourmolu: runs-on: ubuntu-latest - strategy: - fail-fast: false - env: - # Modify this value to "invalidate" the cabal cache. - CABAL_CACHE_VERSION: "2023-07-12" - - STYLISH_HASKELL_VERSION: "0.14.4.0" - - STYLISH_HASKELL_PATHS: > - cardano-api + FOURMOLU_VERSION: "0.16.2.0" steps: - - name: Download stylish-haskell + - name: Download Fourmolu run: | - version="${{ env.STYLISH_HASKELL_VERSION }}" - + fourmolu_path="$(mktemp -d)" + version="${{env.FOURMOLU_VERSION}}" curl -sL \ - "https://github.com/haskell/stylish-haskell/releases/download/v$version/stylish-haskell-v$version-linux-x86_64.tar.gz" \ - | tar -C "/tmp" -xz - - echo "PATH=/tmp/stylish-haskell-v$version-linux-x86_64:$PATH" >> "$GITHUB_ENV" + "https://github.com/fourmolu/fourmolu/releases/download/v$version/fourmolu-$version-linux-x86_64" > "$fourmolu_path/fourmolu" + echo "PATH=$fourmolu_path:$PATH" >> "$GITHUB_ENV" + chmod u+rwx "$fourmolu_path/fourmolu" - uses: actions/checkout@v3 - - name: Run stylish-haskell over all Haskell files (always succeeds) + - name: Run Fourmolu over all Haskell files (always succeeds) run: | git add . git stash - for x in $(git ls-tree --full-tree --name-only -r HEAD ${{ env.STYLISH_HASKELL_PATHS }}); do + for x in $(git ls-tree --full-tree --name-only -r HEAD); do if [ "${x##*.}" == "hs" ]; then if grep -qE '^#' "$x"; then echo "$x contains CPP. Skipping." else - stylish-haskell -i "$x" + fourmolu -q -i "$x" fi fi done git --no-pager diff - - name: Run stylish-haskell over all modified files + - name: Run Fourmolu over all modified files run: | git add . git stash git fetch origin ${{ github.base_ref }} --unshallow - for x in $(git diff --name-only --diff-filter=ACMR origin/${{ github.base_ref }}..HEAD ${{ env.STYLISH_HASKELL_PATHS }}); do + for x in $(git diff --name-only --diff-filter=ACMR origin/${{ github.base_ref }}..HEAD); do if [ "${x##*.}" == "hs" ]; then if grep -qE '^#' "$x"; then echo "$x contains CPP. Skipping." else - stylish-haskell -i "$x" + fourmolu -q -i "$x" fi fi done git --no-pager diff --exit-code + diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index 7218ef5069..0000000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,114 +0,0 @@ -# Stylish-haskell configuration file. - -# Principles: -# -# 1. Amount of indent should not be dependent on the length of the previous line -# 2. Imports lists should be compact -# 3. All linting rules that delete comments should be disabled -# 4. No inline indenting, for example indent of ->, =, <-, as -# 5. Redunant imports and pragmas should be removed -# 6. Consistent syntax -# 7. No trailing whitespaces -# 8. Slightly generous screen width assumed -# 9. All Haskell files in the project are subject to code formatting style -# 10. Import grouping is handled by stylish-haskell - -steps: - # Principle 4 - - simple_align: - cases: false - top_level_patterns: false - # Principle 3 - records: false - - # Import cleanup - - imports: - align: global - - # Principle 1,2 - list_align: with_module_name - - # Principle 4 - pad_module_names: false - - # Principle 2 - long_list_align: inline - - empty_list_align: inherit - - list_padding: 2 - - separate_lists: true - - space_surround: false - - # Principle 10 - group_imports: true - - group_rules: - - match: ^Cardano.Api\> - - match: ^(Cardano|Ouroboros|PlutusCore|PlutusLedgerApi)\> - - match: ^Prelude\> - - match: ^(Control|Codec|Data|Formatting|GHC|Lens|Network|Numeric|Options|Prettyprinter|System|Text)\> - - match: ^(Test.Gen.Cardano.Api)\> - - match: ^(Test.Cardano|Test.Gen.Cardano)\> - - match: ^(Hedgehog|HaskellWorks.Hspec|Test)\> - - - language_pragmas: - style: vertical - - align: false - - # Principle 5 - remove_redundant: true - - # Principle 6 - language_prefix: LANGUAGE - - # Principle 7 - - trailing_whitespace: {} - -# Principle 8 -columns: 100 - -newline: native - -# Principle 9 -# -# These syntax-affecting language extensions are enabled so that -# stylish-haskell wouldn't fail with parsing errors when processing files -# in projects that have those extensions enabled in the .cabal file -# rather than locally. -# -# In particular language extensions with British and American spellings -# that we use should be included here until stylish-haskell supports -# the British spelling. -language_extensions: - - BangPatterns - - ConstraintKinds - - DataKinds - - DefaultSignatures - - DeriveDataTypeable - - DeriveGeneric - - ExistentialQuantification - - FlexibleContexts - - FlexibleInstances - - FunctionalDependencies - - GADTs - - GeneralizedNewtypeDeriving - - LambdaCase - - MultiParamTypeClasses - - MultiWayIf - - OverloadedStrings - - PolyKinds - - RecordWildCards - - ScopedTypeVariables - - StandaloneDeriving - - TemplateHaskell - - TupleSections - - TypeApplications - - TypeFamilies - - ViewPatterns - - ExplicitNamespaces - -cabal: true diff --git a/cardano-api-gen/src/Test/Gen/Cardano/Api/Empty.hs b/cardano-api-gen/src/Test/Gen/Cardano/Api/Empty.hs index 487ed9254e..0ce0529e8f 100644 --- a/cardano-api-gen/src/Test/Gen/Cardano/Api/Empty.hs +++ b/cardano-api-gen/src/Test/Gen/Cardano/Api/Empty.hs @@ -1,5 +1,5 @@ module Test.Gen.Cardano.Api.Empty where -import Test.Gen.Cardano.Api () +import Test.Gen.Cardano.Api () -- | This module is empty, but it is needed to prevent unused-packages warning diff --git a/cardano-api/gen/Test/Gen/Cardano/Api.hs b/cardano-api/gen/Test/Gen/Cardano/Api.hs index a9f167ae81..21f4c42e6d 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api.hs @@ -6,7 +6,8 @@ module Test.Gen.Cardano.Api ( genMetadata , genAlonzoGenesis - ) where + ) +where import qualified Cardano.Ledger.Alonzo.Core as Ledger import qualified Cardano.Ledger.Alonzo.Genesis as Alonzo @@ -15,21 +16,18 @@ import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Plutus.CostModels as Plutus import qualified Cardano.Ledger.Plutus.Language as Alonzo -import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..), ShelleyTxAuxData (..)) - +import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..), ShelleyTxAuxData (..)) import qualified Data.Map.Strict as Map -import Data.Word (Word64) - -import Test.Gen.Cardano.Api.Typed (genCostModel, genRational) - -import Hedgehog (Gen, Range) +import Data.Word (Word64) +import Hedgehog (Gen, Range) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Internal.Range as Range +import Test.Gen.Cardano.Api.Typed (genCostModel, genRational) genMetadata :: Ledger.Era era => Gen (ShelleyTxAuxData era) genMetadata = do numberOfIndices <- Gen.integral (Range.linear 1 15) - let indices = map (\i -> fromIntegral i :: Word64) [1..numberOfIndices] + let indices = map (\i -> fromIntegral i :: Word64) [1 .. numberOfIndices] mData <- Gen.list (Range.singleton numberOfIndices) genMetadatum return . ShelleyTxAuxData . Map.fromList $ zip indices mData @@ -63,22 +61,24 @@ genPrice = do genPrices :: Gen Alonzo.Prices genPrices = do - prMem' <- genPrice + prMem' <- genPrice prSteps' <- genPrice - return Alonzo.Prices - { Alonzo.prMem = prMem' - , Alonzo.prSteps = prSteps' - } + return + Alonzo.Prices + { Alonzo.prMem = prMem' + , Alonzo.prSteps = prSteps' + } genExUnits :: Gen Alonzo.ExUnits genExUnits = do exUnitsMem' <- Gen.integral (Range.linear 0 10) exUnitsSteps' <- Gen.integral (Range.linear 0 10) - return Alonzo.ExUnits - { Alonzo.exUnitsMem = exUnitsMem' - , Alonzo.exUnitsSteps = exUnitsSteps' - } + return + Alonzo.ExUnits + { Alonzo.exUnitsMem = exUnitsMem' + , Alonzo.exUnitsSteps = exUnitsSteps' + } genCostModels :: Gen Alonzo.CostModels genCostModels = do @@ -101,13 +101,14 @@ genAlonzoGenesis = do collateralPercentage' <- Gen.integral (Range.linear 0 10) maxCollateralInputs' <- Gen.integral (Range.linear 0 10) - return Alonzo.AlonzoGenesis - { Alonzo.agCoinsPerUTxOWord = Ledger.CoinPerWord coinsPerUTxOWord - , Alonzo.agCostModels = mempty - , Alonzo.agPrices = prices' - , Alonzo.agMaxTxExUnits = maxTxExUnits' - , Alonzo.agMaxBlockExUnits = maxBlockExUnits' - , Alonzo.agMaxValSize = maxValSize' - , Alonzo.agCollateralPercentage = collateralPercentage' - , Alonzo.agMaxCollateralInputs = maxCollateralInputs' - } + return + Alonzo.AlonzoGenesis + { Alonzo.agCoinsPerUTxOWord = Ledger.CoinPerWord coinsPerUTxOWord + , Alonzo.agCostModels = mempty + , Alonzo.agPrices = prices' + , Alonzo.agMaxTxExUnits = maxTxExUnits' + , Alonzo.agMaxBlockExUnits = maxBlockExUnits' + , Alonzo.agMaxValSize = maxValSize' + , Alonzo.agCollateralPercentage = collateralPercentage' + , Alonzo.agMaxCollateralInputs = maxCollateralInputs' + } diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs index 6a4e600bab..884ff13519 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs @@ -4,19 +4,17 @@ module Test.Gen.Cardano.Api.Byron ( tests - ) where - -import Cardano.Api hiding (txIns) -import Cardano.Api.Byron - -import Data.Proxy - -import Test.Gen.Cardano.Api.Typed - -import Hedgehog -import Test.Hedgehog.Roundtrip.CBOR -import Test.Tasty -import Test.Tasty.Hedgehog + ) +where + +import Cardano.Api hiding (txIns) +import Cardano.Api.Byron +import Data.Proxy +import Hedgehog +import Test.Gen.Cardano.Api.Typed +import Test.Hedgehog.Roundtrip.CBOR +import Test.Tasty +import Test.Tasty.Hedgehog prop_byron_roundtrip_txbody_CBOR :: Property prop_byron_roundtrip_txbody_CBOR = property $ do @@ -35,9 +33,10 @@ prop_byron_roundtrip_Tx_Cddl = property $ do tripping x serializeByronTx deserialiseByronTxCddl tests :: TestTree -tests = testGroup "Test.Gen.Cardano.Api.Byron" - [ testProperty "Byron roundtrip txbody CBOR" prop_byron_roundtrip_txbody_CBOR - , testProperty "Byron roundtrip witness CBOR" prop_byron_roundtrip_witness_CBOR - , testProperty "Byron roundtrip tx CBOR" prop_byron_roundtrip_Tx_Cddl - ] - +tests = + testGroup + "Test.Gen.Cardano.Api.Byron" + [ testProperty "Byron roundtrip txbody CBOR" prop_byron_roundtrip_txbody_CBOR + , testProperty "Byron roundtrip witness CBOR" prop_byron_roundtrip_witness_CBOR + , testProperty "Byron roundtrip tx CBOR" prop_byron_roundtrip_Tx_Cddl + ] diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs index de644abec6..cd620b555d 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs @@ -7,62 +7,62 @@ module Test.Gen.Cardano.Api.Era ( shelleyBasedEraTestConstraints , shelleyToBabbageEraTestConstraints , conwayEraOnwardsTestConstraints - ) where - -import Cardano.Api hiding (txIns) -import Cardano.Api.Shelley + ) +where +import Cardano.Api hiding (txIns) +import Cardano.Api.Shelley import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Core as Ledger - import qualified Data.Functor.Identity as Ledger +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.QuickCheck (Arbitrary (..)) -import Test.Cardano.Ledger.Conway.Arbitrary () -import Test.Cardano.Ledger.Core.Arbitrary () - -import Test.QuickCheck (Arbitrary (..)) - -shelleyBasedEraTestConstraints :: () +shelleyBasedEraTestConstraints + :: () => ShelleyBasedEra era - -> ( ( Ledger.Era (ShelleyLedgerEra era) - , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) - , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) - ) - => a - ) + -> ( ( Ledger.Era (ShelleyLedgerEra era) + , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) + , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) + ) + => a + ) -> a shelleyBasedEraTestConstraints = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id + ShelleyBasedEraShelley -> id + ShelleyBasedEraAllegra -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id + ShelleyBasedEraBabbage -> id + ShelleyBasedEraConway -> id -shelleyToBabbageEraTestConstraints :: () +shelleyToBabbageEraTestConstraints + :: () => ShelleyToBabbageEra era - -> ( ( Ledger.Era (ShelleyLedgerEra era) - , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) - , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) - ) - => a - ) + -> ( ( Ledger.Era (ShelleyLedgerEra era) + , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) + , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) + ) + => a + ) -> a shelleyToBabbageEraTestConstraints = \case - ShelleyToBabbageEraShelley -> id - ShelleyToBabbageEraAllegra -> id - ShelleyToBabbageEraMary -> id - ShelleyToBabbageEraAlonzo -> id - ShelleyToBabbageEraBabbage -> id + ShelleyToBabbageEraShelley -> id + ShelleyToBabbageEraAllegra -> id + ShelleyToBabbageEraMary -> id + ShelleyToBabbageEraAlonzo -> id + ShelleyToBabbageEraBabbage -> id -conwayEraOnwardsTestConstraints :: () +conwayEraOnwardsTestConstraints + :: () => ConwayEraOnwards era - -> ( ( Ledger.Era (ShelleyLedgerEra era) - , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) - , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) - ) - => a - ) + -> ( ( Ledger.Era (ShelleyLedgerEra era) + , Arbitrary (Ledger.PParamsHKD Ledger.StrictMaybe (ShelleyLedgerEra era)) + , Arbitrary (Ledger.PParamsHKD Ledger.Identity (ShelleyLedgerEra era)) + ) + => a + ) -> a conwayEraOnwardsTestConstraints = \case ConwayEraOnwardsConway -> id diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Metadata.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Metadata.hs index d1e0b2dac5..9aa676e652 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Metadata.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Metadata.hs @@ -4,23 +4,22 @@ module Test.Gen.Cardano.Api.Metadata ( genTxMetadata , genTxMetadataValue , genJsonForTxMetadata - ) where + ) +where -import Cardano.Api - -import Data.Aeson (ToJSON (..)) +import Cardano.Api +import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import qualified Data.Map.Strict as Map -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Word (Word64) - -import Hedgehog (Gen) +import Data.Word (Word64) +import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Internal.Gen as Gen import qualified Hedgehog.Range as Range @@ -31,160 +30,191 @@ import qualified Hedgehog.Range as Range genJsonForTxMetadata :: TxMetadataJsonSchema -> Gen Aeson.Value genJsonForTxMetadata mapping = - Gen.sized $ \sz -> - Aeson.object <$> - Gen.list (Range.linear 0 (fromIntegral sz)) - ((,) <$> (Aeson.fromString . show <$> Gen.word64 Range.constantBounded) - <*> genJsonForTxMetadataValue mapping) + Gen.sized $ \sz -> + Aeson.object + <$> Gen.list + (Range.linear 0 (fromIntegral sz)) + ( (,) + <$> (Aeson.fromString . show <$> Gen.word64 Range.constantBounded) + <*> genJsonForTxMetadataValue mapping + ) genJsonForTxMetadataValue :: TxMetadataJsonSchema -> Gen Aeson.Value genJsonForTxMetadataValue TxMetadataJsonNoSchema = genJsonValue - where - genJsonValue :: Gen Aeson.Value - genJsonValue = - Gen.sized $ \sz -> - Gen.frequency - [ (1, Aeson.toJSON <$> genJsonNumber) - , (2, Aeson.toJSON <$> genJsonText) - , (fromIntegral (signum sz), - Aeson.toJSON <$> Gen.scale (`div` 2) genJsonList) - , (fromIntegral (signum sz), - Aeson.object <$> Gen.scale (`div` 2) genJsonMap) - ] - - genJsonNumber :: Gen Integer - genJsonNumber = Gen.integral - (Range.linear - (-fromIntegral (maxBound :: Word64) :: Integer) - ( fromIntegral (maxBound :: Word64) :: Integer)) - - genJsonText :: Gen Text - genJsonText = Gen.choice - [ Gen.ensure validText (genText 64) - , Gen.ensure validText ((bytesPrefix <>) <$> genText 62) - , genBytes - , Text.pack . show <$> genJsonNumber - ] - where - validText t = BS.length (Text.encodeUtf8 t) <= 64 - bytesPrefix = "0x" - genText sz = Text.pack <$> Gen.list (Range.linear 0 sz) Gen.alphaNum - genBytes = (bytesPrefix <>) - . Text.decodeUtf8 - . Base16.encode - . BS.pack - <$> Gen.list (Range.linear 0 64) - (Gen.word8 Range.constantBounded) - - genJsonList :: Gen [Aeson.Value] - genJsonList = Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) genJsonValue - - genJsonKey :: Gen Aeson.Key - genJsonKey = fmap Aeson.fromText genJsonText - - genJsonMap :: Gen [(Aeson.Key, Aeson.Value)] - genJsonMap = Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) $ - (,) <$> genJsonKey <*> genJsonValue - + where + genJsonValue :: Gen Aeson.Value + genJsonValue = + Gen.sized $ \sz -> + Gen.frequency + [ (1, Aeson.toJSON <$> genJsonNumber) + , (2, Aeson.toJSON <$> genJsonText) + , + ( fromIntegral (signum sz) + , Aeson.toJSON <$> Gen.scale (`div` 2) genJsonList + ) + , + ( fromIntegral (signum sz) + , Aeson.object <$> Gen.scale (`div` 2) genJsonMap + ) + ] + genJsonNumber :: Gen Integer + genJsonNumber = + Gen.integral + ( Range.linear + (-fromIntegral (maxBound :: Word64) :: Integer) + (fromIntegral (maxBound :: Word64) :: Integer) + ) + + genJsonText :: Gen Text + genJsonText = + Gen.choice + [ Gen.ensure validText (genText 64) + , Gen.ensure validText ((bytesPrefix <>) <$> genText 62) + , genBytes + , Text.pack . show <$> genJsonNumber + ] + where + validText t = BS.length (Text.encodeUtf8 t) <= 64 + bytesPrefix = "0x" + genText sz = Text.pack <$> Gen.list (Range.linear 0 sz) Gen.alphaNum + genBytes = + (bytesPrefix <>) + . Text.decodeUtf8 + . Base16.encode + . BS.pack + <$> Gen.list + (Range.linear 0 64) + (Gen.word8 Range.constantBounded) + + genJsonList :: Gen [Aeson.Value] + genJsonList = Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) genJsonValue + + genJsonKey :: Gen Aeson.Key + genJsonKey = fmap Aeson.fromText genJsonText + + genJsonMap :: Gen [(Aeson.Key, Aeson.Value)] + genJsonMap = Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) $ + (,) <$> genJsonKey <*> genJsonValue genJsonForTxMetadataValue TxMetadataJsonDetailedSchema = genJsonValue - where - genJsonValue :: Gen Aeson.Value - genJsonValue = - Gen.sized $ \sz -> - Gen.frequency - [ (1, singleFieldObject "int" <$> genJsonNumber) - , (1, singleFieldObject "bytes" <$> genJsonBytes) - , (1, singleFieldObject "string" <$> genJsonText) - , (fromIntegral (signum sz), - singleFieldObject "list" <$> - Gen.scale (`div` 2) genJsonList) - , (fromIntegral (signum sz), - singleFieldObject "map" <$> - Gen.scale (`div` 2) genJsonMap) - ] - - singleFieldObject name v = Aeson.object [(name, v)] - - genJsonNumber :: Gen Aeson.Value - genJsonNumber = toJSON <$> - Gen.integral - (Range.linear - (-fromIntegral (maxBound :: Word64) :: Integer) - ( fromIntegral (maxBound :: Word64) :: Integer)) - - genJsonBytes :: Gen Aeson.Value - genJsonBytes = toJSON - . Text.decodeLatin1 - . Base16.encode - . BS.pack - <$> Gen.list (Range.linear 0 64) - (Gen.word8 Range.constantBounded) - - genJsonText :: Gen Aeson.Value - genJsonText = fmap toJSON $ - Gen.ensure validText $ - Text.pack <$> Gen.list (Range.linear 0 64) Gen.alphaNum - where - validText t = BS.length (Text.encodeUtf8 t) <= 64 - - genJsonList :: Gen Aeson.Value - genJsonList = fmap toJSON $ - Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) genJsonValue - - genJsonMap :: Gen Aeson.Value - genJsonMap = fmap toJSON $ - Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) $ - mkKVPair <$> genJsonValue <*> genJsonValue - where - mkKVPair :: Aeson.Value -> Aeson.Value -> Aeson.Value - mkKVPair k v = Aeson.object [ ("k", k), ("v", v) ] + where + genJsonValue :: Gen Aeson.Value + genJsonValue = + Gen.sized $ \sz -> + Gen.frequency + [ (1, singleFieldObject "int" <$> genJsonNumber) + , (1, singleFieldObject "bytes" <$> genJsonBytes) + , (1, singleFieldObject "string" <$> genJsonText) + , + ( fromIntegral (signum sz) + , singleFieldObject "list" + <$> Gen.scale (`div` 2) genJsonList + ) + , + ( fromIntegral (signum sz) + , singleFieldObject "map" + <$> Gen.scale (`div` 2) genJsonMap + ) + ] + + singleFieldObject name v = Aeson.object [(name, v)] + + genJsonNumber :: Gen Aeson.Value + genJsonNumber = + toJSON + <$> Gen.integral + ( Range.linear + (-fromIntegral (maxBound :: Word64) :: Integer) + (fromIntegral (maxBound :: Word64) :: Integer) + ) + + genJsonBytes :: Gen Aeson.Value + genJsonBytes = + toJSON + . Text.decodeLatin1 + . Base16.encode + . BS.pack + <$> Gen.list + (Range.linear 0 64) + (Gen.word8 Range.constantBounded) + + genJsonText :: Gen Aeson.Value + genJsonText = + fmap toJSON $ + Gen.ensure validText $ + Text.pack <$> Gen.list (Range.linear 0 64) Gen.alphaNum + where + validText t = BS.length (Text.encodeUtf8 t) <= 64 + + genJsonList :: Gen Aeson.Value + genJsonList = fmap toJSON $ + Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) genJsonValue + genJsonMap :: Gen Aeson.Value + genJsonMap = fmap toJSON $ + Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) $ + mkKVPair <$> genJsonValue <*> genJsonValue + where + mkKVPair :: Aeson.Value -> Aeson.Value -> Aeson.Value + mkKVPair k v = Aeson.object [("k", k), ("v", v)] genTxMetadata :: Gen TxMetadata genTxMetadata = - Gen.sized $ \sz -> - TxMetadata . Map.fromList <$> - Gen.list (Range.linear 0 (fromIntegral sz)) - ((,) <$> Gen.word64 Range.constantBounded - <*> genTxMetadataValue) + Gen.sized $ \sz -> + TxMetadata . Map.fromList + <$> Gen.list + (Range.linear 0 (fromIntegral sz)) + ( (,) + <$> Gen.word64 Range.constantBounded + <*> genTxMetadataValue + ) genTxMetadataValue :: Gen TxMetadataValue genTxMetadataValue = - Gen.sized $ \sz -> - Gen.frequency - [ (1, TxMetaNumber <$> genTxMetaNumber) - , (1, TxMetaBytes <$> genTxMetaBytes) - , (1, TxMetaText <$> genTxMetaText) - , (fromIntegral (signum sz), - TxMetaList <$> Gen.scale (`div` 2) genTxMetaList) - , (fromIntegral (signum sz), - TxMetaMap <$> Gen.scale (`div` 2) genTxMetaMap) - ] - where - genTxMetaNumber :: Gen Integer - genTxMetaNumber = Gen.integral - (Range.linear - (-fromIntegral (maxBound :: Word64) :: Integer) - ( fromIntegral (maxBound :: Word64) :: Integer)) - - genTxMetaBytes :: Gen ByteString - genTxMetaBytes = BS.pack <$> Gen.list (Range.linear 0 64) - (Gen.word8 Range.constantBounded) - - genTxMetaText :: Gen Text - genTxMetaText = Text.pack <$> Gen.list (Range.linear 0 64) Gen.alphaNum - - genTxMetaList :: Gen [TxMetadataValue] - genTxMetaList = Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) - genTxMetadataValue - - genTxMetaMap :: Gen [(TxMetadataValue, TxMetadataValue)] - genTxMetaMap = Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) $ - (,) <$> genTxMetadataValue <*> genTxMetadataValue + Gen.sized $ \sz -> + Gen.frequency + [ (1, TxMetaNumber <$> genTxMetaNumber) + , (1, TxMetaBytes <$> genTxMetaBytes) + , (1, TxMetaText <$> genTxMetaText) + , + ( fromIntegral (signum sz) + , TxMetaList <$> Gen.scale (`div` 2) genTxMetaList + ) + , + ( fromIntegral (signum sz) + , TxMetaMap <$> Gen.scale (`div` 2) genTxMetaMap + ) + ] + where + genTxMetaNumber :: Gen Integer + genTxMetaNumber = + Gen.integral + ( Range.linear + (-fromIntegral (maxBound :: Word64) :: Integer) + (fromIntegral (maxBound :: Word64) :: Integer) + ) + + genTxMetaBytes :: Gen ByteString + genTxMetaBytes = + BS.pack + <$> Gen.list + (Range.linear 0 64) + (Gen.word8 Range.constantBounded) + + genTxMetaText :: Gen Text + genTxMetaText = Text.pack <$> Gen.list (Range.linear 0 64) Gen.alphaNum + + genTxMetaList :: Gen [TxMetadataValue] + genTxMetaList = Gen.sized $ \sz -> + Gen.list + (Range.linear 0 (fromIntegral sz)) + genTxMetadataValue + + genTxMetaMap :: Gen [(TxMetadataValue, TxMetadataValue)] + genTxMetaMap = Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) $ + (,) <$> genTxMetadataValue <*> genTxMetadataValue diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs b/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs index 84ab63c241..f05434ddc2 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs @@ -1,25 +1,22 @@ module Test.Gen.Cardano.Api.ProtocolParameters where -import Cardano.Api -import Cardano.Api.Ledger -import Cardano.Api.ProtocolParameters - -import Test.Gen.Cardano.Api.Typed (genCostModels) - -import Test.Cardano.Ledger.Alonzo.Arbitrary () -import Test.Cardano.Ledger.Conway.Arbitrary () - -import Hedgehog (MonadGen) +import Cardano.Api +import Cardano.Api.Ledger +import Cardano.Api.ProtocolParameters +import Hedgehog (MonadGen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen.QuickCheck as Q +import Test.Cardano.Ledger.Alonzo.Arbitrary () +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Gen.Cardano.Api.Typed (genCostModels) genStrictMaybe :: MonadGen m => m a -> m (StrictMaybe a) genStrictMaybe gen = Gen.sized $ \n -> - Gen.frequency [ - (2, pure SNothing), - (1 + fromIntegral n, SJust<$> gen) - ] + Gen.frequency + [ (2, pure SNothing) + , (1 + fromIntegral n, SJust <$> gen) + ] genCommonProtocolParametersUpdate :: MonadGen m => m CommonProtocolParametersUpdate genCommonProtocolParametersUpdate = @@ -77,50 +74,56 @@ genIntroducedInConwayPParams = <*> genStrictMaybe Q.arbitrary <*> genStrictMaybe Q.arbitrary -genShelleyEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ShelleyEra) +genShelleyEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate ShelleyEra) genShelleyEraBasedProtocolParametersUpdate = ShelleyEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genDeprecatedAfterMaryPParams - <*> genDeprecatedAfterBabbagePParams - <*> genShelleyToAlonzoPParams + <$> genCommonProtocolParametersUpdate + <*> genDeprecatedAfterMaryPParams + <*> genDeprecatedAfterBabbagePParams + <*> genShelleyToAlonzoPParams -genAllegraEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AllegraEra) +genAllegraEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate AllegraEra) genAllegraEraBasedProtocolParametersUpdate = AllegraEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genDeprecatedAfterMaryPParams - <*> genShelleyToAlonzoPParams - <*> genDeprecatedAfterBabbagePParams + <$> genCommonProtocolParametersUpdate + <*> genDeprecatedAfterMaryPParams + <*> genShelleyToAlonzoPParams + <*> genDeprecatedAfterBabbagePParams -genMaryEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate MaryEra) +genMaryEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate MaryEra) genMaryEraBasedProtocolParametersUpdate = MaryEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genDeprecatedAfterMaryPParams - <*> genShelleyToAlonzoPParams - <*> genDeprecatedAfterBabbagePParams + <$> genCommonProtocolParametersUpdate + <*> genDeprecatedAfterMaryPParams + <*> genShelleyToAlonzoPParams + <*> genDeprecatedAfterBabbagePParams -genAlonzoEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AlonzoEra) +genAlonzoEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate AlonzoEra) genAlonzoEraBasedProtocolParametersUpdate = AlonzoEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genShelleyToAlonzoPParams - <*> genAlonzoOnwardsPParams - <*> genDeprecatedAfterBabbagePParams + <$> genCommonProtocolParametersUpdate + <*> genShelleyToAlonzoPParams + <*> genAlonzoOnwardsPParams + <*> genDeprecatedAfterBabbagePParams -genBabbageEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate BabbageEra) +genBabbageEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate BabbageEra) genBabbageEraBasedProtocolParametersUpdate = BabbageEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genAlonzoOnwardsPParams - <*> genDeprecatedAfterBabbagePParams - <*> genIntroducedInBabbagePParams + <$> genCommonProtocolParametersUpdate + <*> genAlonzoOnwardsPParams + <*> genDeprecatedAfterBabbagePParams + <*> genIntroducedInBabbagePParams -genConwayEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ConwayEra) +genConwayEraBasedProtocolParametersUpdate + :: MonadGen m => m (EraBasedProtocolParametersUpdate ConwayEra) genConwayEraBasedProtocolParametersUpdate = ConwayEraBasedProtocolParametersUpdate - <$> genCommonProtocolParametersUpdate - <*> genAlonzoOnwardsPParams - <*> genIntroducedInBabbagePParams - <*> genIntroducedInConwayPParams + <$> genCommonProtocolParametersUpdate + <*> genAlonzoOnwardsPParams + <*> genIntroducedInBabbagePParams + <*> genIntroducedInConwayPParams diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 980d4e89f5..9de83d4119 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -8,20 +8,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -Wno-deprecations #-} module Test.Gen.Cardano.Api.Typed ( genFeaturedInEra , genMaybeFeaturedInEra - -- * Byron + -- * Byron , genAddressInEraByron , genAddressByron , genTxBodyByron , genTxByron , genWitnessesByron - , genAddressInEra , genAddressShelley , genCertificate @@ -36,7 +34,6 @@ module Test.Gen.Cardano.Api.Typed , genByronKeyWitness , genCardanoKeyWitness , genShelleyKeyWitness - , genTxId , genTxIn , genTxOutTxContext @@ -55,7 +52,6 @@ module Test.Gen.Cardano.Api.Typed , genScriptData , genScriptDataSchema , genScriptValidity - , genAssetName , genAssetId , genEpochNo @@ -121,30 +117,29 @@ module Test.Gen.Cardano.Api.Typed , genValueForTxOut , genWitnesses , genWitnessNetworkIdOrByronAddress - , genRational - , genGovernancePoll , genGovernancePollAnswer - , genProposals , genProposal , genVotingProcedures - ) where + ) +where -import Cardano.Api hiding (txIns) +import Cardano.Api hiding (txIns) import qualified Cardano.Api as Api -import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), - WitnessNetworkIdOrByronAddress (..)) +import Cardano.Api.Byron + ( KeyWitness (ByronKeyWitness) + , WitnessNetworkIdOrByronAddress (..) + ) import qualified Cardano.Api.Byron as Byron -import Cardano.Api.Eon.AllegraEraOnwards (allegraEraOnwardsToShelleyBasedEra) -import Cardano.Api.Error +import Cardano.Api.Eon.AllegraEraOnwards (allegraEraOnwardsToShelleyBasedEra) +import Cardano.Api.Error import qualified Cardano.Api.Ledger as L import qualified Cardano.Api.Ledger.Lens as A -import Cardano.Api.Script (scriptInEraToRefScript) -import Cardano.Api.Shelley +import Cardano.Api.Script (scriptInEraToRefScript) +import Cardano.Api.Shelley import qualified Cardano.Api.Shelley as ShelleyApi - import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.Hash.Class as CRYPTO @@ -152,46 +147,46 @@ import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Core as Ledger -import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) - -import Control.Applicative (Alternative (..), optional) -import Data.ByteString (ByteString) +import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) +import Control.Applicative (Alternative (..), optional) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS -import Data.Coerce -import Data.Int (Int64) -import Data.Maybe -import Data.OSet.Strict (OSet) +import Data.Coerce +import Data.Int (Int64) +import Data.Maybe +import Data.OSet.Strict (OSet) import qualified Data.OSet.Strict as OSet -import Data.Ratio (Ratio, (%)) -import Data.String -import Data.Word (Word16, Word32, Word64) -import Numeric.Natural (Natural) - -import Test.Gen.Cardano.Api.Era -import Test.Gen.Cardano.Api.Metadata (genTxMetadata) - -import Test.Cardano.Chain.UTxO.Gen (genVKWitness) -import Test.Cardano.Crypto.Gen (genProtocolMagicId) -import Test.Cardano.Ledger.Conway.Arbitrary () -import Test.Cardano.Ledger.Core.Arbitrary () - -import Hedgehog (Gen, MonadGen, Range) +import Data.Ratio (Ratio, (%)) +import Data.String +import Data.Word (Word16, Word32, Word64) +import Hedgehog (Gen, MonadGen, Range) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen.QuickCheck as Q import qualified Hedgehog.Range as Range +import Numeric.Natural (Natural) +import Test.Cardano.Chain.UTxO.Gen (genVKWitness) +import Test.Cardano.Crypto.Gen (genProtocolMagicId) +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Gen.Cardano.Api.Era +import Test.Gen.Cardano.Api.Metadata (genTxMetadata) {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Use let" -} genAddressByron :: Gen (Address ByronAddr) -genAddressByron = makeByronAddress <$> genNetworkId - <*> genVerificationKey AsByronKey +genAddressByron = + makeByronAddress + <$> genNetworkId + <*> genVerificationKey AsByronKey genAddressShelley :: Gen (Address ShelleyAddr) -genAddressShelley = makeShelleyAddress <$> genNetworkId - <*> genPaymentCredential - <*> genStakeAddressReference +genAddressShelley = + makeShelleyAddress + <$> genNetworkId + <*> genPaymentCredential + <*> genStakeAddressReference genAddressInEra :: ShelleyBasedEra era -> Gen (AddressInEra era) genAddressInEra sbe = shelleyAddressInEra sbe <$> genAddressShelley @@ -208,45 +203,43 @@ genLovelace = L.Coin <$> Gen.integral (Range.linear 0 5000) genPositiveLovelace :: Gen L.Coin genPositiveLovelace = L.Coin <$> Gen.integral (Range.linear 1 5000) - ---------------------------------------------------------------------------- -- SimpleScript generators -- genScript :: ScriptLanguage lang -> Gen (Script lang) genScript SimpleScriptLanguage = - SimpleScript <$> genSimpleScript + SimpleScript <$> genSimpleScript genScript (PlutusScriptLanguage lang) = - PlutusScript lang <$> genPlutusScript lang + PlutusScript lang <$> genPlutusScript lang genSimpleScript :: Gen SimpleScript genSimpleScript = - genTerm - where - genTerm = Gen.recursive Gen.choice nonRecursive recursive - - -- Non-recursive generators - nonRecursive = - [ RequireSignature . verificationKeyHash <$> genVerificationKey AsPaymentKey - , RequireTimeBefore <$> genSlotNo - , RequireTimeAfter <$> genSlotNo - ] - - -- Recursive generators - recursive = - [ RequireAllOf <$> Gen.list (Range.linear 0 10) genTerm + genTerm + where + genTerm = Gen.recursive Gen.choice nonRecursive recursive - , RequireAnyOf <$> Gen.list (Range.linear 0 10) genTerm + -- Non-recursive generators + nonRecursive = + [ RequireSignature . verificationKeyHash <$> genVerificationKey AsPaymentKey + , RequireTimeBefore <$> genSlotNo + , RequireTimeAfter <$> genSlotNo + ] - , do ts <- Gen.list (Range.linear 0 10) genTerm - m <- Gen.integral (Range.constant 0 (length ts)) - return (RequireMOf m ts) - ] + -- Recursive generators + recursive = + [ RequireAllOf <$> Gen.list (Range.linear 0 10) genTerm + , RequireAnyOf <$> Gen.list (Range.linear 0 10) genTerm + , do + ts <- Gen.list (Range.linear 0 10) genTerm + m <- Gen.integral (Range.constant 0 (length ts)) + return (RequireMOf m ts) + ] genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genPlutusScript _ = - -- We make no attempt to create a valid script - PlutusScriptSerialised . SBS.toShort <$> Gen.bytes (Range.linear 0 32) + -- We make no attempt to create a valid script + PlutusScriptSerialised . SBS.toShort <$> Gen.bytes (Range.linear 0 32) genScriptDataSchema :: Gen ScriptDataJsonSchema genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema] @@ -261,46 +254,53 @@ genHashableScriptData = do {-# DEPRECATED genScriptData "Use genHashableScriptData" #-} genScriptData :: Gen ScriptData genScriptData = - Gen.recursive - Gen.choice - [ ScriptDataNumber <$> genInteger - , ScriptDataBytes <$> genByteString - ] - -- The Gen.recursive combinator calls these with the size halved - [ ScriptDataConstructor <$> genConstructorInteger - <*> genScriptDataList - , ScriptDataList <$> genScriptDataList - , ScriptDataMap <$> genScriptDataMap - ] - where - genInteger :: Gen Integer - genInteger = Gen.integral - (Range.linear - (-fromIntegral (maxBound :: Word64) :: Integer) - (2 * fromIntegral (maxBound :: Word64) :: Integer)) - - - genConstructorInteger :: Gen Integer - genConstructorInteger = Gen.integral - (Range.linear - 0 -- TODO: Alonzo should be -> (-fromIntegral (maxBound :: Word64) :: Integer) - -- Wrapping bug needs to be fixed in Plutus library - (fromIntegral (maxBound :: Word64) :: Integer)) - - genByteString :: Gen ByteString - genByteString = BS.pack <$> Gen.list (Range.linear 0 64) - (Gen.word8 Range.constantBounded) - - genScriptDataList :: Gen [ScriptData] - genScriptDataList = - Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) genScriptData - - genScriptDataMap :: Gen [(ScriptData, ScriptData)] - genScriptDataMap = - Gen.sized $ \sz -> - Gen.list (Range.linear 0 (fromIntegral sz)) $ - (,) <$> genScriptData <*> genScriptData + Gen.recursive + Gen.choice + [ ScriptDataNumber <$> genInteger + , ScriptDataBytes <$> genByteString + ] + -- The Gen.recursive combinator calls these with the size halved + [ ScriptDataConstructor + <$> genConstructorInteger + <*> genScriptDataList + , ScriptDataList <$> genScriptDataList + , ScriptDataMap <$> genScriptDataMap + ] + where + genInteger :: Gen Integer + genInteger = + Gen.integral + ( Range.linear + (-fromIntegral (maxBound :: Word64) :: Integer) + (2 * fromIntegral (maxBound :: Word64) :: Integer) + ) + + genConstructorInteger :: Gen Integer + genConstructorInteger = + Gen.integral + ( Range.linear + 0 -- TODO: Alonzo should be -> (-fromIntegral (maxBound :: Word64) :: Integer) + -- Wrapping bug needs to be fixed in Plutus library + (fromIntegral (maxBound :: Word64) :: Integer) + ) + + genByteString :: Gen ByteString + genByteString = + BS.pack + <$> Gen.list + (Range.linear 0 64) + (Gen.word8 Range.constantBounded) + + genScriptDataList :: Gen [ScriptData] + genScriptDataList = + Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) genScriptData + + genScriptDataMap :: Gen [(ScriptData, ScriptData)] + genScriptDataMap = + Gen.sized $ \sz -> + Gen.list (Range.linear 0 (fromIntegral sz)) $ + (,) <$> genScriptData <*> genScriptData -- ---------------------------------------------------------------------------- -- Script generators for any language, or any language valid in a specific era @@ -308,23 +308,24 @@ genScriptData = genScriptInAnyLang :: Gen ScriptInAnyLang genScriptInAnyLang = - Gen.choice - [ ScriptInAnyLang lang <$> genScript lang - | AnyScriptLanguage lang <- [minBound..maxBound] ] + Gen.choice + [ ScriptInAnyLang lang <$> genScript lang + | AnyScriptLanguage lang <- [minBound .. maxBound] + ] genScriptInEra :: ShelleyBasedEra era -> Gen (ScriptInEra era) genScriptInEra era = - Gen.choice - [ ScriptInEra langInEra <$> genScript lang - | AnyScriptLanguage lang <- [minBound..maxBound] - -- TODO: scriptLanguageSupportedInEra should be parameterized on ShelleyBasedEra - , Just langInEra <- [scriptLanguageSupportedInEra era lang] ] + Gen.choice + [ ScriptInEra langInEra <$> genScript lang + | AnyScriptLanguage lang <- [minBound .. maxBound] + , -- TODO: scriptLanguageSupportedInEra should be parameterized on ShelleyBasedEra + Just langInEra <- [scriptLanguageSupportedInEra era lang] + ] genScriptHash :: Gen ScriptHash genScriptHash = do - ScriptInAnyLang _ script <- genScriptInAnyLang - return (hashScript script) - + ScriptInAnyLang _ script <- genScriptInAnyLang + return (hashScript script) ---------------------------------------------------------------------------- -- Multi-asset generators @@ -335,18 +336,17 @@ genAssetName = Gen.frequency -- mostly from a small number of choices, so we get plenty of repetition [ (9, Gen.element ["", "a", "b", "c"]) - , (1, AssetName <$> Gen.bytes (Range.singleton 32)) + , (1, AssetName <$> Gen.bytes (Range.singleton 32)) , (1, AssetName <$> Gen.bytes (Range.constant 1 31)) ] genPolicyId :: Gen PolicyId genPolicyId = Gen.frequency - -- mostly from a small number of choices, so we get plenty of repetition - [ (9, Gen.element [ fromString (x : replicate 55 '0') | x <- ['a'..'c'] ]) - - -- and some from the full range of the type - , (1, PolicyId <$> genScriptHash) + -- mostly from a small number of choices, so we get plenty of repetition + [ (9, Gen.element [fromString (x : replicate 55 '0') | x <- ['a' .. 'c']]) + , -- and some from the full range of the type + (1, PolicyId <$> genScriptHash) ] genAssetId :: Gen AssetId @@ -363,9 +363,10 @@ genSignedQuantity = genQuantity (Range.constantFrom 0 (-2) 2) -- | Generate a positive or negative, but not zero quantity. genSignedNonZeroQuantity :: Gen Quantity genSignedNonZeroQuantity = - Gen.choice [ genQuantity (Range.constant (-2) (-1)) - , genQuantity (Range.constant 1 2) - ] + Gen.choice + [ genQuantity (Range.constant (-2) (-1)) + , genQuantity (Range.constant 1 2) + ] genUnsignedQuantity :: Gen Quantity genUnsignedQuantity = genQuantity (Range.constant 0 2) @@ -373,11 +374,13 @@ genUnsignedQuantity = genQuantity (Range.constant 0 2) genPositiveQuantity :: Gen Quantity genPositiveQuantity = genQuantity (Range.constant 1 2) -genValue :: MaryEraOnwards era -> Gen AssetId -> Gen Quantity -> Gen (L.Value (ShelleyLedgerEra era)) +genValue + :: MaryEraOnwards era -> Gen AssetId -> Gen Quantity -> Gen (L.Value (ShelleyLedgerEra era)) genValue w genAId genQuant = - toLedgerValue w . valueFromList <$> - Gen.list (Range.constant 0 10) - ((,) <$> genAId <*> genQuant) + toLedgerValue w . valueFromList + <$> Gen.list + (Range.constant 0 10) + ((,) <$> genAId <*> genQuant) -- | Generate a 'Value' with any asset ID and a positive or negative quantity. genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era)) @@ -388,10 +391,10 @@ genValueDefault w = genValue w genAssetId genSignedNonZeroQuantity genValueForMinting :: MaryEraOnwards era -> Gen Value genValueForMinting w = fromLedgerValue sbe <$> genValue w genAssetIdNoAda genSignedNonZeroQuantity - where - sbe = maryEraOnwardsToShelleyBasedEra w - genAssetIdNoAda :: Gen AssetId - genAssetIdNoAda = AssetId <$> genPolicyId <*> genAssetName + where + sbe = maryEraOnwardsToShelleyBasedEra w + genAssetIdNoAda :: Gen AssetId + genAssetIdNoAda = AssetId <$> genPolicyId <*> genAssetName -- | Generate a 'Value' suitable for usage in a transaction output, i.e. any -- asset ID and a positive quantity. @@ -404,13 +407,12 @@ genValueForTxOut sbe = do -- Generate a potentially empty list with multi assets caseShelleyToAllegraOrMaryEraOnwards (const (pure ada)) - (\w -> do - v <- genValue w genAssetId genPositiveQuantity - pure $ ada <> v + ( \w -> do + v <- genValue w genAssetId genPositiveQuantity + pure $ ada <> v ) sbe - -- Note that we expect to sometimes generate duplicate policy id keys since we -- pick 90% of policy ids from a set of just three. genValueNestedRep :: Gen ValueNestedRep @@ -421,9 +423,11 @@ genValueNestedBundle :: Gen ValueNestedBundle genValueNestedBundle = Gen.choice [ ValueNestedBundleAda <$> genSignedQuantity - , ValueNestedBundle <$> genPolicyId - <*> Gen.map (Range.constant 0 5) - ((,) <$> genAssetName <*> genSignedQuantity) + , ValueNestedBundle + <$> genPolicyId + <*> Gen.map + (Range.constant 0 5) + ((,) <$> genAssetName <*> genSignedQuantity) ] genNetworkId :: Gen NetworkId @@ -442,28 +446,35 @@ genOperationalCertificate = fst <$> genOperationalCertificateWithCounter genOperationalCertificateIssueCounter :: Gen OperationalCertificateIssueCounter genOperationalCertificateIssueCounter = snd <$> genOperationalCertificateWithCounter -genOperationalCertificateWithCounter :: Gen (OperationalCertificate, OperationalCertificateIssueCounter) +genOperationalCertificateWithCounter + :: Gen (OperationalCertificate, OperationalCertificateIssueCounter) genOperationalCertificateWithCounter = do - kesVKey <- genVerificationKey AsKesKey - stkPoolOrGenDelExtSign <- Gen.either (genSigningKey AsStakePoolKey) (genSigningKey AsGenesisDelegateExtendedKey) - kesP <- genKESPeriod - c <- Gen.integral $ Range.linear 0 1000 - let stakePoolVer = either getVerificationKey (convert . getVerificationKey) stkPoolOrGenDelExtSign - iCounter = OperationalCertificateIssueCounter c stakePoolVer - - case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of - -- This case should be impossible as we clearly derive the verification - -- key from the generated signing key. - Left err -> fail $ docToString $ prettyError err - Right pair -> return pair - where - convert :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey StakePoolKey - convert = (castVerificationKey :: VerificationKey GenesisDelegateKey - -> VerificationKey StakePoolKey) - . (castVerificationKey :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey GenesisDelegateKey) - + kesVKey <- genVerificationKey AsKesKey + stkPoolOrGenDelExtSign <- + Gen.either (genSigningKey AsStakePoolKey) (genSigningKey AsGenesisDelegateExtendedKey) + kesP <- genKESPeriod + c <- Gen.integral $ Range.linear 0 1000 + let stakePoolVer = either getVerificationKey (convert . getVerificationKey) stkPoolOrGenDelExtSign + iCounter = OperationalCertificateIssueCounter c stakePoolVer + + case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of + -- This case should be impossible as we clearly derive the verification + -- key from the generated signing key. + Left err -> fail $ docToString $ prettyError err + Right pair -> return pair + where + convert + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey StakePoolKey + convert = + ( castVerificationKey + :: VerificationKey GenesisDelegateKey + -> VerificationKey StakePoolKey + ) + . ( castVerificationKey + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey GenesisDelegateKey + ) -- TODO: Generate payment credential via script genPaymentCredential :: Gen PaymentCredential @@ -473,12 +484,12 @@ genPaymentCredential = do genSigningKey :: Key keyrole => ShelleyApi.AsType keyrole -> Gen (SigningKey keyrole) genSigningKey roletoken = do - seed <- genSeed (fromIntegral seedSize) - let sk = deterministicSigningKey roletoken seed - return sk - where - seedSize :: Word - seedSize = deterministicSigningKeySeedSize roletoken + seed <- genSeed (fromIntegral seedSize) + let sk = deterministicSigningKey roletoken seed + return sk + where + seedSize :: Word + seedSize = deterministicSigningKeySeedSize roletoken genStakeAddress :: Gen StakeAddress genStakeAddress = makeStakeAddress <$> genNetworkId <*> genStakeCredential @@ -517,24 +528,27 @@ genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe genTxOutTxContext :: ShelleyBasedEra era -> Gen (TxOut CtxTx era) genTxOutTxContext era = - TxOut <$> genAddressInEra era - <*> genTxOutValue era - <*> genTxOutDatumHashTxContext era - <*> genReferenceScript era + TxOut + <$> genAddressInEra era + <*> genTxOutValue era + <*> genTxOutDatumHashTxContext era + <*> genReferenceScript era genTxOutUTxOContext :: ShelleyBasedEra era -> Gen (TxOut CtxUTxO era) genTxOutUTxOContext era = - TxOut <$> genAddressInEra era - <*> genTxOutValue era - <*> genTxOutDatumHashUTxOContext era - <*> genReferenceScript era + TxOut + <$> genAddressInEra era + <*> genTxOutValue era + <*> genTxOutDatumHashUTxOContext era + <*> genReferenceScript era genReferenceScript :: ShelleyBasedEra era -> Gen (ReferenceScript era) genReferenceScript era = scriptInEraToRefScript <$> genScriptInEra era genUTxO :: ShelleyBasedEra era -> Gen (UTxO era) genUTxO era = - UTxO <$> Gen.map (Range.constant 0 5) ((,) <$> genTxIn <*> (toCtxUTxOTxOut <$> genTxOutTxContext era)) + UTxO + <$> Gen.map (Range.constant 0 5) ((,) <$> genTxIn <*> (toCtxUTxOTxOut <$> genTxOutTxContext era)) genTtl :: Gen SlotNo genTtl = genSlotNo @@ -555,43 +569,48 @@ genTxMetadataInEra :: CardanoEra era -> Gen (TxMetadataInEra era) genTxMetadataInEra = inEonForEra (pure TxMetadataNone) - (\w -> - Gen.choice - [ pure TxMetadataNone - , TxMetadataInEra w <$> genTxMetadata - ] + ( \w -> + Gen.choice + [ pure TxMetadataNone + , TxMetadataInEra w <$> genTxMetadata + ] ) genTxAuxScripts :: ShelleyBasedEra era -> Gen (TxAuxScripts era) genTxAuxScripts era = - forEraInEon (toCardanoEra era) + forEraInEon + (toCardanoEra era) (pure TxAuxScriptsNone) - (\w -> TxAuxScripts w <$> Gen.list (Range.linear 0 3) - (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w))) + ( \w -> + TxAuxScripts w + <$> Gen.list + (Range.linear 0 3) + (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w)) + ) genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals BuildTx era) genTxWithdrawals = inEonForEra (pure TxWithdrawalsNone) - (\w -> - Gen.choice - [ pure TxWithdrawalsNone - , pure (TxWithdrawals w mempty) + ( \w -> + Gen.choice + [ pure TxWithdrawalsNone + , pure (TxWithdrawals w mempty) -- TODO: Generate withdrawals - ] + ] ) genTxCertificates :: CardanoEra era -> Gen (TxCertificates BuildTx era) genTxCertificates = inEonForEra (pure TxCertificatesNone) - (\w -> do - certs <- Gen.list (Range.constant 0 3) $ genCertificate w - Gen.choice - [ pure TxCertificatesNone - , pure (TxCertificates w certs $ BuildTxWith mempty) + ( \w -> do + certs <- Gen.list (Range.constant 0 3) $ genCertificate w + Gen.choice + [ pure TxCertificatesNone + , pure (TxCertificates w certs $ BuildTxWith mempty) -- TODO: Generate certificates - ] + ] ) -- TODO: Add remaining certificates @@ -606,36 +625,41 @@ genCertificate sbe = genStakeAddressRequirements :: ShelleyBasedEra era -> Gen (StakeAddressRequirements era) genStakeAddressRequirements = caseShelleyToBabbageOrConwayEraOnwards - (\w -> - StakeAddrRegistrationPreConway w - <$> genStakeCredential) - (\w -> StakeAddrRegistrationConway w - <$> genLovelace - <*> genStakeCredential) + ( \w -> + StakeAddrRegistrationPreConway w + <$> genStakeCredential + ) + ( \w -> + StakeAddrRegistrationConway w + <$> genLovelace + <*> genStakeCredential + ) genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era) genTxUpdateProposal sbe = - Gen.choice $ catMaybes - [ Just $ pure TxUpdateProposalNone - , forEraInEon sbe Nothing $ \w -> - Just $ TxUpdateProposal w <$> genUpdateProposal (toCardanoEra w) - ] + Gen.choice $ + catMaybes + [ Just $ pure TxUpdateProposalNone + , forEraInEon sbe Nothing $ \w -> + Just $ TxUpdateProposal w <$> genUpdateProposal (toCardanoEra w) + ] genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = inEonForEra (pure TxMintNone) - (\supported -> - Gen.choice - [ pure TxMintNone - , TxMintValue supported <$> genValueForMinting supported <*> return (BuildTxWith mempty) - ] + ( \supported -> + Gen.choice + [ pure TxMintNone + , TxMintValue supported <$> genValueForMinting supported <*> return (BuildTxWith mempty) + ] ) genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) genTxBodyContent sbe = do let era = toCardanoEra sbe - txIns <- map (, BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn + txIns <- + map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn txInsCollateral <- genTxInsCollateral era txInsReference <- genTxInsReference era txOuts <- Gen.list (Range.constant 1 10) (genTxOutTxContext sbe) @@ -646,8 +670,9 @@ genTxBodyContent sbe = do txValidityUpperBound <- genTxValidityUpperBound sbe txMetadata <- genTxMetadataInEra era txAuxScripts <- genTxAuxScripts sbe - let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes - txProtocolParams <- BuildTxWith <$> forEraInEon era (pure Nothing) (Gen.maybe . genValidProtocolParameters) + let txExtraKeyWits = TxExtraKeyWitnessesNone -- TODO: Alonzo era: Generate witness key hashes + txProtocolParams <- + BuildTxWith <$> forEraInEon era (pure Nothing) (Gen.maybe . genValidProtocolParameters) txWithdrawals <- genTxWithdrawals era txCertificates <- genTxCertificates era txUpdateProposal <- genTxUpdateProposal era @@ -657,40 +682,41 @@ genTxBodyContent sbe = do txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era txCurrentTreasuryValue <- genMaybeFeaturedInEra genCurrentTreasuryValue era txTreasuryDonation <- genMaybeFeaturedInEra genTreasuryDonation era - pure $ TxBodyContent - { Api.txIns - , Api.txInsCollateral - , Api.txInsReference - , Api.txOuts - , Api.txTotalCollateral - , Api.txReturnCollateral - , Api.txFee - , Api.txValidityLowerBound - , Api.txValidityUpperBound - , Api.txMetadata - , Api.txAuxScripts - , Api.txExtraKeyWits - , Api.txProtocolParams - , Api.txWithdrawals - , Api.txCertificates - , Api.txUpdateProposal - , Api.txMintValue - , Api.txScriptValidity - , Api.txProposalProcedures - , Api.txVotingProcedures - , Api.txCurrentTreasuryValue - , Api.txTreasuryDonation - } - + pure $ + TxBodyContent + { Api.txIns + , Api.txInsCollateral + , Api.txInsReference + , Api.txOuts + , Api.txTotalCollateral + , Api.txReturnCollateral + , Api.txFee + , Api.txValidityLowerBound + , Api.txValidityUpperBound + , Api.txMetadata + , Api.txAuxScripts + , Api.txExtraKeyWits + , Api.txProtocolParams + , Api.txWithdrawals + , Api.txCertificates + , Api.txUpdateProposal + , Api.txMintValue + , Api.txScriptValidity + , Api.txProposalProcedures + , Api.txVotingProcedures + , Api.txCurrentTreasuryValue + , Api.txTreasuryDonation + } genTxInsCollateral :: CardanoEra era -> Gen (TxInsCollateral era) genTxInsCollateral = inEonForEra (pure TxInsCollateralNone) - (\w -> Gen.choice - [ pure TxInsCollateralNone - , TxInsCollateral w <$> Gen.list (Range.linear 0 10) genTxIn - ] + ( \w -> + Gen.choice + [ pure TxInsCollateralNone + , TxInsCollateral w <$> Gen.list (Range.linear 0 10) genTxIn + ] ) genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era) @@ -701,9 +727,10 @@ genTxInsReference = genTxReturnCollateral :: ShelleyBasedEra era -> Gen (TxReturnCollateral CtxTx era) genTxReturnCollateral era = - forEraInEon (toCardanoEra era) + forEraInEon + (toCardanoEra era) (pure TxReturnCollateralNone) - (\w -> TxReturnCollateral w <$> genTxOutTxContext era) + (\w -> TxReturnCollateral w <$> genTxOutTxContext era) genTxTotalCollateral :: CardanoEra era -> Gen (TxTotalCollateral era) genTxTotalCollateral = @@ -728,14 +755,16 @@ genTxOutValueByron = TxOutValueByron <$> genPositiveLovelace genTxOutByron :: Gen (TxOut CtxTx ByronEra) genTxOutByron = - TxOut <$> genAddressInEraByron - <*> genTxOutValueByron - <*> pure TxOutDatumNone - <*> pure ReferenceScriptNone + TxOut + <$> genAddressInEraByron + <*> genTxOutValueByron + <*> pure TxOutDatumNone + <*> pure ReferenceScriptNone genTxBodyByron :: Gen (L.Annotated L.Tx ByteString) genTxBodyByron = do - txIns <- map (, BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn + txIns <- + map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn txOuts <- Gen.list (Range.constant 1 10) genTxOutByron case Api.makeByronTransactionBody txIns txOuts of Left err -> fail (displayError err) @@ -752,7 +781,8 @@ genTxBody era = do Right txBody -> pure txBody -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator. -genFeaturedInEra :: () +genFeaturedInEra + :: () => Alternative f => eon era -> f a @@ -761,7 +791,8 @@ genFeaturedInEra witness gen = Featured witness <$> gen -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator. -genMaybeFeaturedInEra :: () +genMaybeFeaturedInEra + :: () => Eon eon => Alternative f => (eon era -> f a) @@ -780,7 +811,8 @@ genTxScriptValidity = genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] -genTx :: () +genTx + :: () => ShelleyBasedEra era -> Gen (Tx era) genTx era = @@ -790,31 +822,32 @@ genTx era = genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era] genWitnesses sbe = do - bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) + bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) return $ bsWits ++ keyWits - -genVerificationKey :: () +genVerificationKey + :: () #if MIN_VERSION_base(4,17,0) - -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.6 complains if its not - -- present. - => HasTypeProxy keyrole + -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.6 complains if its not + -- present. + => HasTypeProxy keyrole #endif - => Key keyrole - => ShelleyApi.AsType keyrole - -> Gen (VerificationKey keyrole) + => Key keyrole + => ShelleyApi.AsType keyrole + -> Gen (VerificationKey keyrole) genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken -genVerificationKeyHash :: () +genVerificationKeyHash + :: () #if MIN_VERSION_base(4,17,0) - -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.6 complains if its not - -- present. - => HasTypeProxy keyrole + -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.6 complains if its not + -- present. + => HasTypeProxy keyrole #endif - => Key keyrole - => ShelleyApi.AsType keyrole - -> Gen (Hash keyrole) + => Key keyrole + => ShelleyApi.AsType keyrole + -> Gen (Hash keyrole) genVerificationKeyHash roletoken = verificationKeyHash <$> genVerificationKey roletoken @@ -831,16 +864,18 @@ genWitnessNetworkIdOrByronAddress = , WitnessByronAddress <$> genAddressByron ] -genShelleyBootstrapWitness :: () +genShelleyBootstrapWitness + :: () => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyBootstrapWitness sbe = - makeShelleyBootstrapWitness sbe - <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody sbe - <*> genSigningKey AsByronKey + makeShelleyBootstrapWitness sbe + <$> genWitnessNetworkIdOrByronAddress + <*> genTxBody sbe + <*> genSigningKey AsByronKey -genShelleyKeyWitness :: () +genShelleyKeyWitness + :: () => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyKeyWitness sbe = @@ -848,26 +883,29 @@ genShelleyKeyWitness sbe = <$> genTxBody sbe <*> genShelleyWitnessSigningKey -genShelleyWitness :: () +genShelleyWitness + :: () => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyWitness sbe = Gen.choice - [ genShelleyKeyWitness sbe - , genShelleyBootstrapWitness sbe - ] + [ genShelleyKeyWitness sbe + , genShelleyBootstrapWitness sbe + ] genShelleyWitnessSigningKey :: Gen ShelleyWitnessSigningKey genShelleyWitnessSigningKey = - Gen.choice [ WitnessPaymentKey <$> genSigningKey AsPaymentKey - , WitnessPaymentExtendedKey <$> genSigningKey AsPaymentExtendedKey - , WitnessStakeKey <$> genSigningKey AsStakeKey - , WitnessStakePoolKey <$> genSigningKey AsStakePoolKey - , WitnessGenesisDelegateKey <$> genSigningKey AsGenesisDelegateKey - , WitnessGenesisUTxOKey <$> genSigningKey AsGenesisUTxOKey - ] - -genCardanoKeyWitness :: () + Gen.choice + [ WitnessPaymentKey <$> genSigningKey AsPaymentKey + , WitnessPaymentExtendedKey <$> genSigningKey AsPaymentExtendedKey + , WitnessStakeKey <$> genSigningKey AsStakeKey + , WitnessStakePoolKey <$> genSigningKey AsStakePoolKey + , WitnessGenesisDelegateKey <$> genSigningKey AsGenesisDelegateKey + , WitnessGenesisUTxOKey <$> genSigningKey AsGenesisUTxOKey + ] + +genCardanoKeyWitness + :: () => ShelleyBasedEra era -> Gen (KeyWitness era) genCardanoKeyWitness = genShelleyWitness @@ -886,25 +924,25 @@ genWord32 = Gen.integral (Range.linear 0 10) genRational :: Gen Rational genRational = - (\d -> ratioToRational (1 % d)) <$> genDenominator - where - genDenominator :: Gen Word64 - genDenominator = Gen.integral (Range.linear 1 maxBound) + (\d -> ratioToRational (1 % d)) <$> genDenominator + where + genDenominator :: Gen Word64 + genDenominator = Gen.integral (Range.linear 1 maxBound) - ratioToRational :: Ratio Word64 -> Rational - ratioToRational = toRational + ratioToRational :: Ratio Word64 -> Rational + ratioToRational = toRational -- TODO: consolidate this back to just genRational once this is merged: -- https://github.com/input-output-hk/cardano-ledger-specs/pull/2330 genRationalInt64 :: Gen Rational genRationalInt64 = - (\d -> ratioToRational (1 % d)) <$> genDenominator - where - genDenominator :: Gen Int64 - genDenominator = Gen.integral (Range.linear 1 maxBound) + (\d -> ratioToRational (1 % d)) <$> genDenominator + where + genDenominator :: Gen Int64 + genDenominator = Gen.integral (Range.linear 1 maxBound) - ratioToRational :: Ratio Int64 -> Rational - ratioToRational = toRational + ratioToRational :: Ratio Int64 -> Rational + ratioToRational = toRational genEpochNo :: Gen EpochNo genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10) @@ -938,7 +976,7 @@ genProtocolParameters era = do protocolParamMonetaryExpansion <- genRational protocolParamTreasuryCut <- genRational protocolParamCostModels <- pure mempty - --TODO: Babbage figure out how to deal with + -- TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances protocolParamPrices <- Gen.maybe genExecutionUnitPrices protocolParamMaxTxExUnits <- Gen.maybe genExecutionUnits @@ -946,7 +984,8 @@ genProtocolParameters era = do protocolParamMaxValueSize <- Gen.maybe genNat protocolParamCollateralPercent <- Gen.maybe genNat protocolParamMaxCollateralInputs <- Gen.maybe genNat - protocolParamUTxOCostPerByte <- inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era + protocolParamUTxOCostPerByte <- + inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era pure ProtocolParameters {..} @@ -956,45 +995,46 @@ genValidProtocolParameters sbe = shelleyBasedEraTestConstraints sbe $ LedgerProt genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate genProtocolParametersUpdate era = do - protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat) - protocolUpdateDecentralization <- Gen.maybe genRational - protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce - protocolUpdateMaxBlockHeaderSize <- Gen.maybe genWord16 - protocolUpdateMaxBlockBodySize <- Gen.maybe genWord32 - protocolUpdateMaxTxSize <- Gen.maybe genWord32 - protocolUpdateTxFeeFixed <- Gen.maybe genLovelace - protocolUpdateTxFeePerByte <- Gen.maybe genLovelace - protocolUpdateMinUTxOValue <- Gen.maybe genLovelace + protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat) + protocolUpdateDecentralization <- Gen.maybe genRational + protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce + protocolUpdateMaxBlockHeaderSize <- Gen.maybe genWord16 + protocolUpdateMaxBlockBodySize <- Gen.maybe genWord32 + protocolUpdateMaxTxSize <- Gen.maybe genWord32 + protocolUpdateTxFeeFixed <- Gen.maybe genLovelace + protocolUpdateTxFeePerByte <- Gen.maybe genLovelace + protocolUpdateMinUTxOValue <- Gen.maybe genLovelace protocolUpdateStakeAddressDeposit <- Gen.maybe genLovelace - protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace - protocolUpdateMinPoolCost <- Gen.maybe genLovelace - protocolUpdatePoolRetireMaxEpoch <- Gen.maybe genEpochInterval - protocolUpdateStakePoolTargetNum <- Gen.maybe genNat + protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace + protocolUpdateMinPoolCost <- Gen.maybe genLovelace + protocolUpdatePoolRetireMaxEpoch <- Gen.maybe genEpochInterval + protocolUpdateStakePoolTargetNum <- Gen.maybe genNat protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64 - protocolUpdateMonetaryExpansion <- Gen.maybe genRational - protocolUpdateTreasuryCut <- Gen.maybe genRational + protocolUpdateMonetaryExpansion <- Gen.maybe genRational + protocolUpdateTreasuryCut <- Gen.maybe genRational let protocolUpdateCostModels = mempty -- genCostModels - --TODO: Babbage figure out how to deal with + -- TODO: Babbage figure out how to deal with -- asymmetric cost model JSON instances - protocolUpdatePrices <- Gen.maybe genExecutionUnitPrices - protocolUpdateMaxTxExUnits <- Gen.maybe genExecutionUnits - protocolUpdateMaxBlockExUnits <- Gen.maybe genExecutionUnits - protocolUpdateMaxValueSize <- Gen.maybe genNat - protocolUpdateCollateralPercent <- Gen.maybe genNat + protocolUpdatePrices <- Gen.maybe genExecutionUnitPrices + protocolUpdateMaxTxExUnits <- Gen.maybe genExecutionUnits + protocolUpdateMaxBlockExUnits <- Gen.maybe genExecutionUnits + protocolUpdateMaxValueSize <- Gen.maybe genNat + protocolUpdateCollateralPercent <- Gen.maybe genNat protocolUpdateMaxCollateralInputs <- Gen.maybe genNat - protocolUpdateUTxOCostPerByte <- inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era - - pure ProtocolParametersUpdate{..} + protocolUpdateUTxOCostPerByte <- + inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era + pure ProtocolParametersUpdate {..} genUpdateProposal :: CardanoEra era -> Gen UpdateProposal genUpdateProposal era = UpdateProposal - <$> Gen.map (Range.constant 1 3) - ( (,) + <$> Gen.map + (Range.constant 1 3) + ( (,) <$> genVerificationKeyHash AsGenesisKey <*> genProtocolParametersUpdate era - ) + ) <*> genEpochNo genCostModel :: MonadGen m => m Alonzo.CostModel @@ -1004,60 +1044,62 @@ genCostModels :: MonadGen m => m Alonzo.CostModels genCostModels = Q.arbitrary genExecutionUnits :: Gen ExecutionUnits -genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000) - <*> Gen.integral (Range.constant 0 1000) +genExecutionUnits = + ExecutionUnits + <$> Gen.integral (Range.constant 0 1000) + <*> Gen.integral (Range.constant 0 1000) genExecutionUnitPrices :: Gen ExecutionUnitPrices genExecutionUnitPrices = ExecutionUnitPrices <$> genRational <*> genRational genTxOutDatumHashTxContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxTx era) genTxOutDatumHashTxContext era = case era of - ShelleyBasedEraShelley -> pure TxOutDatumNone - ShelleyBasedEraAllegra -> pure TxOutDatumNone - ShelleyBasedEraMary -> pure TxOutDatumNone - ShelleyBasedEraAlonzo -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsAlonzo <$> genHashableScriptData - ] - ShelleyBasedEraBabbage -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsBabbage <$> genHashableScriptData - , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData - ] - ShelleyBasedEraConway -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsConway <$> genHashableScriptData - , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData - ] + ShelleyBasedEraShelley -> pure TxOutDatumNone + ShelleyBasedEraAllegra -> pure TxOutDatumNone + ShelleyBasedEraMary -> pure TxOutDatumNone + ShelleyBasedEraAlonzo -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsAlonzo <$> genHashableScriptData + ] + ShelleyBasedEraBabbage -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsBabbage <$> genHashableScriptData + , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData + ] + ShelleyBasedEraConway -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsConway <$> genHashableScriptData + , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData + ] genTxOutDatumHashUTxOContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxUTxO era) genTxOutDatumHashUTxOContext era = case era of - ShelleyBasedEraShelley -> pure TxOutDatumNone - ShelleyBasedEraAllegra -> pure TxOutDatumNone - ShelleyBasedEraMary -> pure TxOutDatumNone - ShelleyBasedEraAlonzo -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData - ] - ShelleyBasedEraBabbage -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData - , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData - ] - ShelleyBasedEraConway -> - Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData - , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData - ] + ShelleyBasedEraShelley -> pure TxOutDatumNone + ShelleyBasedEraAllegra -> pure TxOutDatumNone + ShelleyBasedEraMary -> pure TxOutDatumNone + ShelleyBasedEraAlonzo -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData + ] + ShelleyBasedEraBabbage -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData + , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData + ] + ShelleyBasedEraConway -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData + , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData + ] mkDummyHash :: forall h a. CRYPTO.HashAlgorithm h => Int -> CRYPTO.Hash h a mkDummyHash = coerce . CRYPTO.hashWithSerialiser @h CBOR.toCBOR @@ -1078,24 +1120,24 @@ genGovernancePollAnswer = <$> genGovernancePollHash <*> Gen.word (Range.constant 0 10) where - genGovernancePollHash = - GovernancePollHash . mkDummyHash <$> Gen.int (Range.linear 0 10) + genGovernancePollHash = + GovernancePollHash . mkDummyHash <$> Gen.int (Range.linear 0 10) -- TODO: Left off here. Fix this then get back to incorporating proposal procedure -- script witnesses in the api and then propagate to the cli genProposals :: ConwayEraOnwards era -> Gen (TxProposalProcedures BuildTx era) genProposals w = - conwayEraOnwardsConstraints w - $ TxProposalProcedures - <$> genTxProposalsOSet w - <*> return (BuildTxWith mempty) + conwayEraOnwardsConstraints w $ + TxProposalProcedures + <$> genTxProposalsOSet w + <*> return (BuildTxWith mempty) genTxProposalsOSet :: ConwayEraOnwards era -> Gen (OSet (L.ProposalProcedure (ShelleyLedgerEra era))) genTxProposalsOSet w = - conwayEraOnwardsConstraints w - $ OSet.fromFoldable <$> Gen.list (Range.constant 1 10) (genProposal w) + conwayEraOnwardsConstraints w $ + OSet.fromFoldable <$> Gen.list (Range.constant 1 10) (genProposal w) genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = @@ -1104,8 +1146,8 @@ genProposal w = -- TODO: Generate map of script witnesses genVotingProcedures :: ConwayEraOnwards era -> Gen (Api.TxVotingProcedures BuildTx era) genVotingProcedures w = - conwayEraOnwardsConstraints w - $ Api.TxVotingProcedures <$> Q.arbitrary <*> return (BuildTxWith mempty) + conwayEraOnwardsConstraints w $ + Api.TxVotingProcedures <$> Q.arbitrary <*> return (BuildTxWith mempty) genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin genCurrentTreasuryValue _era = Q.arbitrary diff --git a/cardano-api/gen/Test/Gen/Cardano/Crypto/Seed.hs b/cardano-api/gen/Test/Gen/Cardano/Crypto/Seed.hs index 7b42687478..abd5e5511e 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Crypto/Seed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Crypto/Seed.hs @@ -1,15 +1,14 @@ module Test.Gen.Cardano.Crypto.Seed ( genSeed , genSeedForKey - ) where + ) +where -import Cardano.Api (AsType, Key) +import Cardano.Api (AsType, Key) import qualified Cardano.Api as API - -import Cardano.Crypto.Seed (Seed) +import Cardano.Crypto.Seed (Seed) import qualified Cardano.Crypto.Seed as C - -import Hedgehog (MonadGen, Range) +import Hedgehog (MonadGen, Range) import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R diff --git a/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs b/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs index b55a6747dd..0c4170da99 100644 --- a/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs +++ b/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs @@ -1,26 +1,28 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Test.Hedgehog.Golden.ErrorMessage where - -import Cardano.Api (Error (..)) -import Cardano.Api.Pretty -import Data.Data -import GHC.Stack (HasCallStack, withFrozenCallStack) -import System.FilePath (()) +module Test.Hedgehog.Golden.ErrorMessage where -import Hedgehog +import Cardano.Api (Error (..)) +import Cardano.Api.Pretty +import Data.Data +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Hedgehog import qualified Hedgehog.Extras.Test.Base as H import qualified Hedgehog.Extras.Test.Golden as H -import Test.Tasty -import Test.Tasty.Hedgehog - +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.Hedgehog -- | Generate test tree for the list of values. This 'TestTree' will serialize the values using 'Error' -- instance and compare them against golden files in the provided location. -testAllErrorMessages :: forall a. (HasCallStack, Data a, Error a) - => FilePath -- ^ golden files location - -> [a] -- ^ list of values to test against - -> TestTree +testAllErrorMessages + :: forall a + . (HasCallStack, Data a, Error a) + => FilePath + -- ^ golden files location + -> [a] + -- ^ list of values to test against + -> TestTree testAllErrorMessages goldenFilesLocation errs = withFrozenCallStack $ do -- 'err' here is only needed for its 'Data' instance and it's never evaluated -- it's equivalent of having @err = undefined :: a@ @@ -28,7 +30,7 @@ testAllErrorMessages goldenFilesLocation errs = withFrozenCallStack $ do typeName = show $ typeOf err testedConstructors = map toConstr errs allConstructors = dataTypeConstrs $ dataTypeOf err - notTestedConstructors = [ c | c <- allConstructors, c `notElem` testedConstructors] + notTestedConstructors = [c | c <- allConstructors, c `notElem` testedConstructors] testAllConstructors = testProperty "check if all constructors are tested" . withTests 1 . property $ do H.note_ $ "Untested constructors: " <> show notTestedConstructors @@ -41,41 +43,58 @@ testAllErrorMessages goldenFilesLocation errs = withFrozenCallStack $ do -- -- An escape hatch when adding of 'Data a' instance gets impossible (like when we embed 'TypeRep' in our error -- data types) or requires significant multi-package changes and outweighs the benefits here. -testAllErrorMessages_ :: forall a. (HasCallStack, Error a) - => FilePath -- ^ golden files path - -> String -- ^ module name - -> String -- ^ type name - -> [(String, a)] -- ^ list of constructor names and values - -> TestTree +testAllErrorMessages_ + :: forall a + . (HasCallStack, Error a) + => FilePath + -- ^ golden files path + -> String + -- ^ module name + -> String + -- ^ type name + -> [(String, a)] + -- ^ list of constructor names and values + -> TestTree testAllErrorMessages_ goldenFilesLocation moduleName typeName errs = withFrozenCallStack $ do testGroup typeName $ - fmap (uncurry $ testErrorMessage_ goldenFilesLocation moduleName typeName) errs + fmap (uncurry $ testErrorMessage_ goldenFilesLocation moduleName typeName) errs -- | Create 'TestTree' validating serialized value @a@ using 'Error' against the golden files. -testErrorMessage :: (HasCallStack, Data a, Error a) - => FilePath -- ^ golden files path - -> a -- ^ value to test - -> TestTree +testErrorMessage + :: (HasCallStack, Data a, Error a) + => FilePath + -- ^ golden files path + -> a + -- ^ value to test + -> TestTree testErrorMessage goldenFilesLocation err = withFrozenCallStack $ do let errTypeRep = typeOf err typeName = show errTypeRep moduleName = tyConModule $ typeRepTyCon errTypeRep constructorName = show $ toConstr err - testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err + testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err -- | Create 'TestTree' validating serialized value @a@ using 'Error' against the golden files. -- -- Requires providing a module name, a type name and a constructor name of @a@. Useful when 'Data a' -- instance is not available. -testErrorMessage_ :: (HasCallStack, Error a) - => FilePath -- ^ golden files path - -> String -- ^ module name - -> String -- ^ type name - -> String -- ^ constructor name - -> a -- ^ value to test - -> TestTree +testErrorMessage_ + :: (HasCallStack, Error a) + => FilePath + -- ^ golden files path + -> String + -- ^ module name + -> String + -- ^ type name + -> String + -- ^ constructor name + -> a + -- ^ value to test + -> TestTree testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err = withFrozenCallStack $ do let fqtn = moduleName <> "." <> typeName testProperty constructorName . withTests 1 . property $ do H.note_ "Incorrect error message in golden file" - H.diffVsGoldenFile (docToString (prettyError err)) (goldenFilesLocation fqtn constructorName <> ".txt") + H.diffVsGoldenFile + (docToString (prettyError err)) + (goldenFilesLocation fqtn constructorName <> ".txt") diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/Bech32.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/Bech32.hs index 459244ad74..e6f84ed37f 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/Bech32.hs +++ b/cardano-api/gen/Test/Hedgehog/Roundtrip/Bech32.hs @@ -1,10 +1,10 @@ module Test.Hedgehog.Roundtrip.Bech32 ( roundtrip_Bech32 - ) where + ) +where -import Cardano.Api - -import Hedgehog (Gen, Property) +import Cardano.Api +import Hedgehog (Gen, Property) import qualified Hedgehog as H roundtrip_Bech32 diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs index 93e08b4656..07a4898569 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs +++ b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs @@ -4,19 +4,19 @@ module Test.Hedgehog.Roundtrip.CBOR ( trippingCbor - ) where + ) +where -import Cardano.Api - -import GHC.Stack (HasCallStack) +import Cardano.Api +import GHC.Stack (HasCallStack) import qualified GHC.Stack as GHC - import qualified Hedgehog as H {- HLINT ignore "Use camelCase" -} -- | Assert that CBOR serialisation and deserialisation roundtrips. -trippingCbor :: () +trippingCbor + :: () => HasCallStack => H.MonadTest m => Show a @@ -25,5 +25,6 @@ trippingCbor :: () => AsType a -> a -> m () -trippingCbor typeProxy v = GHC.withFrozenCallStack $ - H.tripping v serialiseToCBOR (deserialiseFromCBOR typeProxy) +trippingCbor typeProxy v = + GHC.withFrozenCallStack $ + H.tripping v serialiseToCBOR (deserialiseFromCBOR typeProxy) diff --git a/cardano-api/internal/Cardano/Api/Address.hs b/cardano-api/internal/Cardano/Api/Address.hs index 6d0ac9493a..22b7345ae1 100644 --- a/cardano-api/internal/Cardano/Api/Address.hs +++ b/cardano-api/internal/Cardano/Api/Address.hs @@ -12,110 +12,116 @@ {- HLINT ignore "Avoid lambda using `infix`" -} -- | Cardano addresses: payment and stake addresses. --- -module Cardano.Api.Address ( - -- * Payment addresses +module Cardano.Api.Address + ( -- * Payment addresses + -- | Constructing and inspecting normal payment addresses - Address(..), + Address (..) -- ** Byron addresses - ByronAddr, - makeByronAddress, + , ByronAddr + , makeByronAddress -- ** Shelley addresses - ShelleyAddr, - makeShelleyAddress, - PaymentCredential(..), - StakeAddressReference(..), - StakeAddressPointer(..), + , ShelleyAddr + , makeShelleyAddress + , PaymentCredential (..) + , StakeAddressReference (..) + , StakeAddressPointer (..) -- ** Addresses in any era - AddressAny(..), - lexPlausibleAddressString, - parseAddressAny, + , AddressAny (..) + , lexPlausibleAddressString + , parseAddressAny -- ** Addresses in specific eras - AddressInEra(..), - AddressTypeInEra(..), - byronAddressInEra, - shelleyAddressInEra, - anyAddressInShelleyBasedEra, - anyAddressInEra, - toAddressAny, - makeByronAddressInEra, - makeShelleyAddressInEra, + , AddressInEra (..) + , AddressTypeInEra (..) + , byronAddressInEra + , shelleyAddressInEra + , anyAddressInShelleyBasedEra + , anyAddressInEra + , toAddressAny + , makeByronAddressInEra + , makeShelleyAddressInEra -- * Stake addresses + -- | Constructing and inspecting stake addresses - StakeAddress(..), - StakeCredential(..), - makeStakeAddress, - stakeAddressCredential, - StakeKey, - StakeExtendedKey, + , StakeAddress (..) + , StakeCredential (..) + , makeStakeAddress + , stakeAddressCredential + , StakeKey + , StakeExtendedKey -- * Conversion functions - shelleyPayAddrToPlutusPubKHash, + , shelleyPayAddrToPlutusPubKHash -- * Internal conversion functions - toShelleyAddr, - toShelleyStakeAddr, - toShelleyStakeCredential, - fromShelleyAddr, - fromShelleyAddrIsSbe, - fromShelleyAddrToAny, - fromShelleyPaymentCredential, - fromShelleyStakeAddr, - fromShelleyStakeCredential, - fromShelleyStakeReference, + , toShelleyAddr + , toShelleyStakeAddr + , toShelleyStakeCredential + , fromShelleyAddr + , fromShelleyAddrIsSbe + , fromShelleyAddrToAny + , fromShelleyPaymentCredential + , fromShelleyStakeAddr + , fromShelleyStakeCredential + , fromShelleyStakeReference -- * Serialising addresses - SerialiseAddress(..), + , SerialiseAddress (..) -- * Data family instances - AsType(AsByronAddr, AsShelleyAddr, AsByronAddress, AsShelleyAddress, - AsAddress, AsAddressAny, AsAddressInEra, AsStakeAddress), + , AsType + ( AsByronAddr + , AsShelleyAddr + , AsByronAddress + , AsShelleyAddress + , AsAddress + , AsAddressAny + , AsAddressInEra + , AsStakeAddress + ) -- * Helpers - isKeyAddress - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Shelley -import Cardano.Api.NetworkId -import Cardano.Api.Script -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseRaw -import Cardano.Api.Utils - + , isKeyAddress + ) +where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Shelley +import Cardano.Api.NetworkId +import Cardano.Api.Script +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseRaw +import Cardano.Api.Utils import qualified Cardano.Chain.Common as Byron import qualified Cardano.Ledger.Address as Shelley import qualified Cardano.Ledger.BaseTypes as Shelley import qualified Cardano.Ledger.Credential as Shelley -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Plutus.TxInfo as Plutus -import qualified PlutusLedgerApi.V1 as PlutusAPI - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData (..), deepseq) -import Data.Aeson (FromJSON (..), ToJSON (..), withText, (.=)) +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (..), deepseq) +import Data.Aeson (FromJSON (..), ToJSON (..), withText, (.=)) import qualified Data.Aeson as Aeson -import Data.Bifunctor (first) +import Data.Bifunctor (first) import qualified Data.ByteString.Base58 as Base58 -import Data.Char (isAsciiLower, isAsciiUpper, isDigit) -import Data.Either.Combinators (rightToMaybe) -import Data.Text (Text) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Either.Combinators (rightToMaybe) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified PlutusLedgerApi.V1 as PlutusAPI import qualified Text.Parsec as Parsec import qualified Text.Parsec.String as Parsec - - -- ---------------------------------------------------------------------------- -- Address Serialisation -- @@ -125,14 +131,12 @@ import qualified Text.Parsec.String as Parsec -- -- In particular, Byron addresses are typically formatted in base 58, while -- Shelley addresses (payment and stake) are formatted using Bech32. --- class HasTypeProxy addr => SerialiseAddress addr where + serialiseAddress :: addr -> Text - serialiseAddress :: addr -> Text - - deserialiseAddress :: AsType addr -> Text -> Maybe addr - -- TODO: consider adding data AddressDecodeError + deserialiseAddress :: AsType addr -> Text -> Maybe addr +-- TODO: consider adding data AddressDecodeError -- ---------------------------------------------------------------------------- -- Payment address types @@ -145,13 +149,12 @@ data ByronAddr data ShelleyAddr instance HasTypeProxy ByronAddr where - data AsType ByronAddr = AsByronAddr - proxyToAsType _ = AsByronAddr + data AsType ByronAddr = AsByronAddr + proxyToAsType _ = AsByronAddr instance HasTypeProxy ShelleyAddr where - data AsType ShelleyAddr = AsShelleyAddr - proxyToAsType _ = AsShelleyAddr - + data AsType ShelleyAddr = AsShelleyAddr + proxyToAsType _ = AsShelleyAddr -- ---------------------------------------------------------------------------- -- Payment addresses @@ -173,30 +176,28 @@ instance HasTypeProxy ShelleyAddr where -- Shelley addresses. The 'Address' type param only says the type of the address -- (either Byron or Shelley). The 'AddressInEra' type connects the address type -- with the era in which it is supported. --- data Address addrtype where + -- | Byron addresses were the only supported address type in the original + -- Byron era. + ByronAddress + :: Byron.Address + -> Address ByronAddr + -- | Shelley addresses allow delegation. Shelley addresses were introduced + -- in Shelley era and are thus supported from the Shelley era onwards + ShelleyAddress + :: Shelley.Network + -> Shelley.PaymentCredential StandardCrypto + -> Shelley.StakeReference StandardCrypto + -> Address ShelleyAddr + +-- Note that the two ledger credential types here are parametrised by +-- the era, but in fact this is a phantom type parameter and they are +-- the same for all eras. See 'toShelleyAddr' below. + +deriving instance Eq (Address addrtype) + +deriving instance Ord (Address addrtype) - -- | Byron addresses were the only supported address type in the original - -- Byron era. - -- - ByronAddress - :: Byron.Address - -> Address ByronAddr - - -- | Shelley addresses allow delegation. Shelley addresses were introduced - -- in Shelley era and are thus supported from the Shelley era onwards - -- - ShelleyAddress - :: Shelley.Network - -> Shelley.PaymentCredential StandardCrypto - -> Shelley.StakeReference StandardCrypto - -> Address ShelleyAddr - -- Note that the two ledger credential types here are parametrised by - -- the era, but in fact this is a phantom type parameter and they are - -- the same for all eras. See 'toShelleyAddr' below. - -deriving instance Eq (Address addrtype) -deriving instance Ord (Address addrtype) deriving instance Show (Address addrtype) instance NFData (Address addrtype) where @@ -205,107 +206,109 @@ instance NFData (Address addrtype) where ShelleyAddress n pc sr -> deepseq (deepseq (deepseq n pc) sr) () instance HasTypeProxy addrtype => HasTypeProxy (Address addrtype) where - data AsType (Address addrtype) = AsAddress (AsType addrtype) - proxyToAsType _ = AsAddress (proxyToAsType (Proxy :: Proxy addrtype)) + data AsType (Address addrtype) = AsAddress (AsType addrtype) + proxyToAsType _ = AsAddress (proxyToAsType (Proxy :: Proxy addrtype)) pattern AsByronAddress :: AsType (Address ByronAddr) -pattern AsByronAddress = AsAddress AsByronAddr +pattern AsByronAddress = AsAddress AsByronAddr + {-# COMPLETE AsByronAddress #-} pattern AsShelleyAddress :: AsType (Address ShelleyAddr) pattern AsShelleyAddress = AsAddress AsShelleyAddr + {-# COMPLETE AsShelleyAddress #-} instance SerialiseAsRawBytes (Address ByronAddr) where - serialiseToRawBytes (ByronAddress addr) = - Shelley.serialiseAddr + serialiseToRawBytes (ByronAddress addr) = + Shelley.serialiseAddr . Shelley.AddrBootstrap . Shelley.BootstrapAddress $ addr - deserialiseFromRawBytes (AsAddress AsByronAddr) bs = - case Shelley.decodeAddr bs :: Maybe (Shelley.Addr StandardCrypto) of - Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") - Just Shelley.Addr{} -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") - Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> - Right (ByronAddress addr) + deserialiseFromRawBytes (AsAddress AsByronAddr) bs = + case Shelley.decodeAddr bs :: Maybe (Shelley.Addr StandardCrypto) of + Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") + Just Shelley.Addr {} -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") + Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> + Right (ByronAddress addr) instance SerialiseAsRawBytes (Address ShelleyAddr) where - serialiseToRawBytes (ShelleyAddress nw pc scr) = - Shelley.serialiseAddr (Shelley.Addr nw pc scr) + serialiseToRawBytes (ShelleyAddress nw pc scr) = + Shelley.serialiseAddr (Shelley.Addr nw pc scr) - deserialiseFromRawBytes (AsAddress AsShelleyAddr) bs = - case Shelley.decodeAddr bs of - Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") - Just Shelley.AddrBootstrap{} -> Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") - Just (Shelley.Addr nw pc scr) -> Right (ShelleyAddress nw pc scr) + deserialiseFromRawBytes (AsAddress AsShelleyAddr) bs = + case Shelley.decodeAddr bs of + Nothing -> + Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") + Just Shelley.AddrBootstrap {} -> Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") + Just (Shelley.Addr nw pc scr) -> Right (ShelleyAddress nw pc scr) instance SerialiseAsBech32 (Address ShelleyAddr) where - bech32PrefixFor (ShelleyAddress Shelley.Mainnet _ _) = "addr" - bech32PrefixFor (ShelleyAddress Shelley.Testnet _ _) = "addr_test" - - bech32PrefixesPermitted (AsAddress AsShelleyAddr) = ["addr", "addr_test"] + bech32PrefixFor (ShelleyAddress Shelley.Mainnet _ _) = "addr" + bech32PrefixFor (ShelleyAddress Shelley.Testnet _ _) = "addr_test" + bech32PrefixesPermitted (AsAddress AsShelleyAddr) = ["addr", "addr_test"] instance SerialiseAddress (Address ByronAddr) where - serialiseAddress addr@ByronAddress{} = - Text.decodeLatin1 - . Base58.encodeBase58 Base58.bitcoinAlphabet - . serialiseToRawBytes - $ addr + serialiseAddress addr@ByronAddress {} = + Text.decodeLatin1 + . Base58.encodeBase58 Base58.bitcoinAlphabet + . serialiseToRawBytes + $ addr - deserialiseAddress (AsAddress AsByronAddr) txt = do - bs <- Base58.decodeBase58 Base58.bitcoinAlphabet (Text.encodeUtf8 txt) - rightToMaybe (deserialiseFromRawBytes (AsAddress AsByronAddr) bs) + deserialiseAddress (AsAddress AsByronAddr) txt = do + bs <- Base58.decodeBase58 Base58.bitcoinAlphabet (Text.encodeUtf8 txt) + rightToMaybe (deserialiseFromRawBytes (AsAddress AsByronAddr) bs) instance SerialiseAddress (Address ShelleyAddr) where - serialiseAddress addr@ShelleyAddress{} = - serialiseToBech32 addr + serialiseAddress addr@ShelleyAddress {} = + serialiseToBech32 addr - deserialiseAddress (AsAddress AsShelleyAddr) t = - either (const Nothing) Just $ + deserialiseAddress (AsAddress AsShelleyAddr) t = + either (const Nothing) Just $ deserialiseFromBech32 (AsAddress AsShelleyAddr) t instance ToJSON (Address ShelleyAddr) where - toJSON = Aeson.String . serialiseAddress + toJSON = Aeson.String . serialiseAddress instance ToJSON (Address ByronAddr) where - toJSON = Aeson.String . serialiseAddress + toJSON = Aeson.String . serialiseAddress instance FromJSON (Address ByronAddr) where - parseJSON = Aeson.withText "Address" $ \txt -> - maybe - (fail "Cardano.Api.Address.FromJSON: Invalid Byron address.") - pure - (deserialiseAddress AsByronAddress txt) + parseJSON = Aeson.withText "Address" $ \txt -> + maybe + (fail "Cardano.Api.Address.FromJSON: Invalid Byron address.") + pure + (deserialiseAddress AsByronAddress txt) instance FromJSON (Address ShelleyAddr) where - parseJSON = Aeson.withText "Address" $ \txt -> - maybe - (fail "Cardano.Api.Address.FromJSON: Invalid Shelley address.") - pure - (deserialiseAddress AsShelleyAddress txt) - -makeByronAddress :: NetworkId - -> VerificationKey ByronKey - -> Address ByronAddr + parseJSON = Aeson.withText "Address" $ \txt -> + maybe + (fail "Cardano.Api.Address.FromJSON: Invalid Shelley address.") + pure + (deserialiseAddress AsShelleyAddress txt) + +makeByronAddress + :: NetworkId + -> VerificationKey ByronKey + -> Address ByronAddr makeByronAddress nw (ByronVerificationKey vk) = - ByronAddress $ - Byron.makeVerKeyAddress - (toByronNetworkMagic nw) - vk - + ByronAddress $ + Byron.makeVerKeyAddress + (toByronNetworkMagic nw) + vk -makeShelleyAddress :: NetworkId - -> PaymentCredential - -> StakeAddressReference - -> Address ShelleyAddr +makeShelleyAddress + :: NetworkId + -> PaymentCredential + -> StakeAddressReference + -> Address ShelleyAddr makeShelleyAddress nw pc scr = - ShelleyAddress - (toShelleyNetwork nw) - (toShelleyPaymentCredential pc) - (toShelleyStakeReference scr) - + ShelleyAddress + (toShelleyNetwork nw) + (toShelleyPaymentCredential pc) + (toShelleyStakeReference scr) -- ---------------------------------------------------------------------------- -- Either type of address @@ -316,37 +319,35 @@ makeShelleyAddress nw pc scr = -- Sometimes we need to be able to work with either of the two types of -- address (Byron or Shelley addresses), but without reference to an era in -- which the address will be used. This type serves that purpose. --- -data AddressAny = AddressByron !(Address ByronAddr) - | AddressShelley !(Address ShelleyAddr) +data AddressAny + = AddressByron !(Address ByronAddr) + | AddressShelley !(Address ShelleyAddr) deriving (Eq, Ord, Show) instance HasTypeProxy AddressAny where - data AsType AddressAny = AsAddressAny - proxyToAsType _ = AsAddressAny + data AsType AddressAny = AsAddressAny + proxyToAsType _ = AsAddressAny instance SerialiseAsRawBytes AddressAny where - serialiseToRawBytes (AddressByron addr) = serialiseToRawBytes addr - serialiseToRawBytes (AddressShelley addr) = serialiseToRawBytes addr - - deserialiseFromRawBytes AsAddressAny bs = - case Shelley.decodeAddr bs of - Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise AddressAny") - Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> - Right (AddressByron (ByronAddress addr)) + serialiseToRawBytes (AddressByron addr) = serialiseToRawBytes addr + serialiseToRawBytes (AddressShelley addr) = serialiseToRawBytes addr - Just (Shelley.Addr nw pc scr) -> - Right (AddressShelley (ShelleyAddress nw pc scr)) + deserialiseFromRawBytes AsAddressAny bs = + case Shelley.decodeAddr bs of + Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise AddressAny") + Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> + Right (AddressByron (ByronAddress addr)) + Just (Shelley.Addr nw pc scr) -> + Right (AddressShelley (ShelleyAddress nw pc scr)) instance SerialiseAddress AddressAny where - serialiseAddress (AddressByron addr) = serialiseAddress addr - serialiseAddress (AddressShelley addr) = serialiseAddress addr + serialiseAddress (AddressByron addr) = serialiseAddress addr + serialiseAddress (AddressShelley addr) = serialiseAddress addr - deserialiseAddress AsAddressAny t = - (AddressByron <$> deserialiseAddress (AsAddress AsByronAddr) t) + deserialiseAddress AsAddressAny t = + (AddressByron <$> deserialiseAddress (AsAddress AsByronAddr) t) <|> (AddressShelley <$> deserialiseAddress (AsAddress AsShelleyAddr) t) - fromShelleyAddrToAny :: Shelley.Addr StandardCrypto -> AddressAny fromShelleyAddrToAny (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) = AddressByron $ ByronAddress addr @@ -361,11 +362,11 @@ fromShelleyAddrToAny (Shelley.Addr nw pc scr) = -- -- All current ledger eras support Byron addresses. Shelley addresses are -- supported in the 'ShelleyEra' and later eras. --- data AddressInEra era where - AddressInEra :: AddressTypeInEra addrtype era - -> Address addrtype - -> AddressInEra era + AddressInEra + :: AddressTypeInEra addrtype era + -> Address addrtype + -> AddressInEra era instance NFData (AddressInEra era) where rnf (AddressInEra t a) = deepseq (deepseq t a) () @@ -375,63 +376,64 @@ instance IsCardanoEra era => ToJSON (AddressInEra era) where instance IsShelleyBasedEra era => FromJSON (AddressInEra era) where parseJSON = - let sbe = shelleyBasedEra @era in - withText "AddressInEra" $ \txt -> do - addressAny <- runParsecParser parseAddressAny txt - pure $ anyAddressInShelleyBasedEra sbe addressAny + let sbe = shelleyBasedEra @era + in withText "AddressInEra" $ \txt -> do + addressAny <- runParsecParser parseAddressAny txt + pure $ anyAddressInShelleyBasedEra sbe addressAny parseAddressAny :: Parsec.Parser AddressAny parseAddressAny = do - str <- lexPlausibleAddressString - case deserialiseAddress AsAddressAny str of - Nothing -> fail $ "invalid address: " <> Text.unpack str - Just addr -> pure addr + str <- lexPlausibleAddressString + case deserialiseAddress AsAddressAny str of + Nothing -> fail $ "invalid address: " <> Text.unpack str + Just addr -> pure addr lexPlausibleAddressString :: Parsec.Parser Text lexPlausibleAddressString = - Text.pack <$> Parsec.many1 (Parsec.satisfy isPlausibleAddressChar) - where - -- Covers both base58 and bech32 (with constrained prefixes) - isPlausibleAddressChar c = - isAsciiLower c + Text.pack <$> Parsec.many1 (Parsec.satisfy isPlausibleAddressChar) + where + -- Covers both base58 and bech32 (with constrained prefixes) + isPlausibleAddressChar c = + isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' instance Eq (AddressInEra era) where - (==) (AddressInEra ByronAddressInAnyEra addr1) - (AddressInEra ByronAddressInAnyEra addr2) = addr1 == addr2 - - (==) (AddressInEra ShelleyAddressInEra{} addr1) - (AddressInEra ShelleyAddressInEra{} addr2) = addr1 == addr2 - - (==) (AddressInEra ByronAddressInAnyEra _) - (AddressInEra ShelleyAddressInEra{} _) = False - - (==) (AddressInEra ShelleyAddressInEra{} _) - (AddressInEra ByronAddressInAnyEra _) = False + (==) + (AddressInEra ByronAddressInAnyEra addr1) + (AddressInEra ByronAddressInAnyEra addr2) = addr1 == addr2 + (==) + (AddressInEra ShelleyAddressInEra {} addr1) + (AddressInEra ShelleyAddressInEra {} addr2) = addr1 == addr2 + (==) + (AddressInEra ByronAddressInAnyEra _) + (AddressInEra ShelleyAddressInEra {} _) = False + (==) + (AddressInEra ShelleyAddressInEra {} _) + (AddressInEra ByronAddressInAnyEra _) = False instance Ord (AddressInEra era) where - compare (AddressInEra ByronAddressInAnyEra addr1) - (AddressInEra ByronAddressInAnyEra addr2) = compare addr1 addr2 - - compare (AddressInEra ShelleyAddressInEra{} addr1) - (AddressInEra ShelleyAddressInEra{} addr2) = compare addr1 addr2 - - compare (AddressInEra ByronAddressInAnyEra _) - (AddressInEra ShelleyAddressInEra{} _) = LT - - compare (AddressInEra ShelleyAddressInEra{} _) - (AddressInEra ByronAddressInAnyEra _) = GT + compare + (AddressInEra ByronAddressInAnyEra addr1) + (AddressInEra ByronAddressInAnyEra addr2) = compare addr1 addr2 + compare + (AddressInEra ShelleyAddressInEra {} addr1) + (AddressInEra ShelleyAddressInEra {} addr2) = compare addr1 addr2 + compare + (AddressInEra ByronAddressInAnyEra _) + (AddressInEra ShelleyAddressInEra {} _) = LT + compare + (AddressInEra ShelleyAddressInEra {} _) + (AddressInEra ByronAddressInAnyEra _) = GT deriving instance Show (AddressInEra era) data AddressTypeInEra addrtype era where - - ByronAddressInAnyEra :: AddressTypeInEra ByronAddr era - - ShelleyAddressInEra :: ShelleyBasedEra era - -> AddressTypeInEra ShelleyAddr era + ByronAddressInAnyEra :: AddressTypeInEra ByronAddr era + ShelleyAddressInEra + :: ShelleyBasedEra era + -> AddressTypeInEra ShelleyAddr era deriving instance Show (AddressTypeInEra addrtype era) @@ -441,74 +443,75 @@ instance NFData (AddressTypeInEra addrtype era) where ShelleyAddressInEra sbe -> deepseq sbe () instance HasTypeProxy era => HasTypeProxy (AddressInEra era) where - data AsType (AddressInEra era) = AsAddressInEra (AsType era) - proxyToAsType _ = AsAddressInEra (proxyToAsType (Proxy :: Proxy era)) + data AsType (AddressInEra era) = AsAddressInEra (AsType era) + proxyToAsType _ = AsAddressInEra (proxyToAsType (Proxy :: Proxy era)) instance IsCardanoEra era => SerialiseAsRawBytes (AddressInEra era) where + serialiseToRawBytes (AddressInEra ByronAddressInAnyEra addr) = + serialiseToRawBytes addr + serialiseToRawBytes (AddressInEra ShelleyAddressInEra {} addr) = + serialiseToRawBytes addr - serialiseToRawBytes (AddressInEra ByronAddressInAnyEra addr) = - serialiseToRawBytes addr - - serialiseToRawBytes (AddressInEra ShelleyAddressInEra{} addr) = - serialiseToRawBytes addr - - deserialiseFromRawBytes _ bs = - first (const (SerialiseAsRawBytesError "Unable to deserialise AddressInEra era")) $ - anyAddressInEra cardanoEra =<< first unSerialiseAsRawBytesError (deserialiseFromRawBytes AsAddressAny bs) + deserialiseFromRawBytes _ bs = + first (const (SerialiseAsRawBytesError "Unable to deserialise AddressInEra era")) $ + anyAddressInEra cardanoEra + =<< first unSerialiseAsRawBytesError (deserialiseFromRawBytes AsAddressAny bs) instance IsCardanoEra era => SerialiseAddress (AddressInEra era) where - serialiseAddress (AddressInEra ByronAddressInAnyEra addr) = - serialiseAddress addr + serialiseAddress (AddressInEra ByronAddressInAnyEra addr) = + serialiseAddress addr + serialiseAddress (AddressInEra ShelleyAddressInEra {} addr) = + serialiseAddress addr - serialiseAddress (AddressInEra ShelleyAddressInEra{} addr) = - serialiseAddress addr - - deserialiseAddress _ t = - rightToMaybe . anyAddressInEra cardanoEra =<< deserialiseAddress AsAddressAny t + deserialiseAddress _ t = + rightToMaybe . anyAddressInEra cardanoEra =<< deserialiseAddress AsAddressAny t byronAddressInEra :: Address ByronAddr -> AddressInEra era byronAddressInEra = AddressInEra ByronAddressInAnyEra - -shelleyAddressInEra :: () +shelleyAddressInEra + :: () => ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era shelleyAddressInEra sbe = AddressInEra (ShelleyAddressInEra sbe) -anyAddressInShelleyBasedEra :: () +anyAddressInShelleyBasedEra + :: () => ShelleyBasedEra era -> AddressAny -> AddressInEra era anyAddressInShelleyBasedEra sbe = \case - AddressByron addr -> byronAddressInEra addr + AddressByron addr -> byronAddressInEra addr AddressShelley addr -> shelleyAddressInEra sbe addr - -anyAddressInEra :: CardanoEra era - -> AddressAny - -> Either String (AddressInEra era) +anyAddressInEra + :: CardanoEra era + -> AddressAny + -> Either String (AddressInEra era) anyAddressInEra era = \case AddressByron addr -> Right (AddressInEra ByronAddressInAnyEra addr) AddressShelley addr -> - forEraInEon era + forEraInEon + era (Left "Expected Byron based era address") (\sbe -> Right (AddressInEra (ShelleyAddressInEra sbe) addr)) toAddressAny :: Address addr -> AddressAny -toAddressAny a@ShelleyAddress{} = AddressShelley a -toAddressAny a@ByronAddress{} = AddressByron a +toAddressAny a@ShelleyAddress {} = AddressShelley a +toAddressAny a@ByronAddress {} = AddressByron a -makeByronAddressInEra :: NetworkId - -> VerificationKey ByronKey - -> AddressInEra era +makeByronAddressInEra + :: NetworkId + -> VerificationKey ByronKey + -> AddressInEra era makeByronAddressInEra nw vk = - byronAddressInEra (makeByronAddress nw vk) + byronAddressInEra (makeByronAddress nw vk) - -makeShelleyAddressInEra :: () +makeShelleyAddressInEra + :: () => ShelleyBasedEra era -> NetworkId -> PaymentCredential @@ -517,26 +520,25 @@ makeShelleyAddressInEra :: () makeShelleyAddressInEra sbe nw pc scr = shelleyAddressInEra sbe (makeShelleyAddress nw pc scr) - -- ---------------------------------------------------------------------------- -- Stake addresses -- data StakeAddress where - StakeAddress - :: Shelley.Network - -> Shelley.StakeCredential StandardCrypto - -> StakeAddress + StakeAddress + :: Shelley.Network + -> Shelley.StakeCredential StandardCrypto + -> StakeAddress deriving (Eq, Ord, Show) data PaymentCredential - = PaymentCredentialByKey (Hash PaymentKey) - | PaymentCredentialByScript ScriptHash + = PaymentCredentialByKey (Hash PaymentKey) + | PaymentCredentialByScript ScriptHash deriving (Eq, Ord, Show) data StakeCredential - = StakeCredentialByKey (Hash StakeKey) - | StakeCredentialByScript ScriptHash + = StakeCredentialByKey (Hash StakeKey) + | StakeCredentialByScript ScriptHash deriving (Eq, Ord, Show) instance ToJSON StakeCredential where @@ -549,9 +551,9 @@ instance ToJSON StakeCredential where ["stakingScriptHash" .= serialiseToRawBytesHexText scriptHash] data StakeAddressReference - = StakeAddressByValue StakeCredential - | StakeAddressByPointer StakeAddressPointer - | NoStakeAddress + = StakeAddressByValue StakeCredential + | StakeAddressByPointer StakeAddressPointer + | NoStakeAddress deriving (Eq, Show) newtype StakeAddressPointer = StakeAddressPointer @@ -560,33 +562,30 @@ newtype StakeAddressPointer = StakeAddressPointer deriving (Eq, Show) instance HasTypeProxy StakeAddress where - data AsType StakeAddress = AsStakeAddress - proxyToAsType _ = AsStakeAddress - + data AsType StakeAddress = AsStakeAddress + proxyToAsType _ = AsStakeAddress instance SerialiseAsRawBytes StakeAddress where - serialiseToRawBytes (StakeAddress nw sc) = - Shelley.serialiseRewardAccount (Shelley.RewardAccount nw sc) - - deserialiseFromRawBytes AsStakeAddress bs = - case Shelley.deserialiseRewardAccount bs of - Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise StakeAddress") - Just (Shelley.RewardAccount nw sc) -> Right (StakeAddress nw sc) + serialiseToRawBytes (StakeAddress nw sc) = + Shelley.serialiseRewardAccount (Shelley.RewardAccount nw sc) + deserialiseFromRawBytes AsStakeAddress bs = + case Shelley.deserialiseRewardAccount bs of + Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise StakeAddress") + Just (Shelley.RewardAccount nw sc) -> Right (StakeAddress nw sc) instance SerialiseAsBech32 StakeAddress where - bech32PrefixFor (StakeAddress Shelley.Mainnet _) = "stake" - bech32PrefixFor (StakeAddress Shelley.Testnet _) = "stake_test" - - bech32PrefixesPermitted AsStakeAddress = ["stake", "stake_test"] + bech32PrefixFor (StakeAddress Shelley.Mainnet _) = "stake" + bech32PrefixFor (StakeAddress Shelley.Testnet _) = "stake_test" + bech32PrefixesPermitted AsStakeAddress = ["stake", "stake_test"] instance SerialiseAddress StakeAddress where - serialiseAddress addr@StakeAddress{} = - serialiseToBech32 addr + serialiseAddress addr@StakeAddress {} = + serialiseToBech32 addr - deserialiseAddress AsStakeAddress t = - either (const Nothing) Just $ + deserialiseAddress AsStakeAddress t = + either (const Nothing) Just $ deserialiseFromBech32 AsStakeAddress t instance ToJSON StakeAddress where @@ -599,13 +598,14 @@ instance FromJSON StakeAddress where fail $ "Error while deserialising StakeAddress: " <> Text.unpack str Just sAddr -> pure sAddr -makeStakeAddress :: NetworkId - -> StakeCredential - -> StakeAddress +makeStakeAddress + :: NetworkId + -> StakeCredential + -> StakeAddress makeStakeAddress nw sc = - StakeAddress - (toShelleyNetwork nw) - (toShelleyStakeCredential sc) + StakeAddress + (toShelleyNetwork nw) + (toShelleyStakeCredential sc) -- ---------------------------------------------------------------------------- -- Helpers @@ -632,42 +632,49 @@ shelleyPayAddrToPlutusPubKHash (ShelleyAddress _ payCred _) = toShelleyAddr :: AddressInEra era -> Shelley.Addr StandardCrypto toShelleyAddr (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) = - Shelley.AddrBootstrap (Shelley.BootstrapAddress addr) -toShelleyAddr (AddressInEra (ShelleyAddressInEra _) - (ShelleyAddress nw pc scr)) = + Shelley.AddrBootstrap (Shelley.BootstrapAddress addr) +toShelleyAddr + ( AddressInEra + (ShelleyAddressInEra _) + (ShelleyAddress nw pc scr) + ) = Shelley.Addr nw pc scr toShelleyStakeAddr :: StakeAddress -> Shelley.RewardAccount StandardCrypto toShelleyStakeAddr (StakeAddress nw sc) = - Shelley.RewardAccount { - Shelley.raNetwork = nw, - Shelley.raCredential = sc + Shelley.RewardAccount + { Shelley.raNetwork = nw + , Shelley.raCredential = sc } -toShelleyPaymentCredential :: PaymentCredential - -> Shelley.PaymentCredential StandardCrypto +toShelleyPaymentCredential + :: PaymentCredential + -> Shelley.PaymentCredential StandardCrypto toShelleyPaymentCredential (PaymentCredentialByKey (PaymentKeyHash kh)) = - Shelley.KeyHashObj kh + Shelley.KeyHashObj kh toShelleyPaymentCredential (PaymentCredentialByScript sh) = - Shelley.ScriptHashObj (toShelleyScriptHash sh) + Shelley.ScriptHashObj (toShelleyScriptHash sh) -toShelleyStakeCredential :: StakeCredential - -> Shelley.StakeCredential StandardCrypto +toShelleyStakeCredential + :: StakeCredential + -> Shelley.StakeCredential StandardCrypto toShelleyStakeCredential (StakeCredentialByKey (StakeKeyHash kh)) = - Shelley.KeyHashObj kh + Shelley.KeyHashObj kh toShelleyStakeCredential (StakeCredentialByScript sh) = - Shelley.ScriptHashObj (toShelleyScriptHash sh) + Shelley.ScriptHashObj (toShelleyScriptHash sh) -toShelleyStakeReference :: StakeAddressReference - -> Shelley.StakeReference StandardCrypto +toShelleyStakeReference + :: StakeAddressReference + -> Shelley.StakeReference StandardCrypto toShelleyStakeReference (StakeAddressByValue stakecred) = - Shelley.StakeRefBase (toShelleyStakeCredential stakecred) + Shelley.StakeRefBase (toShelleyStakeCredential stakecred) toShelleyStakeReference (StakeAddressByPointer ptr) = - Shelley.StakeRefPtr (unStakeAddressPointer ptr) -toShelleyStakeReference NoStakeAddress = - Shelley.StakeRefNull + Shelley.StakeRefPtr (unStakeAddressPointer ptr) +toShelleyStakeReference NoStakeAddress = + Shelley.StakeRefNull -fromShelleyAddrIsSbe :: () +fromShelleyAddrIsSbe + :: () => ShelleyBasedEra era -> Shelley.Addr StandardCrypto -> AddressInEra era @@ -682,32 +689,34 @@ fromShelleyAddr -> Shelley.Addr StandardCrypto -> AddressInEra era fromShelleyAddr _ (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) = - AddressInEra ByronAddressInAnyEra (ByronAddress addr) - + AddressInEra ByronAddressInAnyEra (ByronAddress addr) fromShelleyAddr sBasedEra (Shelley.Addr nw pc scr) = - AddressInEra - (ShelleyAddressInEra sBasedEra) - (ShelleyAddress nw pc scr) + AddressInEra + (ShelleyAddressInEra sBasedEra) + (ShelleyAddress nw pc scr) fromShelleyStakeAddr :: Shelley.RewardAccount StandardCrypto -> StakeAddress fromShelleyStakeAddr (Shelley.RewardAccount nw sc) = StakeAddress nw sc -fromShelleyStakeCredential :: Shelley.StakeCredential StandardCrypto - -> StakeCredential +fromShelleyStakeCredential + :: Shelley.StakeCredential StandardCrypto + -> StakeCredential fromShelleyStakeCredential (Shelley.KeyHashObj kh) = - StakeCredentialByKey (StakeKeyHash kh) + StakeCredentialByKey (StakeKeyHash kh) fromShelleyStakeCredential (Shelley.ScriptHashObj sh) = - StakeCredentialByScript (fromShelleyScriptHash sh) + StakeCredentialByScript (fromShelleyScriptHash sh) -fromShelleyPaymentCredential :: Shelley.PaymentCredential StandardCrypto - -> PaymentCredential +fromShelleyPaymentCredential + :: Shelley.PaymentCredential StandardCrypto + -> PaymentCredential fromShelleyPaymentCredential (Shelley.KeyHashObj kh) = PaymentCredentialByKey (PaymentKeyHash kh) fromShelleyPaymentCredential (Shelley.ScriptHashObj sh) = PaymentCredentialByScript (ScriptHash sh) -fromShelleyStakeReference :: Shelley.StakeReference StandardCrypto - -> StakeAddressReference +fromShelleyStakeReference + :: Shelley.StakeReference StandardCrypto + -> StakeAddressReference fromShelleyStakeReference (Shelley.StakeRefBase stakecred) = StakeAddressByValue (fromShelleyStakeCredential stakecred) fromShelleyStakeReference (Shelley.StakeRefPtr ptr) = diff --git a/cardano-api/internal/Cardano/Api/Anchor.hs b/cardano-api/internal/Cardano/Api/Anchor.hs index 740767c54a..ccd29c9ff3 100644 --- a/cardano-api/internal/Cardano/Api/Anchor.hs +++ b/cardano-api/internal/Cardano/Api/Anchor.hs @@ -1,19 +1,21 @@ -module Cardano.Api.Anchor ( - AnchorUrl(..), - AnchorDataHash(..) - ) where +module Cardano.Api.Anchor + ( AnchorUrl (..) + , AnchorDataHash (..) + ) +where import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.SafeHash as L - -- | The URL to build the anchor to pass to DRep registration certificate newtype AnchorUrl = AnchorUrl { unAnchorUrl :: L.Url - } deriving (Eq, Show) + } + deriving (Eq, Show) -- | The hash to build the anchor to pass to DRep registration certificate newtype AnchorDataHash = AnchorDataHash { unAnchorDataHash :: L.SafeHash Crypto.StandardCrypto L.AnchorData - } deriving (Eq, Show) + } + deriving (Eq, Show) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 90182c16f0..3ec24aa134 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -13,60 +13,64 @@ {-# LANGUAGE ViewPatterns #-} -- | Blocks in the blockchain --- -module Cardano.Api.Block ( - - -- * Blocks in the context of an era - Block(..), - pattern Block, - BlockHeader(..), - getBlockHeader, +module Cardano.Api.Block + ( -- * Blocks in the context of an era + Block (..) + , pattern Block + , BlockHeader (..) + , getBlockHeader -- ** Blocks in the context of a consensus mode - BlockInMode(..), - fromConsensusBlock, - toConsensusBlock, + , BlockInMode (..) + , fromConsensusBlock + , toConsensusBlock -- * Points on the chain - ChainPoint(..), - SlotNo(..), - EpochNo(..), - toConsensusPoint, - fromConsensusPoint, - fromConsensusPointHF, - toConsensusPointHF, + , ChainPoint (..) + , SlotNo (..) + , EpochNo (..) + , toConsensusPoint + , fromConsensusPoint + , fromConsensusPointHF + , toConsensusPointHF -- * Tip of the chain - ChainTip(..), - BlockNo(..), - chainTipToChainPoint, - fromConsensusTip, + , ChainTip (..) + , BlockNo (..) + , chainTipToChainPoint + , fromConsensusTip -- * Data family instances - Hash(..), - - chainPointToHeaderHash, - chainPointToSlotNo, - makeChainTip, - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Shelley -import Cardano.Api.Modes -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseUsing -import Cardano.Api.Tx.Sign - + , Hash (..) + , chainPointToHeaderHash + , chainPointToSlotNo + , makeChainTip + ) +where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Shelley +import Cardano.Api.Modes +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseUsing +import Cardano.Api.Tx.Sign import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Hashing import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Block as Ledger import qualified Cardano.Ledger.Era as Ledger -import Cardano.Slotting.Block (BlockNo) -import Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..)) +import Cardano.Slotting.Block (BlockNo) +import Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import Data.Foldable (Foldable (toList)) +import Data.String (IsString) +import Data.Text (Text) import qualified Ouroboros.Consensus.Block as Consensus import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus @@ -75,14 +79,6 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus import qualified Ouroboros.Network.Block as Consensus -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Short as SBS -import Data.Foldable (Foldable (toList)) -import Data.String (IsString) -import Data.Text (Text) - {- HLINT ignore "Use lambda" -} {- HLINT ignore "Use lambda-case" -} @@ -91,18 +87,16 @@ import Data.Text (Text) -- -- | A blockchain block in a particular Cardano era. --- data Block era where - - ByronBlock :: Consensus.ByronBlock - -> Block ByronEra - - ShelleyBlock :: ShelleyBasedEra era - -> Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) - -> Block era + ByronBlock + :: Consensus.ByronBlock + -> Block ByronEra + ShelleyBlock + :: ShelleyBasedEra era + -> Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) + -> Block era -- | A block consists of a header and a body containing transactions. --- pattern Block :: BlockHeader -> [Tx era] -> Block era pattern Block header txs <- (getBlockHeaderAndTxs -> (header, txs)) @@ -113,69 +107,70 @@ getBlockHeaderAndTxs block = (getBlockHeader block, getBlockTxs block) -- The GADT in the ShelleyBlock case requires a custom instance instance Show (Block era) where - showsPrec p (ByronBlock block) = - showParen (p >= 11) - ( showString "ByronBlock " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraShelley block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraShelley " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraAllegra block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraAllegra " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraMary block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraMary " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraAlonzo block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraAlonzo " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraBabbage block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraBabbage " - . showsPrec 11 block - ) - - showsPrec p (ShelleyBlock ShelleyBasedEraConway block) = - showParen (p >= 11) - ( showString "ShelleyBlock ShelleyBasedEraConway " - . showsPrec 11 block - ) - -getBlockTxs :: forall era . Block era -> [Tx era] + showsPrec p (ByronBlock block) = + showParen + (p >= 11) + ( showString "ByronBlock " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraShelley block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraShelley " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraAllegra block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraAllegra " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraMary block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraMary " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraAlonzo block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraAlonzo " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraBabbage block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraBabbage " + . showsPrec 11 block + ) + showsPrec p (ShelleyBlock ShelleyBasedEraConway block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraConway " + . showsPrec 11 block + ) + +getBlockTxs :: forall era. Block era -> [Tx era] getBlockTxs = \case -- In the context of foldBlocks we don't care about the Byron era. -- Testing leans on ledger events which is a Shelley onwards feature. - ByronBlock Consensus.ByronBlock{} -> [] - - ShelleyBlock sbe Consensus.ShelleyBlock{Consensus.shelleyBlockRaw} -> + ByronBlock Consensus.ByronBlock {} -> [] + ShelleyBlock sbe Consensus.ShelleyBlock {Consensus.shelleyBlockRaw} -> shelleyBasedEraConstraints sbe $ getShelleyBlockTxs sbe shelleyBlockRaw - -getShelleyBlockTxs :: forall era ledgerera blockheader. - ShelleyLedgerEra era ~ ledgerera - => Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera - => Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader - => ShelleyBasedEra era - -> Ledger.Block blockheader ledgerera - -> [Tx era] +getShelleyBlockTxs + :: forall era ledgerera blockheader + . ShelleyLedgerEra era ~ ledgerera + => Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera + => Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader + => ShelleyBasedEra era + -> Ledger.Block blockheader ledgerera + -> [Tx era] getShelleyBlockTxs era (Ledger.Block _header txs) = [ ShelleyTx era txinblock - | txinblock <- toList (Ledger.fromTxSeq txs) ] + | txinblock <- toList (Ledger.fromTxSeq txs) + ] -- ---------------------------------------------------------------------------- -- Block in a consensus mode @@ -191,39 +186,43 @@ data BlockInMode where deriving instance Show BlockInMode -fromConsensusBlock :: () +fromConsensusBlock + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => block -> BlockInMode fromConsensusBlock = \case - Consensus.BlockByron b' -> BlockInMode cardanoEra $ ByronBlock b' - Consensus.BlockShelley b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraShelley b' - Consensus.BlockAllegra b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAllegra b' - Consensus.BlockMary b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraMary b' - Consensus.BlockAlonzo b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b' - Consensus.BlockBabbage b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b' - Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b' - -toConsensusBlock :: () + Consensus.BlockByron b' -> BlockInMode cardanoEra $ ByronBlock b' + Consensus.BlockShelley b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraShelley b' + Consensus.BlockAllegra b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAllegra b' + Consensus.BlockMary b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraMary b' + Consensus.BlockAlonzo b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b' + Consensus.BlockBabbage b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b' + Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b' + +toConsensusBlock + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => BlockInMode -> block toConsensusBlock = \case - BlockInMode _ (ByronBlock b') -> Consensus.BlockByron b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') -> Consensus.BlockShelley b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') -> Consensus.BlockAllegra b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') -> Consensus.BlockMary b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') -> Consensus.BlockAlonzo b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') -> Consensus.BlockBabbage b' - BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') -> Consensus.BlockConway b' + BlockInMode _ (ByronBlock b') -> Consensus.BlockByron b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') -> Consensus.BlockShelley b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') -> Consensus.BlockAllegra b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') -> Consensus.BlockMary b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') -> Consensus.BlockAlonzo b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') -> Consensus.BlockBabbage b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') -> Consensus.BlockConway b' -- ---------------------------------------------------------------------------- -- Block headers -- -data BlockHeader = BlockHeader !SlotNo - !(Hash BlockHeader) - !BlockNo +data BlockHeader + = BlockHeader + !SlotNo + !(Hash BlockHeader) + !BlockNo -- | For now at least we use a fixed concrete hash type for all modes and era. -- The different eras do use different types, but it's all the same underlying @@ -231,53 +230,50 @@ data BlockHeader = BlockHeader !SlotNo newtype instance Hash BlockHeader = HeaderHash SBS.ShortByteString deriving (Eq, Ord, Show) deriving (ToJSON, FromJSON) via UsingRawBytesHex (Hash BlockHeader) - deriving IsString via UsingRawBytesHex (Hash BlockHeader) - - + deriving (IsString) via UsingRawBytesHex (Hash BlockHeader) instance SerialiseAsRawBytes (Hash BlockHeader) where - serialiseToRawBytes (HeaderHash bs) = SBS.fromShort bs + serialiseToRawBytes (HeaderHash bs) = SBS.fromShort bs - deserialiseFromRawBytes (AsHash AsBlockHeader) bs - | BS.length bs == 32 = Right $! HeaderHash (SBS.toShort bs) - | otherwise = Left (SerialiseAsRawBytesError "Unable to deserialise Hash BlockHeader") + deserialiseFromRawBytes (AsHash AsBlockHeader) bs + | BS.length bs == 32 = Right $! HeaderHash (SBS.toShort bs) + | otherwise = Left (SerialiseAsRawBytesError "Unable to deserialise Hash BlockHeader") instance HasTypeProxy BlockHeader where - data AsType BlockHeader = AsBlockHeader - proxyToAsType _ = AsBlockHeader + data AsType BlockHeader = AsBlockHeader + proxyToAsType _ = AsBlockHeader getBlockHeader - :: forall era . Block era -> BlockHeader + :: forall era. Block era -> BlockHeader getBlockHeader = \case ShelleyBlock sbe block -> - shelleyBasedEraConstraints sbe - $ let Consensus.HeaderFields { - Consensus.headerFieldHash - = Consensus.ShelleyHash (Crypto.UnsafeHash hashSBS), - Consensus.headerFieldSlot, - Consensus.headerFieldBlockNo + shelleyBasedEraConstraints sbe $ + let Consensus.HeaderFields + { Consensus.headerFieldHash = + Consensus.ShelleyHash (Crypto.UnsafeHash hashSBS) + , Consensus.headerFieldSlot + , Consensus.headerFieldBlockNo } = Consensus.getHeaderFields block - in BlockHeader headerFieldSlot (HeaderHash hashSBS) headerFieldBlockNo - + in BlockHeader headerFieldSlot (HeaderHash hashSBS) headerFieldBlockNo ByronBlock block -> BlockHeader headerFieldSlot (HeaderHash $ Cardano.Crypto.Hashing.abstractHashToShort byronHeaderHash) headerFieldBlockNo - where - Consensus.HeaderFields { - Consensus.headerFieldHash = Consensus.ByronHash byronHeaderHash, - Consensus.headerFieldSlot, - Consensus.headerFieldBlockNo + where + Consensus.HeaderFields + { Consensus.headerFieldHash = Consensus.ByronHash byronHeaderHash + , Consensus.headerFieldSlot + , Consensus.headerFieldBlockNo } = Consensus.getHeaderFields block - -- ---------------------------------------------------------------------------- -- Chain points -- -data ChainPoint = ChainPointAtGenesis - | ChainPoint !SlotNo !(Hash BlockHeader) +data ChainPoint + = ChainPointAtGenesis + | ChainPoint !SlotNo !(Hash BlockHeader) deriving (Eq, Show) instance Ord ChainPoint where @@ -305,46 +301,46 @@ instance FromJSON ChainPoint where _ -> fail "Expected tag to be ChainPointAtGenesis | ChainPoint" -- | Convert a 'Consensus.Point' for multi-era block type --- -toConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs - => ChainPoint -> Consensus.Point block -toConsensusPointHF ChainPointAtGenesis = Consensus.GenesisPoint +toConsensusPointHF + :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs + => ChainPoint -> Consensus.Point block +toConsensusPointHF ChainPointAtGenesis = Consensus.GenesisPoint toConsensusPointHF (ChainPoint slot (HeaderHash h)) = - Consensus.BlockPoint slot (Consensus.OneEraHash h) + Consensus.BlockPoint slot (Consensus.OneEraHash h) -- | Convert a 'Consensus.Point' for multi-era block type --- -fromConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs - => Consensus.Point block -> ChainPoint +fromConsensusPointHF + :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs + => Consensus.Point block -> ChainPoint fromConsensusPointHF Consensus.GenesisPoint = ChainPointAtGenesis fromConsensusPointHF (Consensus.BlockPoint slot (Consensus.OneEraHash h)) = - ChainPoint slot (HeaderHash h) + ChainPoint slot (HeaderHash h) -- | Convert a 'Consensus.Point' for single Shelley-era block type --- -toConsensusPoint :: forall ledgerera protocol. - Consensus.ShelleyCompatible protocol ledgerera - => ChainPoint - -> Consensus.Point (Consensus.ShelleyBlock protocol ledgerera) +toConsensusPoint + :: forall ledgerera protocol + . Consensus.ShelleyCompatible protocol ledgerera + => ChainPoint + -> Consensus.Point (Consensus.ShelleyBlock protocol ledgerera) toConsensusPoint ChainPointAtGenesis = Consensus.GenesisPoint toConsensusPoint (ChainPoint slot (HeaderHash h)) = - Consensus.BlockPoint slot (Consensus.fromShortRawHash proxy h) - where - proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera) - proxy = Proxy + Consensus.BlockPoint slot (Consensus.fromShortRawHash proxy h) + where + proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera) + proxy = Proxy -- | Convert a 'Consensus.Point' for single Shelley-era block type --- -fromConsensusPoint :: forall protocol ledgerera. - Consensus.ShelleyCompatible protocol ledgerera - => Consensus.Point (Consensus.ShelleyBlock protocol ledgerera) - -> ChainPoint +fromConsensusPoint + :: forall protocol ledgerera + . Consensus.ShelleyCompatible protocol ledgerera + => Consensus.Point (Consensus.ShelleyBlock protocol ledgerera) + -> ChainPoint fromConsensusPoint Consensus.GenesisPoint = ChainPointAtGenesis fromConsensusPoint (Consensus.BlockPoint slot h) = - ChainPoint slot (HeaderHash (Consensus.toShortRawHash proxy h)) - where - proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera) - proxy = Proxy + ChainPoint slot (HeaderHash (Consensus.toShortRawHash proxy h)) + where + proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera) + proxy = Proxy chainPointToSlotNo :: ChainPoint -> Maybe SlotNo chainPointToSlotNo ChainPointAtGenesis = Nothing @@ -354,7 +350,6 @@ chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader) chainPointToHeaderHash ChainPointAtGenesis = Nothing chainPointToHeaderHash (ChainPoint _ blockHeader) = Just blockHeader - -- ---------------------------------------------------------------------------- -- Chain tips -- @@ -363,22 +358,23 @@ chainPointToHeaderHash (ChainPoint _ blockHeader) = Just blockHeader -- chain: that is the most recent block at the end of the chain. -- -- It also carries the 'BlockNo' of the chain tip. --- -data ChainTip = ChainTipAtGenesis - | ChainTip !SlotNo !(Hash BlockHeader) !BlockNo +data ChainTip + = ChainTipAtGenesis + | ChainTip !SlotNo !(Hash BlockHeader) !BlockNo deriving (Eq, Show) instance ToJSON ChainTip where toJSON ChainTipAtGenesis = Aeson.Null toJSON (ChainTip slot headerHash (Consensus.BlockNo bNum)) = - object [ "slot" .= slot - , "hash" .= serialiseToRawBytesHexText headerHash - , "block" .= bNum - ] + object + [ "slot" .= slot + , "hash" .= serialiseToRawBytesHexText headerHash + , "block" .= bNum + ] chainTipToChainPoint :: ChainTip -> ChainPoint chainTipToChainPoint ChainTipAtGenesis = ChainPointAtGenesis -chainTipToChainPoint (ChainTip s h _) = ChainPoint s h +chainTipToChainPoint (ChainTip s h _) = ChainPoint s h makeChainTip :: WithOrigin BlockNo -> ChainPoint -> ChainTip makeChainTip woBlockNo chainPoint = case woBlockNo of @@ -387,14 +383,16 @@ makeChainTip woBlockNo chainPoint = case woBlockNo of ChainPointAtGenesis -> ChainTipAtGenesis ChainPoint slotNo headerHash -> ChainTip slotNo headerHash blockNo -fromConsensusTip :: () +fromConsensusTip + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => Consensus.Tip block -> ChainTip fromConsensusTip = conv - where - conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto) - -> ChainTip - conv Consensus.TipGenesis = ChainTipAtGenesis - conv (Consensus.Tip slot (Consensus.OneEraHash h) block) = - ChainTip slot (HeaderHash h) block + where + conv + :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto) + -> ChainTip + conv Consensus.TipGenesis = ChainTipAtGenesis + conv (Consensus.Tip slot (Consensus.OneEraHash h) block) = + ChainTip slot (HeaderHash h) block diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index ea8d4be064..5b74639f77 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -11,182 +11,179 @@ {-# LANGUAGE TypeFamilies #-} -- | Certificates embedded in transactions --- -module Cardano.Api.Certificate ( - Certificate(..), +module Cardano.Api.Certificate + ( Certificate (..) -- * Registering stake address and delegating - StakeAddressRequirements(..), - StakeDelegationRequirements(..), - makeStakeAddressDelegationCertificate, - makeStakeAddressRegistrationCertificate, - makeStakeAddressUnregistrationCertificate, - PoolId, + , StakeAddressRequirements (..) + , StakeDelegationRequirements (..) + , makeStakeAddressDelegationCertificate + , makeStakeAddressRegistrationCertificate + , makeStakeAddressUnregistrationCertificate + , PoolId -- * Registering stake pools - StakePoolRegistrationRequirements(..), - StakePoolRetirementRequirements(..), - makeStakePoolRegistrationCertificate, - makeStakePoolRetirementCertificate, - StakePoolParameters(..), - StakePoolRelay(..), - StakePoolMetadataReference(..), + , StakePoolRegistrationRequirements (..) + , StakePoolRetirementRequirements (..) + , makeStakePoolRegistrationCertificate + , makeStakePoolRetirementCertificate + , StakePoolParameters (..) + , StakePoolRelay (..) + , StakePoolMetadataReference (..) -- * Conway specific certificates - CommitteeColdkeyResignationRequirements(..), - CommitteeHotKeyAuthorizationRequirements(..), - DRepRegistrationRequirements(..), - DRepUnregistrationRequirements(..), - DRepUpdateRequirements(..), - makeCommitteeColdkeyResignationCertificate, - makeCommitteeHotKeyAuthorizationCertificate, - makeDrepRegistrationCertificate, - makeDrepUnregistrationCertificate, - makeDrepUpdateCertificate, - - makeStakeAddressAndDRepDelegationCertificate, + , CommitteeColdkeyResignationRequirements (..) + , CommitteeHotKeyAuthorizationRequirements (..) + , DRepRegistrationRequirements (..) + , DRepUnregistrationRequirements (..) + , DRepUpdateRequirements (..) + , makeCommitteeColdkeyResignationCertificate + , makeCommitteeHotKeyAuthorizationCertificate + , makeDrepRegistrationCertificate + , makeDrepUnregistrationCertificate + , makeDrepUpdateCertificate + , makeStakeAddressAndDRepDelegationCertificate -- * Registering DReps - DRepMetadataReference(..), + , DRepMetadataReference (..) -- * Special certificates - GenesisKeyDelegationRequirements(..), - MirCertificateRequirements(..), - makeMIRCertificate, - makeGenesisKeyDelegationCertificate, - Ledger.MIRTarget (..), - Ledger.MIRPot(..), - selectStakeCredentialWitness, + , GenesisKeyDelegationRequirements (..) + , MirCertificateRequirements (..) + , makeMIRCertificate + , makeGenesisKeyDelegationCertificate + , Ledger.MIRTarget (..) + , Ledger.MIRPot (..) + , selectStakeCredentialWitness -- * Internal conversion functions - toShelleyCertificate, - fromShelleyCertificate, - toShelleyPoolParams, - fromShelleyPoolParams, - + , toShelleyCertificate + , fromShelleyCertificate + , toShelleyPoolParams + , fromShelleyPoolParams -- * Data family instances - AsType(..), + , AsType (..) -- * Internal functions - filterUnRegCreds, - filterUnRegDRepCreds, - ) where - -import Cardano.Api.Address -import Cardano.Api.DRepMetadata -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToBabbageEra -import Cardano.Api.Eras -import Cardano.Api.Governance.Actions.VotingProcedure -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Praos -import Cardano.Api.Keys.Shelley -import Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto) + , filterUnRegCreds + , filterUnRegDRepCreds + ) +where + +import Cardano.Api.Address +import Cardano.Api.DRepMetadata +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eras +import Cardano.Api.Governance.Actions.VotingProcedure +import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Praos +import Cardano.Api.Keys.Shelley +import Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto) import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.Script -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.StakePoolMetadata -import Cardano.Api.Utils (noInlineMaybeToStrictMaybe) -import Cardano.Api.Value - +import Cardano.Api.Script +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.StakePoolMetadata +import Cardano.Api.Utils (noInlineMaybeToStrictMaybe) +import Cardano.Api.Value import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Keys as Ledger - -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.Foldable as Foldable -import Data.IP (IPv4, IPv6) -import Data.Maybe +import Data.IP (IPv4, IPv6) +import Data.Maybe import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Typeable -import Network.Socket (PortNumber) - +import Data.Typeable +import Network.Socket (PortNumber) -- ---------------------------------------------------------------------------- -- Certificates embedded in transactions -- data Certificate era where - -- Pre-Conway - -- 1. Stake registration - -- 2. Stake unregistration - -- 3. Stake delegation - -- 4. Pool retirement - -- 5. Pool registration - -- 6. Genesis delegation - -- 7. MIR certificates - ShelleyRelatedCertificate - :: ShelleyToBabbageEra era - -> Ledger.ShelleyTxCert (ShelleyLedgerEra era) - -> Certificate era - - -- Conway onwards - -- TODO: Add comments about the new types of certificates - ConwayCertificate - :: ConwayEraOnwards era - -> Ledger.ConwayTxCert (ShelleyLedgerEra era) - -> Certificate era - - deriving anyclass SerialiseAsCBOR + -- Pre-Conway + -- 1. Stake registration + -- 2. Stake unregistration + -- 3. Stake delegation + -- 4. Pool retirement + -- 5. Pool registration + -- 6. Genesis delegation + -- 7. MIR certificates + ShelleyRelatedCertificate + :: ShelleyToBabbageEra era + -> Ledger.ShelleyTxCert (ShelleyLedgerEra era) + -> Certificate era + -- Conway onwards + -- TODO: Add comments about the new types of certificates + ConwayCertificate + :: ConwayEraOnwards era + -> Ledger.ConwayTxCert (ShelleyLedgerEra era) + -> Certificate era + deriving anyclass (SerialiseAsCBOR) deriving instance Eq (Certificate era) + deriving instance Show (Certificate era) instance Typeable era => HasTypeProxy (Certificate era) where - data AsType (Certificate era) = AsCertificate - proxyToAsType _ = AsCertificate + data AsType (Certificate era) = AsCertificate + proxyToAsType _ = AsCertificate instance - forall era. - ( IsShelleyBasedEra era - ) => ToCBOR (Certificate era) where - toCBOR = - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate + forall era + . IsShelleyBasedEra era + => ToCBOR (Certificate era) + where + toCBOR = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate instance - ( IsShelleyBasedEra era - ) => FromCBOR (Certificate era) where - fromCBOR = - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) - + IsShelleyBasedEra era + => FromCBOR (Certificate era) + where + fromCBOR = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) instance - ( IsShelleyBasedEra era - ) => HasTextEnvelope (Certificate era) where - textEnvelopeType _ = - forEraInEon @ConwayEraOnwards (cardanoEra :: CardanoEra era) "CertificateShelley" (const "CertificateConway") - textEnvelopeDefaultDescr cert = case cert of - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyRegCert{}) -> "Stake address registration" - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyUnRegCert{}) -> "Stake address deregistration" - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyDelegCert{}) -> "Stake address delegation" - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RetirePool{}) -> "Pool retirement" - ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RegPool{}) -> "Pool registration" - ShelleyRelatedCertificate _ Ledger.ShelleyTxCertGenesisDeleg{} -> "Genesis key delegation" - ShelleyRelatedCertificate _ Ledger.ShelleyTxCertMir{} -> "MIR" - - -- Conway and onwards related - -- Constitutional Committee related - ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayRegDRep{}) -> "Constitution committee member key registration" - ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayUnRegDRep{}) -> "Constitution committee member key unregistration" - ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayUpdateDRep{}) -> "Constitution committee member key registration update" - ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayAuthCommitteeHotKey{}) -> "Constitution committee member hot key registration" - ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayResignCommitteeColdKey{}) -> "Constitution committee member hot key resignation" - - ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegCert{}) -> "Stake address registration" - ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayUnRegCert{}) -> "Stake address deregistration" - ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayDelegCert{}) -> "Stake address delegation" - ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegDelegCert{}) -> "Stake address registration and delegation" - ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RegPool{}) -> "Pool registration" - ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RetirePool{}) -> "Pool retirement" + IsShelleyBasedEra era + => HasTextEnvelope (Certificate era) + where + textEnvelopeType _ = + forEraInEon @ConwayEraOnwards + (cardanoEra :: CardanoEra era) + "CertificateShelley" + (const "CertificateConway") + textEnvelopeDefaultDescr cert = case cert of + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyRegCert {}) -> "Stake address registration" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyUnRegCert {}) -> "Stake address deregistration" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyDelegCert {}) -> "Stake address delegation" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RetirePool {}) -> "Pool retirement" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RegPool {}) -> "Pool registration" + ShelleyRelatedCertificate _ Ledger.ShelleyTxCertGenesisDeleg {} -> "Genesis key delegation" + ShelleyRelatedCertificate _ Ledger.ShelleyTxCertMir {} -> "MIR" + -- Conway and onwards related + -- Constitutional Committee related + ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayRegDRep {}) -> "Constitution committee member key registration" + ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayUnRegDRep {}) -> "Constitution committee member key unregistration" + ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayUpdateDRep {}) -> "Constitution committee member key registration update" + ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayAuthCommitteeHotKey {}) -> "Constitution committee member hot key registration" + ConwayCertificate _ (Ledger.ConwayTxCertGov Ledger.ConwayResignCommitteeColdKey {}) -> "Constitution committee member hot key resignation" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegCert {}) -> "Stake address registration" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayUnRegCert {}) -> "Stake address deregistration" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayDelegCert {}) -> "Stake address delegation" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegDelegCert {}) -> "Stake address registration and delegation" + ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RegPool {}) -> "Pool registration" + ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RetirePool {}) -> "Pool retirement" -- ---------------------------------------------------------------------------- -- Stake pool parameters @@ -194,55 +191,53 @@ instance type PoolId = Hash StakePoolKey -data StakePoolParameters = - StakePoolParameters { - stakePoolId :: PoolId, - stakePoolVRF :: Hash VrfKey, - stakePoolCost :: L.Coin, - stakePoolMargin :: Rational, - stakePoolRewardAccount :: StakeAddress, - stakePoolPledge :: L.Coin, - stakePoolOwners :: [Hash StakeKey], - stakePoolRelays :: [StakePoolRelay], - stakePoolMetadata :: Maybe StakePoolMetadataReference - } +data StakePoolParameters + = StakePoolParameters + { stakePoolId :: PoolId + , stakePoolVRF :: Hash VrfKey + , stakePoolCost :: L.Coin + , stakePoolMargin :: Rational + , stakePoolRewardAccount :: StakeAddress + , stakePoolPledge :: L.Coin + , stakePoolOwners :: [Hash StakeKey] + , stakePoolRelays :: [StakePoolRelay] + , stakePoolMetadata :: Maybe StakePoolMetadataReference + } deriving (Eq, Show) -data StakePoolRelay = - - -- | One or both of IPv4 & IPv6 - StakePoolRelayIp - (Maybe IPv4) (Maybe IPv6) (Maybe PortNumber) - - -- | An DNS name pointing to a @A@ or @AAAA@ record. - | StakePoolRelayDnsARecord - ByteString (Maybe PortNumber) - - -- | A DNS name pointing to a @SRV@ record. - | StakePoolRelayDnsSrvRecord - ByteString - +data StakePoolRelay + = -- | One or both of IPv4 & IPv6 + StakePoolRelayIp + (Maybe IPv4) + (Maybe IPv6) + (Maybe PortNumber) + | -- | An DNS name pointing to a @A@ or @AAAA@ record. + StakePoolRelayDnsARecord + ByteString + (Maybe PortNumber) + | -- | A DNS name pointing to a @SRV@ record. + StakePoolRelayDnsSrvRecord + ByteString deriving (Eq, Show) -data StakePoolMetadataReference = - StakePoolMetadataReference { - stakePoolMetadataURL :: Text, - stakePoolMetadataHash :: Hash StakePoolMetadata - } +data StakePoolMetadataReference + = StakePoolMetadataReference + { stakePoolMetadataURL :: Text + , stakePoolMetadataHash :: Hash StakePoolMetadata + } deriving (Eq, Show) -- ---------------------------------------------------------------------------- -- DRep parameters -- -data DRepMetadataReference = - DRepMetadataReference - { drepMetadataURL :: Text +data DRepMetadataReference + = DRepMetadataReference + { drepMetadataURL :: Text , drepMetadataHash :: Hash DRepMetadata } deriving (Eq, Show) - -- ---------------------------------------------------------------------------- -- Constructor functions -- @@ -253,7 +248,6 @@ data StakeAddressRequirements era where -> L.Coin -> StakeCredential -> StakeAddressRequirements era - StakeAddrRegistrationPreConway :: ShelleyToBabbageEra era -> StakeCredential @@ -262,26 +256,27 @@ data StakeAddressRequirements era where makeStakeAddressRegistrationCertificate :: StakeAddressRequirements era -> Certificate era makeStakeAddressRegistrationCertificate = \case StakeAddrRegistrationPreConway w scred -> - shelleyToBabbageEraConstraints w - $ ShelleyRelatedCertificate w - $ Ledger.mkRegTxCert $ toShelleyStakeCredential scred + shelleyToBabbageEraConstraints w $ + ShelleyRelatedCertificate w $ + Ledger.mkRegTxCert $ + toShelleyStakeCredential scred StakeAddrRegistrationConway cOnwards deposit scred -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkRegDepositTxCert (toShelleyStakeCredential scred) deposit + conwayEraOnwardsConstraints cOnwards $ + ConwayCertificate cOnwards $ + Ledger.mkRegDepositTxCert (toShelleyStakeCredential scred) deposit makeStakeAddressUnregistrationCertificate :: StakeAddressRequirements era -> Certificate era makeStakeAddressUnregistrationCertificate req = case req of StakeAddrRegistrationConway cOnwards deposit scred -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkUnRegDepositTxCert (toShelleyStakeCredential scred) deposit - + conwayEraOnwardsConstraints cOnwards $ + ConwayCertificate cOnwards $ + Ledger.mkUnRegDepositTxCert (toShelleyStakeCredential scred) deposit StakeAddrRegistrationPreConway atMostEra scred -> - shelleyToBabbageEraConstraints atMostEra - $ ShelleyRelatedCertificate atMostEra - $ Ledger.mkUnRegTxCert $ toShelleyStakeCredential scred + shelleyToBabbageEraConstraints atMostEra $ + ShelleyRelatedCertificate atMostEra $ + Ledger.mkUnRegTxCert $ + toShelleyStakeCredential scred data StakeDelegationRequirements era where StakeDelegationRequirementsConwayOnwards @@ -289,7 +284,6 @@ data StakeDelegationRequirements era where -> StakeCredential -> Ledger.Delegatee (EraCrypto (ShelleyLedgerEra era)) -> StakeDelegationRequirements era - StakeDelegationRequirementsPreConway :: ShelleyToBabbageEra era -> StakeCredential @@ -299,38 +293,37 @@ data StakeDelegationRequirements era where makeStakeAddressDelegationCertificate :: StakeDelegationRequirements era -> Certificate era makeStakeAddressDelegationCertificate = \case StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee - + conwayEraOnwardsConstraints cOnwards $ + ConwayCertificate cOnwards $ + Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee StakeDelegationRequirementsPreConway atMostBabbage scred pid -> - shelleyToBabbageEraConstraints atMostBabbage - $ ShelleyRelatedCertificate atMostBabbage - $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid) + shelleyToBabbageEraConstraints atMostBabbage $ + ShelleyRelatedCertificate atMostBabbage $ + Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid) data StakePoolRegistrationRequirements era where StakePoolRegistrationRequirementsConwayOnwards :: ConwayEraOnwards era -> Ledger.PoolParams (EraCrypto (ShelleyLedgerEra era)) -> StakePoolRegistrationRequirements era - StakePoolRegistrationRequirementsPreConway :: ShelleyToBabbageEra era -> Ledger.PoolParams (EraCrypto (ShelleyLedgerEra era)) -> StakePoolRegistrationRequirements era -makeStakePoolRegistrationCertificate :: () +makeStakePoolRegistrationCertificate + :: () => StakePoolRegistrationRequirements era -> Certificate era makeStakePoolRegistrationCertificate = \case StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkRegPoolTxCert poolParams + conwayEraOnwardsConstraints cOnwards $ + ConwayCertificate cOnwards $ + Ledger.mkRegPoolTxCert poolParams StakePoolRegistrationRequirementsPreConway atMostBab poolParams -> - shelleyToBabbageEraConstraints atMostBab - $ ShelleyRelatedCertificate atMostBab - $ Ledger.mkRegPoolTxCert poolParams + shelleyToBabbageEraConstraints atMostBab $ + ShelleyRelatedCertificate atMostBab $ + Ledger.mkRegPoolTxCert poolParams data StakePoolRetirementRequirements era where StakePoolRetirementRequirementsConwayOnwards @@ -338,26 +331,26 @@ data StakePoolRetirementRequirements era where -> PoolId -> Ledger.EpochNo -> StakePoolRetirementRequirements era - StakePoolRetirementRequirementsPreConway :: ShelleyToBabbageEra era -> PoolId -> Ledger.EpochNo -> StakePoolRetirementRequirements era -makeStakePoolRetirementCertificate :: () +makeStakePoolRetirementCertificate + :: () => StakePoolRetirementRequirements era -> Certificate era makeStakePoolRetirementCertificate req = case req of StakePoolRetirementRequirementsPreConway atMostBab poolId retirementEpoch -> - shelleyToBabbageEraConstraints atMostBab - $ ShelleyRelatedCertificate atMostBab - $ Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch + shelleyToBabbageEraConstraints atMostBab $ + ShelleyRelatedCertificate atMostBab $ + Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch StakePoolRetirementRequirementsConwayOnwards atMostBab poolId retirementEpoch -> - conwayEraOnwardsConstraints atMostBab - $ ConwayCertificate atMostBab - $ Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch + conwayEraOnwardsConstraints atMostBab $ + ConwayCertificate atMostBab $ + Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch data GenesisKeyDelegationRequirements ere where GenesisKeyDelegationRequirements @@ -368,11 +361,17 @@ data GenesisKeyDelegationRequirements ere where -> GenesisKeyDelegationRequirements era makeGenesisKeyDelegationCertificate :: GenesisKeyDelegationRequirements era -> Certificate era -makeGenesisKeyDelegationCertificate (GenesisKeyDelegationRequirements atMostEra - (GenesisKeyHash hGenKey) (GenesisDelegateKeyHash hGenDelegKey) (VrfKeyHash hVrfKey)) = - ShelleyRelatedCertificate atMostEra - $ shelleyToBabbageEraConstraints atMostEra - $ Ledger.ShelleyTxCertGenesisDeleg $ Ledger.GenesisDelegCert hGenKey hGenDelegKey hVrfKey +makeGenesisKeyDelegationCertificate + ( GenesisKeyDelegationRequirements + atMostEra + (GenesisKeyHash hGenKey) + (GenesisDelegateKeyHash hGenDelegKey) + (VrfKeyHash hVrfKey) + ) = + ShelleyRelatedCertificate atMostEra $ + shelleyToBabbageEraConstraints atMostEra $ + Ledger.ShelleyTxCertGenesisDeleg $ + Ledger.GenesisDelegCert hGenKey hGenDelegKey hVrfKey data MirCertificateRequirements era where MirCertificateRequirements @@ -381,12 +380,14 @@ data MirCertificateRequirements era where -> Ledger.MIRTarget (EraCrypto (ShelleyLedgerEra era)) -> MirCertificateRequirements era -makeMIRCertificate :: () +makeMIRCertificate + :: () => MirCertificateRequirements era -> Certificate era makeMIRCertificate (MirCertificateRequirements atMostEra mirPot mirTarget) = - ShelleyRelatedCertificate atMostEra - $ Ledger.ShelleyTxCertMir $ Ledger.MIRCert mirPot mirTarget + ShelleyRelatedCertificate atMostEra $ + Ledger.ShelleyTxCertMir $ + Ledger.MIRCert mirPot mirTarget data DRepRegistrationRequirements era where DRepRegistrationRequirements @@ -395,8 +396,8 @@ data DRepRegistrationRequirements era where -> L.Coin -> DRepRegistrationRequirements era - -makeDrepRegistrationCertificate :: () +makeDrepRegistrationCertificate + :: () => DRepRegistrationRequirements era -> Maybe (Ledger.Anchor (EraCrypto (ShelleyLedgerEra era))) -> Certificate era @@ -412,7 +413,8 @@ data CommitteeHotKeyAuthorizationRequirements era where -> Ledger.Credential Ledger.HotCommitteeRole (EraCrypto (ShelleyLedgerEra era)) -> CommitteeHotKeyAuthorizationRequirements era -makeCommitteeHotKeyAuthorizationCertificate :: () +makeCommitteeHotKeyAuthorizationCertificate + :: () => CommitteeHotKeyAuthorizationRequirements era -> Certificate era makeCommitteeHotKeyAuthorizationCertificate (CommitteeHotKeyAuthorizationRequirements cOnwards coldKeyCredential hotKeyCredential) = @@ -427,15 +429,16 @@ data CommitteeColdkeyResignationRequirements era where -> Maybe (Ledger.Anchor (EraCrypto (ShelleyLedgerEra era))) -> CommitteeColdkeyResignationRequirements era -makeCommitteeColdkeyResignationCertificate :: () +makeCommitteeColdkeyResignationCertificate + :: () => CommitteeColdkeyResignationRequirements era -> Certificate era makeCommitteeColdkeyResignationCertificate (CommitteeColdkeyResignationRequirements cOnwards coldKeyCred anchor) = ConwayCertificate cOnwards . Ledger.ConwayTxCertGov $ Ledger.ConwayResignCommitteeColdKey - coldKeyCred - (noInlineMaybeToStrictMaybe anchor) + coldKeyCred + (noInlineMaybeToStrictMaybe anchor) data DRepUnregistrationRequirements era where DRepUnregistrationRequirements @@ -444,7 +447,8 @@ data DRepUnregistrationRequirements era where -> L.Coin -> DRepUnregistrationRequirements era -makeDrepUnregistrationCertificate :: () +makeDrepUnregistrationCertificate + :: () => DRepUnregistrationRequirements era -> Certificate era makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards vcred deposit) = @@ -452,16 +456,17 @@ makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards . Ledger.ConwayTxCertGov $ Ledger.ConwayUnRegDRep vcred deposit -makeStakeAddressAndDRepDelegationCertificate :: () +makeStakeAddressAndDRepDelegationCertificate + :: () => ConwayEraOnwards era -> StakeCredential -> Ledger.Delegatee (EraCrypto (ShelleyLedgerEra era)) -> L.Coin -> Certificate era makeStakeAddressAndDRepDelegationCertificate w cred delegatee deposit = - conwayEraOnwardsConstraints w - $ ConwayCertificate w - $ Ledger.mkRegDepositDelegTxCert (toShelleyStakeCredential cred) delegatee deposit + conwayEraOnwardsConstraints w $ + ConwayCertificate w $ + Ledger.mkRegDepositDelegTxCert (toShelleyStakeCredential cred) delegatee deposit data DRepUpdateRequirements era where DRepUpdateRequirements @@ -499,40 +504,41 @@ selectStakeCredentialWitness :: Certificate era -> Maybe StakeCredential selectStakeCredentialWitness = \case - ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ - getTxCertWitness (shelleyToBabbageEraToShelleyBasedEra stbEra) shelleyCert - ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ - getTxCertWitness (conwayEraOnwardsToShelleyBasedEra cEra) conwayCert + ShelleyRelatedCertificate stbEra shelleyCert -> + shelleyToBabbageEraConstraints stbEra $ + getTxCertWitness (shelleyToBabbageEraToShelleyBasedEra stbEra) shelleyCert + ConwayCertificate cEra conwayCert -> + conwayEraOnwardsConstraints cEra $ + getTxCertWitness (conwayEraOnwardsToShelleyBasedEra cEra) conwayCert filterUnRegCreds :: Certificate era -> Maybe StakeCredential -filterUnRegCreds = fmap fromShelleyStakeCredential . \case - ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ - case shelleyCert of - Ledger.RegTxCert _ -> Nothing - Ledger.UnRegTxCert cred -> Just cred - Ledger.DelegStakeTxCert _ _ -> Nothing - Ledger.RegPoolTxCert _ -> Nothing - Ledger.RetirePoolTxCert _ _ -> Nothing - Ledger.MirTxCert _ -> Nothing - Ledger.GenesisDelegTxCert{} -> Nothing - - ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ - case conwayCert of - Ledger.RegTxCert _ -> Nothing - Ledger.UnRegTxCert cred -> Just cred - Ledger.RegPoolTxCert _ -> Nothing - Ledger.RetirePoolTxCert _ _ -> Nothing - Ledger.RegDepositTxCert _ _ -> Nothing - Ledger.UnRegDepositTxCert _ _ -> Nothing - Ledger.DelegTxCert _ _ -> Nothing - Ledger.RegDepositDelegTxCert{} -> Nothing - Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing - Ledger.ResignCommitteeColdTxCert{} -> Nothing - Ledger.RegDRepTxCert{} -> Nothing - Ledger.UnRegDRepTxCert{} -> Nothing - Ledger.UpdateDRepTxCert{} -> Nothing - +filterUnRegCreds = + fmap fromShelleyStakeCredential . \case + ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ + case shelleyCert of + Ledger.RegTxCert _ -> Nothing + Ledger.UnRegTxCert cred -> Just cred + Ledger.DelegStakeTxCert _ _ -> Nothing + Ledger.RegPoolTxCert _ -> Nothing + Ledger.RetirePoolTxCert _ _ -> Nothing + Ledger.MirTxCert _ -> Nothing + Ledger.GenesisDelegTxCert {} -> Nothing + ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ + case conwayCert of + Ledger.RegTxCert _ -> Nothing + Ledger.UnRegTxCert cred -> Just cred + Ledger.RegPoolTxCert _ -> Nothing + Ledger.RetirePoolTxCert _ _ -> Nothing + Ledger.RegDepositTxCert _ _ -> Nothing + Ledger.UnRegDepositTxCert _ _ -> Nothing + Ledger.DelegTxCert _ _ -> Nothing + Ledger.RegDepositDelegTxCert {} -> Nothing + Ledger.AuthCommitteeHotKeyTxCert {} -> Nothing + Ledger.ResignCommitteeColdTxCert {} -> Nothing + Ledger.RegDRepTxCert {} -> Nothing + Ledger.UnRegDRepTxCert {} -> Nothing + Ledger.UpdateDRepTxCert {} -> Nothing filterUnRegDRepCreds :: Certificate era -> Maybe (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) @@ -540,25 +546,26 @@ filterUnRegDRepCreds = \case ShelleyRelatedCertificate _ _ -> Nothing ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ case conwayCert of - Ledger.RegTxCert _ -> Nothing - Ledger.UnRegTxCert _ -> Nothing - Ledger.RegPoolTxCert _ -> Nothing - Ledger.RetirePoolTxCert _ _ -> Nothing - Ledger.RegDepositTxCert _ _ -> Nothing - Ledger.UnRegDepositTxCert _ _ -> Nothing - Ledger.DelegTxCert _ _ -> Nothing - Ledger.RegDepositDelegTxCert{} -> Nothing - Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing - Ledger.ResignCommitteeColdTxCert{} -> Nothing - Ledger.RegDRepTxCert{} -> Nothing - Ledger.UnRegDRepTxCert cred _ -> Just cred - Ledger.UpdateDRepTxCert{} -> Nothing + Ledger.RegTxCert _ -> Nothing + Ledger.UnRegTxCert _ -> Nothing + Ledger.RegPoolTxCert _ -> Nothing + Ledger.RetirePoolTxCert _ _ -> Nothing + Ledger.RegDepositTxCert _ _ -> Nothing + Ledger.UnRegDepositTxCert _ _ -> Nothing + Ledger.DelegTxCert _ _ -> Nothing + Ledger.RegDepositDelegTxCert {} -> Nothing + Ledger.AuthCommitteeHotKeyTxCert {} -> Nothing + Ledger.ResignCommitteeColdTxCert {} -> Nothing + Ledger.RegDRepTxCert {} -> Nothing + Ledger.UnRegDRepTxCert cred _ -> Just cred + Ledger.UpdateDRepTxCert {} -> Nothing -- ---------------------------------------------------------------------------- -- Internal conversion functions -- -toShelleyCertificate :: () +toShelleyCertificate + :: () => Certificate era -> Ledger.TxCert (ShelleyLedgerEra era) toShelleyCertificate = \case @@ -567,7 +574,8 @@ toShelleyCertificate = \case ConwayCertificate w c -> conwayEraOnwardsConstraints w c -fromShelleyCertificate :: () +fromShelleyCertificate + :: () => ShelleyBasedEra era -> Ledger.TxCert (ShelleyLedgerEra era) -> Certificate era @@ -575,61 +583,65 @@ fromShelleyCertificate = caseShelleyToBabbageOrConwayEraOnwards ShelleyRelatedCertificate ConwayCertificate toShelleyPoolParams :: StakePoolParameters -> Ledger.PoolParams StandardCrypto -toShelleyPoolParams StakePoolParameters { - stakePoolId = StakePoolKeyHash poolkh - , stakePoolVRF = VrfKeyHash vrfkh - , stakePoolCost - , stakePoolMargin - , stakePoolRewardAccount - , stakePoolPledge - , stakePoolOwners - , stakePoolRelays - , stakePoolMetadata - } = - --TODO: validate pool parameters such as the PoolMargin below, but also +toShelleyPoolParams + StakePoolParameters + { stakePoolId = StakePoolKeyHash poolkh + , stakePoolVRF = VrfKeyHash vrfkh + , stakePoolCost + , stakePoolMargin + , stakePoolRewardAccount + , stakePoolPledge + , stakePoolOwners + , stakePoolRelays + , stakePoolMetadata + } = + -- TODO: validate pool parameters such as the PoolMargin below, but also -- do simple client-side sanity checks, e.g. on the pool metadata url - Ledger.PoolParams { - Ledger.ppId = poolkh - , Ledger.ppVrf = vrfkh - , Ledger.ppPledge = stakePoolPledge - , Ledger.ppCost = stakePoolCost - , Ledger.ppMargin = fromMaybe - (error "toShelleyPoolParams: invalid PoolMargin") - (Ledger.boundRational stakePoolMargin) - , Ledger.ppRewardAccount = toShelleyStakeAddr stakePoolRewardAccount - , Ledger.ppOwners = Set.fromList - [ kh | StakeKeyHash kh <- stakePoolOwners ] - , Ledger.ppRelays = Seq.fromList - (map toShelleyStakePoolRelay stakePoolRelays) - , Ledger.ppMetadata = toShelleyPoolMetadata <$> - Ledger.maybeToStrictMaybe stakePoolMetadata - } - where + Ledger.PoolParams + { Ledger.ppId = poolkh + , Ledger.ppVrf = vrfkh + , Ledger.ppPledge = stakePoolPledge + , Ledger.ppCost = stakePoolCost + , Ledger.ppMargin = + fromMaybe + (error "toShelleyPoolParams: invalid PoolMargin") + (Ledger.boundRational stakePoolMargin) + , Ledger.ppRewardAccount = toShelleyStakeAddr stakePoolRewardAccount + , Ledger.ppOwners = + Set.fromList + [kh | StakeKeyHash kh <- stakePoolOwners] + , Ledger.ppRelays = + Seq.fromList + (map toShelleyStakePoolRelay stakePoolRelays) + , Ledger.ppMetadata = + toShelleyPoolMetadata + <$> Ledger.maybeToStrictMaybe stakePoolMetadata + } + where toShelleyStakePoolRelay :: StakePoolRelay -> Ledger.StakePoolRelay toShelleyStakePoolRelay (StakePoolRelayIp mipv4 mipv6 mport) = Ledger.SingleHostAddr (fromIntegral <$> Ledger.maybeToStrictMaybe mport) (Ledger.maybeToStrictMaybe mipv4) (Ledger.maybeToStrictMaybe mipv6) - toShelleyStakePoolRelay (StakePoolRelayDnsARecord dnsname mport) = Ledger.SingleHostName (fromIntegral <$> Ledger.maybeToStrictMaybe mport) (toShelleyDnsName dnsname) - toShelleyStakePoolRelay (StakePoolRelayDnsSrvRecord dnsname) = Ledger.MultiHostName (toShelleyDnsName dnsname) toShelleyPoolMetadata :: StakePoolMetadataReference -> Ledger.PoolMetadata - toShelleyPoolMetadata StakePoolMetadataReference { - stakePoolMetadataURL - , stakePoolMetadataHash = StakePoolMetadataHash mdh - } = - Ledger.PoolMetadata { - Ledger.pmUrl = toShelleyUrl stakePoolMetadataURL - , Ledger.pmHash = Ledger.hashToBytes mdh - } + toShelleyPoolMetadata + StakePoolMetadataReference + { stakePoolMetadataURL + , stakePoolMetadataHash = StakePoolMetadataHash mdh + } = + Ledger.PoolMetadata + { Ledger.pmUrl = toShelleyUrl stakePoolMetadataURL + , Ledger.pmHash = Ledger.hashToBytes mdh + } toShelleyDnsName :: ByteString -> Ledger.DnsName toShelleyDnsName name = @@ -639,15 +651,15 @@ toShelleyPoolParams StakePoolParameters { toShelleyUrl :: Text -> Ledger.Url toShelleyUrl url = - fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation") - $ Ledger.textToUrl (Text.length url) url + fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation") $ + Ledger.textToUrl (Text.length url) url - -fromShelleyPoolParams :: Ledger.PoolParams StandardCrypto - -> StakePoolParameters fromShelleyPoolParams - Ledger.PoolParams { - Ledger.ppId + :: Ledger.PoolParams StandardCrypto + -> StakePoolParameters +fromShelleyPoolParams + Ledger.PoolParams + { Ledger.ppId , Ledger.ppVrf , Ledger.ppPledge , Ledger.ppCost @@ -657,50 +669,54 @@ fromShelleyPoolParams , Ledger.ppRelays , Ledger.ppMetadata } = - StakePoolParameters { - stakePoolId = StakePoolKeyHash ppId - , stakePoolVRF = VrfKeyHash ppVrf - , stakePoolCost = ppCost - , stakePoolMargin = Ledger.unboundRational ppMargin - , stakePoolRewardAccount = fromShelleyStakeAddr ppRewardAccount - , stakePoolPledge = ppPledge - , stakePoolOwners = map StakeKeyHash (Set.toList ppOwners) - , stakePoolRelays = map fromShelleyStakePoolRelay - (Foldable.toList ppRelays) - , stakePoolMetadata = fromShelleyPoolMetadata <$> - Ledger.strictMaybeToMaybe ppMetadata - } - where + StakePoolParameters + { stakePoolId = StakePoolKeyHash ppId + , stakePoolVRF = VrfKeyHash ppVrf + , stakePoolCost = ppCost + , stakePoolMargin = Ledger.unboundRational ppMargin + , stakePoolRewardAccount = fromShelleyStakeAddr ppRewardAccount + , stakePoolPledge = ppPledge + , stakePoolOwners = map StakeKeyHash (Set.toList ppOwners) + , stakePoolRelays = + map + fromShelleyStakePoolRelay + (Foldable.toList ppRelays) + , stakePoolMetadata = + fromShelleyPoolMetadata + <$> Ledger.strictMaybeToMaybe ppMetadata + } + where fromShelleyStakePoolRelay :: Ledger.StakePoolRelay -> StakePoolRelay fromShelleyStakePoolRelay (Ledger.SingleHostAddr mport mipv4 mipv6) = StakePoolRelayIp (Ledger.strictMaybeToMaybe mipv4) (Ledger.strictMaybeToMaybe mipv6) (fromIntegral . Ledger.portToWord16 <$> Ledger.strictMaybeToMaybe mport) - fromShelleyStakePoolRelay (Ledger.SingleHostName mport dnsname) = StakePoolRelayDnsARecord (fromShelleyDnsName dnsname) (fromIntegral . Ledger.portToWord16 <$> Ledger.strictMaybeToMaybe mport) - fromShelleyStakePoolRelay (Ledger.MultiHostName dnsname) = StakePoolRelayDnsSrvRecord (fromShelleyDnsName dnsname) fromShelleyPoolMetadata :: Ledger.PoolMetadata -> StakePoolMetadataReference - fromShelleyPoolMetadata Ledger.PoolMetadata { - Ledger.pmUrl - , Ledger.pmHash - } = - StakePoolMetadataReference { - stakePoolMetadataURL = Ledger.urlToText pmUrl - , stakePoolMetadataHash = StakePoolMetadataHash - . fromMaybe (error "fromShelleyPoolMetadata: invalid hash. TODO: proper validation") - . Ledger.hashFromBytes - $ pmHash - } - - --TODO: change the ledger rep of the DNS name to use ShortByteString + fromShelleyPoolMetadata + Ledger.PoolMetadata + { Ledger.pmUrl + , Ledger.pmHash + } = + StakePoolMetadataReference + { stakePoolMetadataURL = Ledger.urlToText pmUrl + , stakePoolMetadataHash = + StakePoolMetadataHash + . fromMaybe (error "fromShelleyPoolMetadata: invalid hash. TODO: proper validation") + . Ledger.hashFromBytes + $ pmHash + } + + -- TODO: change the ledger rep of the DNS name to use ShortByteString fromShelleyDnsName :: Ledger.DnsName -> ByteString - fromShelleyDnsName = Text.encodeUtf8 - . Ledger.dnsToText + fromShelleyDnsName = + Text.encodeUtf8 + . Ledger.dnsToText diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index 50a2698f61..a46bc74e9b 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -1,72 +1,91 @@ {-# LANGUAGE DataKinds #-} -- | Convenience transaction construction functions --- -module Cardano.Api.Convenience.Construction ( - constructBalancedTx, +module Cardano.Api.Convenience.Construction + ( constructBalancedTx -- * Misc - TxInsExistError(..), - ScriptLockedTxInsError(..), - notScriptLockedTxIns, - renderNotScriptLockedTxInsError, - renderTxInsExistError, - txInsExistInUTxO, - - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Fees -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.Utils - + , TxInsExistError (..) + , ScriptLockedTxInsError (..) + , notScriptLockedTxIns + , renderNotScriptLockedTxInsError + , renderTxInsExistError + , txInsExistInUTxO + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Fees +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.Utils import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Credential as L import qualified Cardano.Ledger.Keys as L - import qualified Data.List as List import qualified Data.Map.Strict as Map -import Data.Set (Set) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text -- | Construct a balanced transaction. -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a -- convenient way of querying the node to get the required arguements -- for constructBalancedTx. -constructBalancedTx :: () +constructBalancedTx + :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era - -> AddressInEra era -- ^ Change address - -> Maybe Word -- ^ Override key witnesses - -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. + -> AddressInEra era + -- ^ Change address + -> Maybe Word + -- ^ Override key witnesses + -> UTxO era + -- ^ Just the transaction inputs, not the entire 'UTxO'. -> LedgerProtocolParameters era -> LedgerEpochInfo -> SystemStart - -> Set PoolId -- ^ The set of registered stake pools + -> Set PoolId + -- ^ The set of registered stake pools -> Map.Map StakeCredential L.Coin -> Map.Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin -> [ShelleyWitnessSigningKey] -> Either (TxBodyErrorAutoBalance era) (Tx era) -constructBalancedTx sbe txbodcontent changeAddr mOverrideWits utxo lpp - ledgerEpochInfo systemStart stakePools - stakeDelegDeposits drepDelegDeposits shelleyWitSigningKeys = do - - BalancedTxBody _ txbody _txBalanceOutput _fee - <- makeTransactionBodyAutoBalance - sbe systemStart ledgerEpochInfo - lpp stakePools stakeDelegDeposits drepDelegDeposits utxo txbodcontent - changeAddr mOverrideWits - - let keyWits = map (makeShelleyKeyWitness sbe txbody) shelleyWitSigningKeys - return $ makeSignedTransaction keyWits txbody +constructBalancedTx + sbe + txbodcontent + changeAddr + mOverrideWits + utxo + lpp + ledgerEpochInfo + systemStart + stakePools + stakeDelegDeposits + drepDelegDeposits + shelleyWitSigningKeys = do + BalancedTxBody _ txbody _txBalanceOutput _fee <- + makeTransactionBodyAutoBalance + sbe + systemStart + ledgerEpochInfo + lpp + stakePools + stakeDelegDeposits + drepDelegDeposits + utxo + txbodcontent + changeAddr + mOverrideWits + + let keyWits = map (makeShelleyKeyWitness sbe txbody) shelleyWitSigningKeys + return $ makeSignedTransaction keyWits txbody data TxInsExistError = TxInsDoNotExist [TxIn] @@ -76,34 +95,32 @@ renderTxInsExistError :: TxInsExistError -> Text renderTxInsExistError EmptyUTxO = "The UTxO is empty" renderTxInsExistError (TxInsDoNotExist txins) = - "The following tx input(s) were not present in the UTxO: " <> - Text.singleton '\n' <> - Text.intercalate (Text.singleton '\n') (map renderTxIn txins) + "The following tx input(s) were not present in the UTxO: " + <> Text.singleton '\n' + <> Text.intercalate (Text.singleton '\n') (map renderTxIn txins) txInsExistInUTxO :: [TxIn] -> UTxO era -> Either TxInsExistError () txInsExistInUTxO ins (UTxO utxo) | null utxo = Left EmptyUTxO | otherwise = do let utxoIns = Map.keys utxo - occursInUtxo = [ txin | txin <- ins, txin `elem` utxoIns ] + occursInUtxo = [txin | txin <- ins, txin `elem` utxoIns] if length occursInUtxo == length ins - then return () - else Left . TxInsDoNotExist $ ins List.\\ occursInUtxo + then return () + else Left . TxInsDoNotExist $ ins List.\\ occursInUtxo newtype ScriptLockedTxInsError = ScriptLockedTxIns [TxIn] renderNotScriptLockedTxInsError :: ScriptLockedTxInsError -> Text renderNotScriptLockedTxInsError (ScriptLockedTxIns txins) = - "The followings tx inputs were expected to be key witnessed but are actually script witnessed: " <> - textShow (map renderTxIn txins) + "The followings tx inputs were expected to be key witnessed but are actually script witnessed: " + <> textShow (map renderTxIn txins) notScriptLockedTxIns :: [TxIn] -> UTxO era -> Either ScriptLockedTxInsError () notScriptLockedTxIns collTxIns (UTxO utxo) = do let onlyCollateralUTxOs = Map.restrictKeys utxo $ Set.fromList collTxIns scriptLockedTxIns = - filter (\(_, TxOut aInEra _ _ _) -> not $ isKeyAddress aInEra ) $ Map.assocs onlyCollateralUTxOs + filter (\(_, TxOut aInEra _ _ _) -> not $ isKeyAddress aInEra) $ Map.assocs onlyCollateralUTxOs if null scriptLockedTxIns - then return () - else Left . ScriptLockedTxIns $ map fst scriptLockedTxIns - - + then return () + else Left . ScriptLockedTxIns $ map fst scriptLockedTxIns diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index dbdcb657e7..36febbc62d 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -7,56 +7,54 @@ {-# LANGUAGE TypeFamilies #-} -- | Convenience query functions --- -module Cardano.Api.Convenience.Query ( - QueryConvenienceError(..), - TxCurrentTreasuryValue(..), - determineEra, - -- * Simplest query related - executeQueryCardanoMode, - executeQueryAnyMode, - - queryStateForBalancedTx, - renderQueryConvenienceError, - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Feature (Featured (..)) -import Cardano.Api.IO -import Cardano.Api.IPC -import Cardano.Api.IPC.Monad -import Cardano.Api.Monad.Error -import Cardano.Api.NetworkId -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query -import Cardano.Api.Query.Expr -import Cardano.Api.Tx.Body -import Cardano.Api.Utils +module Cardano.Api.Convenience.Query + ( QueryConvenienceError (..) + , TxCurrentTreasuryValue (..) + , determineEra + -- * Simplest query related + , executeQueryCardanoMode + , executeQueryAnyMode + , queryStateForBalancedTx + , renderQueryConvenienceError + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.Feature (Featured (..)) +import Cardano.Api.IO +import Cardano.Api.IPC +import Cardano.Api.IPC.Monad +import Cardano.Api.Monad.Error +import Cardano.Api.NetworkId +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query +import Cardano.Api.Query.Expr +import Cardano.Api.Tx.Body +import Cardano.Api.Utils import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.CertState (DRepState (..)) +import Cardano.Ledger.CertState (DRepState (..)) import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Credential as L import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.Shelley.LedgerState as L -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..)) -import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) - -import Control.Exception.Safe (SomeException, displayException) -import Control.Monad -import Data.Bifunctor (first) -import Data.Function ((&)) -import Data.Map (Map) +import Control.Exception.Safe (SomeException, displayException) +import Control.Monad +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) -import Data.Set (Set) +import Data.Maybe (mapMaybe) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) -import GHC.Exts (IsString (..)) +import Data.Text (Text) +import GHC.Exts (IsString (..)) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) data QueryConvenienceError = AcqFailure AcquiringFailure @@ -64,34 +62,47 @@ data QueryConvenienceError | ByronEraNotSupported | QceUnsupportedNtcVersion !UnsupportedNtcVersionError | QceUnexpectedException !SomeException - deriving Show + deriving (Show) renderQueryConvenienceError :: QueryConvenienceError -> Text renderQueryConvenienceError (AcqFailure e) = "Acquiring failure: " <> textShow e renderQueryConvenienceError (QueryEraMismatch (EraMismatch ledgerEraName' otherEraName')) = - "The era of the node and the tx do not match. " <> - "The node is running in the " <> ledgerEraName' <> - " era, but the transaction is for the " <> otherEraName' <> " era." + "The era of the node and the tx do not match. " + <> "The node is running in the " + <> ledgerEraName' + <> " era, but the transaction is for the " + <> otherEraName' + <> " era." renderQueryConvenienceError ByronEraNotSupported = "Byron era not supported" renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion)) = - "Unsupported feature for the node-to-client protocol version.\n" <> - "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <> - "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." + "Unsupported feature for the node-to-client protocol version.\n" + <> "This query requires at least " + <> textShow minNtcVersion + <> " but the node negotiated " + <> textShow ntcVersion + <> ".\n" + <> "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." renderQueryConvenienceError (QceUnexpectedException e) = "Unexpected exception while processing query:\n" <> fromString (displayException e) -newtype TxCurrentTreasuryValue = TxCurrentTreasuryValue { unTxCurrentTreasuryValue :: L.Coin } - deriving newtype Show +newtype TxCurrentTreasuryValue = TxCurrentTreasuryValue {unTxCurrentTreasuryValue :: L.Coin} + deriving newtype (Show) -- | A convenience function to query the relevant information, from -- the local node, for Cardano.Api.Convenience.Construction.constructBalancedTx -queryStateForBalancedTx :: () +queryStateForBalancedTx + :: () => CardanoEra era -> [TxIn] -> [Certificate era] - -> LocalStateQueryExpr block point QueryInMode r IO + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO ( Either QueryConvenienceError ( UTxO era @@ -101,32 +112,40 @@ queryStateForBalancedTx :: () , Set PoolId , Map StakeCredential L.Coin , Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin - , Maybe (Featured ConwayEraOnwards era TxCurrentTreasuryValue)) ) + , Maybe (Featured ConwayEraOnwards era TxCurrentTreasuryValue) + ) + ) queryStateForBalancedTx era allTxIns certs = runExceptT $ do - sbe <- requireShelleyBasedEra era - & onNothing (left ByronEraNotSupported) + sbe <- + requireShelleyBasedEra era + & onNothing (left ByronEraNotSupported) let stakeCreds = Set.fromList $ mapMaybe filterUnRegCreds certs - drepCreds = Set.fromList $ mapMaybe filterUnRegDRepCreds certs + drepCreds = Set.fromList $ mapMaybe filterUnRegDRepCreds certs -- Query execution - utxo <- lift (queryUtxo sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) - & onLeft (left . QceUnsupportedNtcVersion) - & onLeft (left . QueryEraMismatch) + utxo <- + lift (queryUtxo sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch) - pparams <- lift (queryProtocolParameters sbe) - & onLeft (left . QceUnsupportedNtcVersion) - & onLeft (left . QueryEraMismatch) + pparams <- + lift (queryProtocolParameters sbe) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch) - eraHistory <- lift queryEraHistory - & onLeft (left . QceUnsupportedNtcVersion) + eraHistory <- + lift queryEraHistory + & onLeft (left . QceUnsupportedNtcVersion) - systemStart <- lift querySystemStart - & onLeft (left . QceUnsupportedNtcVersion) + systemStart <- + lift querySystemStart + & onLeft (left . QceUnsupportedNtcVersion) - stakePools <- lift (queryStakePools sbe) - & onLeft (left . QceUnsupportedNtcVersion) - & onLeft (left . QueryEraMismatch) + stakePools <- + lift (queryStakePools sbe) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch) stakeDelegDeposits <- monoidForEraInEonA era $ \beo -> @@ -136,27 +155,39 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do drepDelegDeposits <- monoidForEraInEonA era $ \con -> - Map.map drepDeposit <$> - (lift (queryDRepState con drepCreds) - & onLeft (left . QceUnsupportedNtcVersion) - & onLeft (left . QueryEraMismatch)) + Map.map drepDeposit + <$> ( lift (queryDRepState con drepCreds) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch) + ) featuredTxTreasuryValueM <- caseShelleyToBabbageOrConwayEraOnwards (const $ pure Nothing) - (\cOnwards -> do - L.AccountState { L.asTreasury } <- - lift (queryAccountState cOnwards) - & onLeft (left . QceUnsupportedNtcVersion) - & onLeft (left . QueryEraMismatch) - let txCurrentTreasuryValue = TxCurrentTreasuryValue asTreasury - return $ Just $ Featured cOnwards txCurrentTreasuryValue) + ( \cOnwards -> do + L.AccountState {L.asTreasury} <- + lift (queryAccountState cOnwards) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch) + let txCurrentTreasuryValue = TxCurrentTreasuryValue asTreasury + return $ Just $ Featured cOnwards txCurrentTreasuryValue + ) sbe - pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, featuredTxTreasuryValueM) + pure + ( utxo + , LedgerProtocolParameters pparams + , eraHistory + , systemStart + , stakePools + , stakeDelegDeposits + , drepDelegDeposits + , featuredTxTreasuryValueM + ) -- | Query the node to determine which era it is in. -determineEra :: () +determineEra + :: () => LocalNodeConnectInfo -> ExceptT AcquiringFailure IO AnyCardanoEra determineEra localNodeConnInfo = @@ -164,7 +195,8 @@ determineEra localNodeConnInfo = -- | Execute a query against the local node. The local -- node must be in CardanoMode. -executeQueryCardanoMode :: () +executeQueryCardanoMode + :: () => SocketPath -> NetworkId -> QueryInMode (Either EraMismatch result) @@ -180,12 +212,15 @@ executeQueryCardanoMode socketPath nid q = do executeQueryAnyMode localNodeConnInfo q -- | Execute a query against the local node in any mode. -executeQueryAnyMode :: forall result. () +executeQueryAnyMode + :: forall result + . () => LocalNodeConnectInfo -> QueryInMode (Either EraMismatch result) -> ExceptT QueryConvenienceError IO result executeQueryAnyMode localNodeConnInfo q = - liftEither <=< fmap (first QueryEraMismatch) - . handleIOExceptionsWith QceUnexpectedException - . modifyError AcqFailure + liftEither + <=< fmap (first QueryEraMismatch) + . handleIOExceptionsWith QceUnexpectedException + . modifyError AcqFailure $ queryNodeLocalState localNodeConnInfo VolatileTip q diff --git a/cardano-api/internal/Cardano/Api/DRepMetadata.hs b/cardano-api/internal/Cardano/Api/DRepMetadata.hs index bc8da34f42..589b474c75 100644 --- a/cardano-api/internal/Cardano/Api/DRepMetadata.hs +++ b/cardano-api/internal/Cardano/Api/DRepMetadata.hs @@ -1,43 +1,40 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -- | DRep off-chain metadata --- -module Cardano.Api.DRepMetadata ( - -- * DRep off-chain metadata - DRepMetadata(..), - hashDRepMetadata, +module Cardano.Api.DRepMetadata + ( -- * DRep off-chain metadata + DRepMetadata (..) + , hashDRepMetadata -- * Data family instances - AsType(..), - Hash(..), - ) where - -import Cardano.Api.Eras -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Praos -import Cardano.Api.Script -import Cardano.Api.SerialiseRaw - + , AsType (..) + , Hash (..) + ) +where + +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Praos +import Cardano.Api.Script +import Cardano.Api.SerialiseRaw import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley - -import Data.ByteString (ByteString) -import Data.Either.Combinators (maybeToRight) +import Data.ByteString (ByteString) +import Data.Either.Combinators (maybeToRight) -- ---------------------------------------------------------------------------- -- DRep metadata -- -- | A representation of the required fields for off-chain drep metadata. --- newtype DRepMetadata = DRepMetadata { unDRepMetadata :: ByteString - } deriving (Eq, Show) + } + deriving (Eq, Show) newtype instance Hash DRepMetadata = DRepMetadataHash (Shelley.Hash StandardCrypto ByteString) deriving (Eq, Show) @@ -58,7 +55,6 @@ hashDRepMetadata :: ByteString -> (DRepMetadata, Hash DRepMetadata) hashDRepMetadata bs = - let md = DRepMetadata bs - mdh = DRepMetadataHash (Crypto.hashWith id bs) in - (md, mdh) - + let md = DRepMetadata bs + mdh = DRepMetadataHash (Crypto.hashWith id bs) + in (md, mdh) diff --git a/cardano-api/internal/Cardano/Api/DeserialiseAnyOf.hs b/cardano-api/internal/Cardano/Api/DeserialiseAnyOf.hs index 89bf363685..db524de708 100644 --- a/cardano-api/internal/Cardano/Api/DeserialiseAnyOf.hs +++ b/cardano-api/internal/Cardano/Api/DeserialiseAnyOf.hs @@ -5,48 +5,45 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Class of errors used in the Api. --- module Cardano.Api.DeserialiseAnyOf ( InputFormat (..) , InputDecodeError (..) , deserialiseInput , deserialiseInputAnyOf , renderInputDecodeError - -- TODO: Consider moving everything below - , SomeAddressVerificationKey(..) + , SomeAddressVerificationKey (..) , deserialiseAnyVerificationKey , deserialiseAnyVerificationKeyBech32 , deserialiseAnyVerificationKeyTextEnvelope , renderSomeAddressVerificationKey , mapSomeAddressVerificationKey - ) where - -import Cardano.Api.Address -import Cardano.Api.Error -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Class -import Cardano.Api.Keys.Praos -import Cardano.Api.Keys.Shelley -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope - + ) +where + +import Cardano.Api.Address +import Cardano.Api.Error +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Class +import Cardano.Api.Keys.Praos +import Cardano.Api.Keys.Shelley +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Chain.Common as Common import qualified Cardano.Crypto.Signing as Crypto - import qualified Data.Aeson as Aeson -import Data.Bifunctor (first) -import Data.ByteString (ByteString) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC -import Data.Char (toLower) -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty) +import Data.Char (toLower) +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Formatting (build, sformat, (%)) -import Prettyprinter +import Formatting (build, sformat, (%)) +import Prettyprinter ------------------------------------------------------------------------------ -- Formatted/encoded input deserialisation @@ -56,27 +53,26 @@ import Prettyprinter data InputFormat a where -- | Bech32 encoding. InputFormatBech32 :: SerialiseAsBech32 a => InputFormat a - -- | Hex/Base16 encoding. InputFormatHex :: SerialiseAsRawBytes a => InputFormat a - -- TODO: Specify TextEnvelope CBOR hex + -- | Text envelope format. InputFormatTextEnvelope :: HasTextEnvelope a => InputFormat a - -- TODO: Add constructor for TextEnvelope Bech32 +-- TODO: Add constructor for TextEnvelope Bech32 -- | Input decoding error. data InputDecodeError - = InputTextEnvelopeError !TextEnvelopeError - -- ^ The provided data seems to be a valid text envelope, but some error - -- occurred in deserialising it. - | InputBech32DecodeError !Bech32DecodeError - -- ^ The provided data is valid Bech32, but some error occurred in - -- deserialising it. - | InputInvalidError - -- ^ The provided data does not represent a valid value of the provided - -- type. + = -- | The provided data seems to be a valid text envelope, but some error + -- occurred in deserialising it. + InputTextEnvelopeError !TextEnvelopeError + | -- | The provided data is valid Bech32, but some error occurred in + -- deserialising it. + InputBech32DecodeError !Bech32DecodeError + | -- | The provided data does not represent a valid value of the provided + -- type. + InputInvalidError deriving (Eq, Show, Data) instance Error InputDecodeError where @@ -97,221 +93,220 @@ renderInputDecodeError = \case -- Note that this type isn't intended to be exported, but only used as a -- helper within the 'deserialiseInput' function. data DeserialiseInputResult a - = DeserialiseInputSuccess !a - -- ^ Input successfully deserialised. - | DeserialiseInputError !InputDecodeError - -- ^ The provided data is of the expected format/encoding, but an error - -- occurred in deserialising it. - | DeserialiseInputErrorFormatMismatch - -- ^ The provided data's formatting/encoding does not match that which was - -- expected. This error is an indication that one could attempt to - -- deserialise the input again, but instead expecting a different format. + = -- | Input successfully deserialised. + DeserialiseInputSuccess !a + | -- | The provided data is of the expected format/encoding, but an error + -- occurred in deserialising it. + DeserialiseInputError !InputDecodeError + | -- | The provided data's formatting/encoding does not match that which was + -- expected. This error is an indication that one could attempt to + -- deserialise the input again, but instead expecting a different format. + DeserialiseInputErrorFormatMismatch -- | Deserialise an input of some type that is formatted in some way. deserialiseInput - :: forall a. - AsType a + :: forall a + . AsType a -> NonEmpty (InputFormat a) -> ByteString -> Either InputDecodeError a deserialiseInput asType acceptedFormats inputBs = - go (NE.toList acceptedFormats) - where - inputText :: Text - inputText = Text.decodeUtf8 inputBs - - go :: [InputFormat a] -> Either InputDecodeError a - go [] = Left InputInvalidError - go (kf:kfs) = - let res = - case kf of - InputFormatBech32 -> deserialiseBech32 - InputFormatHex -> deserialiseHex - InputFormatTextEnvelope -> deserialiseTextEnvelope - in case res of - DeserialiseInputSuccess a -> Right a - DeserialiseInputError err -> Left err - DeserialiseInputErrorFormatMismatch -> go kfs - - deserialiseTextEnvelope :: HasTextEnvelope a => DeserialiseInputResult a - deserialiseTextEnvelope = do - let textEnvRes :: Either TextEnvelopeError a - textEnvRes = - deserialiseFromTextEnvelope asType - =<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs) - case textEnvRes of - Right res -> DeserialiseInputSuccess res - - -- The input was valid a text envelope, but there was a type mismatch - -- error. - Left err@TextEnvelopeTypeError{} -> - DeserialiseInputError (InputTextEnvelopeError err) - - -- The input was not valid a text envelope. - Left _ -> DeserialiseInputErrorFormatMismatch - - deserialiseBech32 :: SerialiseAsBech32 a => DeserialiseInputResult a - deserialiseBech32 = - case deserialiseFromBech32 asType inputText of - Right res -> DeserialiseInputSuccess res - - -- The input was not valid Bech32. - Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch - - -- The input was valid Bech32, but some other error occurred. - Left err -> DeserialiseInputError $ InputBech32DecodeError err - - deserialiseHex :: SerialiseAsRawBytes a => DeserialiseInputResult a - deserialiseHex - | isValidHex inputBs = - case deserialiseFromRawBytesHex asType inputBs of - Left _ -> DeserialiseInputError InputInvalidError - Right x -> DeserialiseInputSuccess x - | otherwise = DeserialiseInputErrorFormatMismatch - - isValidHex :: ByteString -> Bool - isValidHex x = - all (`elem` hexAlpha) (toLower <$> BSC.unpack x) - && even (BSC.length x) - where - hexAlpha :: [Char] - hexAlpha = "0123456789abcdef" + go (NE.toList acceptedFormats) + where + inputText :: Text + inputText = Text.decodeUtf8 inputBs + + go :: [InputFormat a] -> Either InputDecodeError a + go [] = Left InputInvalidError + go (kf : kfs) = + let res = + case kf of + InputFormatBech32 -> deserialiseBech32 + InputFormatHex -> deserialiseHex + InputFormatTextEnvelope -> deserialiseTextEnvelope + in case res of + DeserialiseInputSuccess a -> Right a + DeserialiseInputError err -> Left err + DeserialiseInputErrorFormatMismatch -> go kfs + + deserialiseTextEnvelope :: HasTextEnvelope a => DeserialiseInputResult a + deserialiseTextEnvelope = do + let textEnvRes :: Either TextEnvelopeError a + textEnvRes = + deserialiseFromTextEnvelope asType + =<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs) + case textEnvRes of + Right res -> DeserialiseInputSuccess res + -- The input was valid a text envelope, but there was a type mismatch + -- error. + Left err@TextEnvelopeTypeError {} -> + DeserialiseInputError (InputTextEnvelopeError err) + -- The input was not valid a text envelope. + Left _ -> DeserialiseInputErrorFormatMismatch + + deserialiseBech32 :: SerialiseAsBech32 a => DeserialiseInputResult a + deserialiseBech32 = + case deserialiseFromBech32 asType inputText of + Right res -> DeserialiseInputSuccess res + -- The input was not valid Bech32. + Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch + -- The input was valid Bech32, but some other error occurred. + Left err -> DeserialiseInputError $ InputBech32DecodeError err + + deserialiseHex :: SerialiseAsRawBytes a => DeserialiseInputResult a + deserialiseHex + | isValidHex inputBs = + case deserialiseFromRawBytesHex asType inputBs of + Left _ -> DeserialiseInputError InputInvalidError + Right x -> DeserialiseInputSuccess x + | otherwise = DeserialiseInputErrorFormatMismatch + + isValidHex :: ByteString -> Bool + isValidHex x = + all ((`elem` hexAlpha) . toLower) (BSC.unpack x) + && even (BSC.length x) + where + hexAlpha :: [Char] + hexAlpha = "0123456789abcdef" -- | Deserialise an input of some type that is formatted in some way. -- -- The provided 'ByteString' can either be Bech32-encoded or in the text -- envelope format. deserialiseInputAnyOf - :: forall b. - [FromSomeType SerialiseAsBech32 b] + :: forall b + . [FromSomeType SerialiseAsBech32 b] -> [FromSomeType HasTextEnvelope b] -> ByteString -> Either InputDecodeError b deserialiseInputAnyOf bech32Types textEnvTypes inputBs = - case deserialiseBech32 `orTry` deserialiseTextEnvelope of - DeserialiseInputSuccess res -> Right res - DeserialiseInputError err -> Left err - DeserialiseInputErrorFormatMismatch -> Left InputInvalidError - where - inputText :: Text - inputText = Text.decodeUtf8 inputBs - - orTry - :: DeserialiseInputResult b - -> DeserialiseInputResult b - -> DeserialiseInputResult b - orTry x y = - case x of - DeserialiseInputSuccess _ -> x - DeserialiseInputError _ -> x - DeserialiseInputErrorFormatMismatch -> y - - deserialiseTextEnvelope :: DeserialiseInputResult b - deserialiseTextEnvelope = do - let textEnvRes :: Either TextEnvelopeError b - textEnvRes = - deserialiseFromTextEnvelopeAnyOf textEnvTypes - =<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs) - case textEnvRes of - Right res -> DeserialiseInputSuccess res - - -- The input was valid a text envelope, but there was a type mismatch - -- error. - Left err@TextEnvelopeTypeError{} -> - DeserialiseInputError (InputTextEnvelopeError err) - - -- The input was not valid a text envelope. - Left _ -> DeserialiseInputErrorFormatMismatch - - deserialiseBech32 :: DeserialiseInputResult b - deserialiseBech32 = - case deserialiseAnyOfFromBech32 bech32Types inputText of - Right res -> DeserialiseInputSuccess res - - -- The input was not valid Bech32. - Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch - - -- The input was valid Bech32, but some other error occurred. - Left err -> DeserialiseInputError $ InputBech32DecodeError err + case deserialiseBech32 `orTry` deserialiseTextEnvelope of + DeserialiseInputSuccess res -> Right res + DeserialiseInputError err -> Left err + DeserialiseInputErrorFormatMismatch -> Left InputInvalidError + where + inputText :: Text + inputText = Text.decodeUtf8 inputBs + + orTry + :: DeserialiseInputResult b + -> DeserialiseInputResult b + -> DeserialiseInputResult b + orTry x y = + case x of + DeserialiseInputSuccess _ -> x + DeserialiseInputError _ -> x + DeserialiseInputErrorFormatMismatch -> y + + deserialiseTextEnvelope :: DeserialiseInputResult b + deserialiseTextEnvelope = do + let textEnvRes :: Either TextEnvelopeError b + textEnvRes = + deserialiseFromTextEnvelopeAnyOf textEnvTypes + =<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs) + case textEnvRes of + Right res -> DeserialiseInputSuccess res + -- The input was valid a text envelope, but there was a type mismatch + -- error. + Left err@TextEnvelopeTypeError {} -> + DeserialiseInputError (InputTextEnvelopeError err) + -- The input was not valid a text envelope. + Left _ -> DeserialiseInputErrorFormatMismatch + + deserialiseBech32 :: DeserialiseInputResult b + deserialiseBech32 = + case deserialiseAnyOfFromBech32 bech32Types inputText of + Right res -> DeserialiseInputSuccess res + -- The input was not valid Bech32. + Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch + -- The input was valid Bech32, but some other error occurred. + Left err -> DeserialiseInputError $ InputBech32DecodeError err data SomeAddressVerificationKey - = AByronVerificationKey (VerificationKey ByronKey) - | APaymentVerificationKey (VerificationKey PaymentKey) - | APaymentExtendedVerificationKey (VerificationKey PaymentExtendedKey) - | AGenesisUTxOVerificationKey (VerificationKey GenesisUTxOKey) - | AGenesisExtendedVerificationKey (VerificationKey GenesisExtendedKey) + = AByronVerificationKey (VerificationKey ByronKey) + | APaymentVerificationKey (VerificationKey PaymentKey) + | APaymentExtendedVerificationKey (VerificationKey PaymentExtendedKey) + | AGenesisUTxOVerificationKey (VerificationKey GenesisUTxOKey) + | AGenesisExtendedVerificationKey (VerificationKey GenesisExtendedKey) | AGenesisDelegateExtendedVerificationKey - (VerificationKey GenesisDelegateExtendedKey) - | AKesVerificationKey (VerificationKey KesKey) - | AVrfVerificationKey (VerificationKey VrfKey) - | AStakeVerificationKey (VerificationKey StakeKey) - | AStakeExtendedVerificationKey (VerificationKey StakeExtendedKey) - | ADRepVerificationKey (VerificationKey DRepKey) - | ADRepExtendedVerificationKey (VerificationKey DRepExtendedKey) - | ACommitteeColdVerificationKey (VerificationKey CommitteeColdKey) + (VerificationKey GenesisDelegateExtendedKey) + | AKesVerificationKey (VerificationKey KesKey) + | AVrfVerificationKey (VerificationKey VrfKey) + | AStakeVerificationKey (VerificationKey StakeKey) + | AStakeExtendedVerificationKey (VerificationKey StakeExtendedKey) + | ADRepVerificationKey (VerificationKey DRepKey) + | ADRepExtendedVerificationKey (VerificationKey DRepExtendedKey) + | ACommitteeColdVerificationKey (VerificationKey CommitteeColdKey) | ACommitteeColdExtendedVerificationKey (VerificationKey CommitteeColdExtendedKey) - | ACommitteeHotVerificationKey (VerificationKey CommitteeHotKey) - | ACommitteeHotExtendedVerificationKey (VerificationKey CommitteeHotExtendedKey) + | ACommitteeHotVerificationKey (VerificationKey CommitteeHotKey) + | ACommitteeHotExtendedVerificationKey (VerificationKey CommitteeHotExtendedKey) deriving (Show) renderSomeAddressVerificationKey :: SomeAddressVerificationKey -> Text renderSomeAddressVerificationKey = \case - AByronVerificationKey vk -> prettyByronVerificationKey vk - APaymentVerificationKey vk -> serialiseToBech32 vk + AByronVerificationKey vk -> prettyByronVerificationKey vk + APaymentVerificationKey vk -> serialiseToBech32 vk APaymentExtendedVerificationKey vk -> serialiseToBech32 vk - AGenesisUTxOVerificationKey vk -> serialiseToBech32 (castVerificationKey vk :: VerificationKey PaymentKey) + AGenesisUTxOVerificationKey vk -> serialiseToBech32 (castVerificationKey vk :: VerificationKey PaymentKey) AGenesisExtendedVerificationKey vk -> - let genKey = (castVerificationKey vk :: VerificationKey GenesisKey) + let genKey = (castVerificationKey vk :: VerificationKey GenesisKey) payKey = (castVerificationKey genKey :: VerificationKey PaymentKey) - in serialiseToBech32 payKey + in serialiseToBech32 payKey AGenesisDelegateExtendedVerificationKey vk -> -- TODO: We could implement a CastVerificationKeyRole GenesisDelegateKey PaymentKey -- if we want to avoid casting twice. - let genDelegKey = (castVerificationKey vk :: VerificationKey GenesisDelegateKey) + let genDelegKey = (castVerificationKey vk :: VerificationKey GenesisDelegateKey) stakePoolKey = castVerificationKey genDelegKey :: VerificationKey StakePoolKey - in serialiseToBech32 stakePoolKey - AKesVerificationKey vk -> serialiseToBech32 vk - AVrfVerificationKey vk -> serialiseToBech32 vk - AStakeVerificationKey vk -> serialiseToBech32 vk - AStakeExtendedVerificationKey vk -> serialiseToBech32 vk - ADRepVerificationKey vk -> serialiseToBech32 vk - ADRepExtendedVerificationKey vk -> serialiseToBech32 vk - ACommitteeColdVerificationKey vk -> serialiseToBech32 vk + in serialiseToBech32 stakePoolKey + AKesVerificationKey vk -> serialiseToBech32 vk + AVrfVerificationKey vk -> serialiseToBech32 vk + AStakeVerificationKey vk -> serialiseToBech32 vk + AStakeExtendedVerificationKey vk -> serialiseToBech32 vk + ADRepVerificationKey vk -> serialiseToBech32 vk + ADRepExtendedVerificationKey vk -> serialiseToBech32 vk + ACommitteeColdVerificationKey vk -> serialiseToBech32 vk ACommitteeColdExtendedVerificationKey vk -> serialiseToBech32 vk - ACommitteeHotVerificationKey vk -> serialiseToBech32 vk - ACommitteeHotExtendedVerificationKey vk -> serialiseToBech32 vk - + ACommitteeHotVerificationKey vk -> serialiseToBech32 vk + ACommitteeHotExtendedVerificationKey vk -> serialiseToBech32 vk -mapSomeAddressVerificationKey :: () +mapSomeAddressVerificationKey + :: () => (forall keyrole. Key keyrole => VerificationKey keyrole -> a) -> SomeAddressVerificationKey -> a mapSomeAddressVerificationKey f = \case - AByronVerificationKey vk -> f vk - APaymentVerificationKey vk -> f vk - APaymentExtendedVerificationKey vk -> f vk - AGenesisUTxOVerificationKey vk -> f vk - AKesVerificationKey vk -> f vk - AGenesisDelegateExtendedVerificationKey vk -> f vk - AGenesisExtendedVerificationKey vk -> f vk - AVrfVerificationKey vk -> f vk - AStakeVerificationKey vk -> f vk - AStakeExtendedVerificationKey vk -> f vk - ADRepVerificationKey vk -> f vk - ADRepExtendedVerificationKey vk -> f vk - ACommitteeColdVerificationKey vk -> f vk - ACommitteeColdExtendedVerificationKey vk -> f vk - ACommitteeHotVerificationKey vk -> f vk - ACommitteeHotExtendedVerificationKey vk -> f vk + AByronVerificationKey vk -> f vk + APaymentVerificationKey vk -> f vk + APaymentExtendedVerificationKey vk -> f vk + AGenesisUTxOVerificationKey vk -> f vk + AKesVerificationKey vk -> f vk + AGenesisDelegateExtendedVerificationKey vk -> f vk + AGenesisExtendedVerificationKey vk -> f vk + AVrfVerificationKey vk -> f vk + AStakeVerificationKey vk -> f vk + AStakeExtendedVerificationKey vk -> f vk + ADRepVerificationKey vk -> f vk + ADRepExtendedVerificationKey vk -> f vk + ACommitteeColdVerificationKey vk -> f vk + ACommitteeColdExtendedVerificationKey vk -> f vk + ACommitteeHotVerificationKey vk -> f vk + ACommitteeHotExtendedVerificationKey vk -> f vk -- | Internal function to pretty render byron keys -prettyByronVerificationKey :: VerificationKey ByronKey-> Text +prettyByronVerificationKey :: VerificationKey ByronKey -> Text prettyByronVerificationKey (ByronVerificationKey vk) = - sformat ( " public key hash: " % build % - "\npublic key (base64): " % Crypto.fullVerificationKeyF % - "\n public key (hex): " % Crypto.fullVerificationKeyHexF) - (Common.addressHash vk) vk vk + sformat + ( " public key hash: " + % build + % "\npublic key (base64): " + % Crypto.fullVerificationKeyF + % "\n public key (hex): " + % Crypto.fullVerificationKeyHexF + ) + (Common.addressHash vk) + vk + vk deserialiseAnyVerificationKey :: ByteString -> Either InputDecodeError SomeAddressVerificationKey @@ -367,4 +362,3 @@ deserialiseAnyVerificationKeyTextEnvelope bs = , FromSomeType (AsVerificationKey AsGenesisUTxOKey) AGenesisUTxOVerificationKey , FromSomeType (AsVerificationKey AsGenesisExtendedKey) AGenesisExtendedVerificationKey ] - diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index e4bc2964fa..ddd7870e06 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.AllegraEraOnwards - ( AllegraEraOnwards(..) + ( AllegraEraOnwards (..) , allegraEraOnwardsConstraints , allegraEraOnwardsToShelleyBasedEra - , AllegraEraOnwardsConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -29,40 +28,40 @@ import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data AllegraEraOnwards era where - AllegraEraOnwardsAllegra :: AllegraEraOnwards AllegraEra - AllegraEraOnwardsMary :: AllegraEraOnwards MaryEra - AllegraEraOnwardsAlonzo :: AllegraEraOnwards AlonzoEra - AllegraEraOnwardsBabbage :: AllegraEraOnwards BabbageEra - AllegraEraOnwardsConway :: AllegraEraOnwards ConwayEra + AllegraEraOnwardsAllegra :: AllegraEraOnwards AllegraEra + AllegraEraOnwardsMary :: AllegraEraOnwards MaryEra + AllegraEraOnwardsAlonzo :: AllegraEraOnwards AlonzoEra + AllegraEraOnwardsBabbage :: AllegraEraOnwards BabbageEra + AllegraEraOnwardsConway :: AllegraEraOnwards ConwayEra deriving instance Show (AllegraEraOnwards era) + deriving instance Eq (AllegraEraOnwards era) instance Eon AllegraEraOnwards where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> yes AllegraEraOnwardsAllegra - MaryEra -> yes AllegraEraOnwardsMary - AlonzoEra -> yes AllegraEraOnwardsAlonzo - BabbageEra -> yes AllegraEraOnwardsBabbage - ConwayEra -> yes AllegraEraOnwardsConway + ByronEra -> no + ShelleyEra -> no + AllegraEra -> yes AllegraEraOnwardsAllegra + MaryEra -> yes AllegraEraOnwardsMary + AlonzoEra -> yes AllegraEraOnwardsAlonzo + BabbageEra -> yes AllegraEraOnwardsBabbage + ConwayEra -> yes AllegraEraOnwardsConway instance ToCardanoEra AllegraEraOnwards where toCardanoEra = \case AllegraEraOnwardsAllegra -> AllegraEra - AllegraEraOnwardsMary -> MaryEra - AllegraEraOnwardsAlonzo -> AlonzoEra + AllegraEraOnwardsMary -> MaryEra + AllegraEraOnwardsAlonzo -> AlonzoEra AllegraEraOnwardsBabbage -> BabbageEra - AllegraEraOnwardsConway -> ConwayEra + AllegraEraOnwardsConway -> ConwayEra type AllegraEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -81,7 +80,6 @@ type AllegraEraOnwardsConstraints era = , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.AllegraEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -90,21 +88,22 @@ type AllegraEraOnwardsConstraints era = , Typeable era ) -allegraEraOnwardsConstraints :: () +allegraEraOnwardsConstraints + :: () => AllegraEraOnwards era -> (AllegraEraOnwardsConstraints era => a) -> a allegraEraOnwardsConstraints = \case AllegraEraOnwardsAllegra -> id - AllegraEraOnwardsMary -> id - AllegraEraOnwardsAlonzo -> id + AllegraEraOnwardsMary -> id + AllegraEraOnwardsAlonzo -> id AllegraEraOnwardsBabbage -> id - AllegraEraOnwardsConway -> id + AllegraEraOnwardsConway -> id allegraEraOnwardsToShelleyBasedEra :: AllegraEraOnwards era -> ShelleyBasedEra era allegraEraOnwardsToShelleyBasedEra = \case AllegraEraOnwardsAllegra -> ShelleyBasedEraAllegra - AllegraEraOnwardsMary -> ShelleyBasedEraMary - AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo + AllegraEraOnwardsMary -> ShelleyBasedEraMary + AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AllegraEraOnwardsBabbage -> ShelleyBasedEraBabbage - AllegraEraOnwardsConway -> ShelleyBasedEraConway + AllegraEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 6b63d37703..bd67019114 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.AlonzoEraOnwards - ( AlonzoEraOnwards(..) + ( AlonzoEraOnwards (..) , alonzoEraOnwardsConstraints , alonzoEraOnwardsToShelleyBasedEra - , AlonzoEraOnwardsConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -36,36 +35,36 @@ import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data AlonzoEraOnwards era where - AlonzoEraOnwardsAlonzo :: AlonzoEraOnwards AlonzoEra + AlonzoEraOnwardsAlonzo :: AlonzoEraOnwards AlonzoEra AlonzoEraOnwardsBabbage :: AlonzoEraOnwards BabbageEra - AlonzoEraOnwardsConway :: AlonzoEraOnwards ConwayEra + AlonzoEraOnwardsConway :: AlonzoEraOnwards ConwayEra deriving instance Show (AlonzoEraOnwards era) + deriving instance Eq (AlonzoEraOnwards era) instance Eon AlonzoEraOnwards where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> no - MaryEra -> no - AlonzoEra -> yes AlonzoEraOnwardsAlonzo - BabbageEra -> yes AlonzoEraOnwardsBabbage - ConwayEra -> yes AlonzoEraOnwardsConway + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> yes AlonzoEraOnwardsAlonzo + BabbageEra -> yes AlonzoEraOnwardsBabbage + ConwayEra -> yes AlonzoEraOnwardsConway instance ToCardanoEra AlonzoEraOnwards where toCardanoEra = \case - AlonzoEraOnwardsAlonzo -> AlonzoEra + AlonzoEraOnwardsAlonzo -> AlonzoEra AlonzoEraOnwardsBabbage -> BabbageEra - AlonzoEraOnwardsConway -> ConwayEra + AlonzoEraOnwardsConway -> ConwayEra type AlonzoEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -94,7 +93,6 @@ type AlonzoEraOnwardsConstraints era = , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -108,12 +106,12 @@ alonzoEraOnwardsConstraints -> (AlonzoEraOnwardsConstraints era => a) -> a alonzoEraOnwardsConstraints = \case - AlonzoEraOnwardsAlonzo -> id + AlonzoEraOnwardsAlonzo -> id AlonzoEraOnwardsBabbage -> id - AlonzoEraOnwardsConway -> id + AlonzoEraOnwardsConway -> id alonzoEraOnwardsToShelleyBasedEra :: AlonzoEraOnwards era -> ShelleyBasedEra era alonzoEraOnwardsToShelleyBasedEra = \case - AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo + AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AlonzoEraOnwardsBabbage -> ShelleyBasedEraBabbage - AlonzoEraOnwardsConway -> ShelleyBasedEraConway + AlonzoEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index be41a5f30d..b408da0209 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.BabbageEraOnwards - ( BabbageEraOnwards(..) + ( BabbageEraOnwards (..) , babbageEraOnwardsConstraints , babbageEraOnwardsToShelleyBasedEra - , BabbageEraOnwardsConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -34,34 +33,34 @@ import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data BabbageEraOnwards era where BabbageEraOnwardsBabbage :: BabbageEraOnwards BabbageEra - BabbageEraOnwardsConway :: BabbageEraOnwards ConwayEra + BabbageEraOnwardsConway :: BabbageEraOnwards ConwayEra deriving instance Show (BabbageEraOnwards era) + deriving instance Eq (BabbageEraOnwards era) instance Eon BabbageEraOnwards where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> no - MaryEra -> no - AlonzoEra -> no - BabbageEra -> yes BabbageEraOnwardsBabbage - ConwayEra -> yes BabbageEraOnwardsConway + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> no + BabbageEra -> yes BabbageEraOnwardsBabbage + ConwayEra -> yes BabbageEraOnwardsConway instance ToCardanoEra BabbageEraOnwards where toCardanoEra = \case BabbageEraOnwardsBabbage -> BabbageEra - BabbageEraOnwardsConway -> ConwayEra + BabbageEraOnwardsConway -> ConwayEra type BabbageEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -89,7 +88,6 @@ type BabbageEraOnwardsConstraints era = , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxOut (ShelleyLedgerEra era) ~ L.BabbageTxOut (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -98,15 +96,16 @@ type BabbageEraOnwardsConstraints era = , Typeable era ) -babbageEraOnwardsConstraints :: () +babbageEraOnwardsConstraints + :: () => BabbageEraOnwards era -> (BabbageEraOnwardsConstraints era => a) -> a babbageEraOnwardsConstraints = \case BabbageEraOnwardsBabbage -> id - BabbageEraOnwardsConway -> id + BabbageEraOnwardsConway -> id babbageEraOnwardsToShelleyBasedEra :: BabbageEraOnwards era -> ShelleyBasedEra era babbageEraOnwardsToShelleyBasedEra = \case BabbageEraOnwardsBabbage -> ShelleyBasedEraBabbage - BabbageEraOnwardsConway -> ShelleyBasedEraConway + BabbageEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs index e837d1d78f..5606e59d62 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs @@ -8,56 +8,57 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.Api.Eon.ByronToAlonzoEra - ( ByronToAlonzoEra(..) + ( ByronToAlonzoEra (..) , byronToAlonzoEraConstraints - , ByronToAlonzoEraConstraints - ) where - -import Cardano.Api.Eras.Core + ) +where -import Data.Typeable (Typeable) +import Cardano.Api.Eras.Core +import Data.Typeable (Typeable) data ByronToAlonzoEra era where - ByronToAlonzoEraByron :: ByronToAlonzoEra ByronEra + ByronToAlonzoEraByron :: ByronToAlonzoEra ByronEra ByronToAlonzoEraShelley :: ByronToAlonzoEra ShelleyEra ByronToAlonzoEraAllegra :: ByronToAlonzoEra AllegraEra - ByronToAlonzoEraMary :: ByronToAlonzoEra MaryEra - ByronToAlonzoEraAlonzo :: ByronToAlonzoEra AlonzoEra + ByronToAlonzoEraMary :: ByronToAlonzoEra MaryEra + ByronToAlonzoEraAlonzo :: ByronToAlonzoEra AlonzoEra deriving instance Show (ByronToAlonzoEra era) + deriving instance Eq (ByronToAlonzoEra era) instance Eon ByronToAlonzoEra where inEonForEra no yes = \case - ByronEra -> yes ByronToAlonzoEraByron - ShelleyEra -> yes ByronToAlonzoEraShelley - AllegraEra -> yes ByronToAlonzoEraAllegra - MaryEra -> yes ByronToAlonzoEraMary - AlonzoEra -> yes ByronToAlonzoEraAlonzo - BabbageEra -> no - ConwayEra -> no + ByronEra -> yes ByronToAlonzoEraByron + ShelleyEra -> yes ByronToAlonzoEraShelley + AllegraEra -> yes ByronToAlonzoEraAllegra + MaryEra -> yes ByronToAlonzoEraMary + AlonzoEra -> yes ByronToAlonzoEraAlonzo + BabbageEra -> no + ConwayEra -> no instance ToCardanoEra ByronToAlonzoEra where toCardanoEra = \case - ByronToAlonzoEraByron -> ByronEra + ByronToAlonzoEraByron -> ByronEra ByronToAlonzoEraShelley -> ShelleyEra ByronToAlonzoEraAllegra -> AllegraEra - ByronToAlonzoEraMary -> MaryEra - ByronToAlonzoEraAlonzo -> AlonzoEra + ByronToAlonzoEraMary -> MaryEra + ByronToAlonzoEraAlonzo -> AlonzoEra type ByronToAlonzoEraConstraints era = ( IsCardanoEra era , Typeable era ) -byronToAlonzoEraConstraints :: () +byronToAlonzoEraConstraints + :: () => ByronToAlonzoEra era -> (ByronToAlonzoEraConstraints era => a) -> a byronToAlonzoEraConstraints = \case - ByronToAlonzoEraByron -> id - ByronToAlonzoEraShelley -> id - ByronToAlonzoEraAllegra -> id - ByronToAlonzoEraMary -> id - ByronToAlonzoEraAlonzo -> id + ByronToAlonzoEraByron -> id + ByronToAlonzoEraShelley -> id + ByronToAlonzoEraAllegra -> id + ByronToAlonzoEraMary -> id + ByronToAlonzoEraAlonzo -> id diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index a38ef5867c..789bcc2a69 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ConwayEraOnwards - ( ConwayEraOnwards(..) + ( ConwayEraOnwards (..) , conwayEraOnwardsConstraints , conwayEraOnwardsToShelleyBasedEra - , ConwayEraOnwardsConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -35,28 +34,28 @@ import qualified Cardano.Ledger.Conway.TxCert as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ConwayEraOnwards era where ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra deriving instance Show (ConwayEraOnwards era) + deriving instance Eq (ConwayEraOnwards era) instance Eon ConwayEraOnwards where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> no - MaryEra -> no - AlonzoEra -> no - BabbageEra -> no - ConwayEra -> yes ConwayEraOnwardsConway + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> yes ConwayEraOnwardsConway instance ToCardanoEra ConwayEraOnwards where toCardanoEra = \case @@ -92,7 +91,6 @@ type ConwayEraOnwardsConstraints era = , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ConwayTxCert (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -101,7 +99,8 @@ type ConwayEraOnwardsConstraints era = , Typeable era ) -conwayEraOnwardsConstraints :: () +conwayEraOnwardsConstraints + :: () => ConwayEraOnwards era -> (ConwayEraOnwardsConstraints era => a) -> a diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index 9247e1245d..b79a5e36ed 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.MaryEraOnwards - ( MaryEraOnwards(..) + ( MaryEraOnwards (..) , maryEraOnwardsConstraints , maryEraOnwardsToShelleyBasedEra - , MaryEraOnwardsConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -31,38 +30,38 @@ import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data MaryEraOnwards era where - MaryEraOnwardsMary :: MaryEraOnwards MaryEra - MaryEraOnwardsAlonzo :: MaryEraOnwards AlonzoEra + MaryEraOnwardsMary :: MaryEraOnwards MaryEra + MaryEraOnwardsAlonzo :: MaryEraOnwards AlonzoEra MaryEraOnwardsBabbage :: MaryEraOnwards BabbageEra - MaryEraOnwardsConway :: MaryEraOnwards ConwayEra + MaryEraOnwardsConway :: MaryEraOnwards ConwayEra deriving instance Show (MaryEraOnwards era) + deriving instance Eq (MaryEraOnwards era) instance Eon MaryEraOnwards where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> no - MaryEra -> yes MaryEraOnwardsMary - AlonzoEra -> yes MaryEraOnwardsAlonzo - BabbageEra -> yes MaryEraOnwardsBabbage - ConwayEra -> yes MaryEraOnwardsConway + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> yes MaryEraOnwardsMary + AlonzoEra -> yes MaryEraOnwardsAlonzo + BabbageEra -> yes MaryEraOnwardsBabbage + ConwayEra -> yes MaryEraOnwardsConway instance ToCardanoEra MaryEraOnwards where toCardanoEra = \case - MaryEraOnwardsMary -> MaryEra - MaryEraOnwardsAlonzo -> AlonzoEra + MaryEraOnwardsMary -> MaryEra + MaryEraOnwardsAlonzo -> AlonzoEra MaryEraOnwardsBabbage -> BabbageEra - MaryEraOnwardsConway -> ConwayEra + MaryEraOnwardsConway -> ConwayEra type MaryEraOnwardsConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -83,7 +82,6 @@ type MaryEraOnwardsConstraints era = , L.MaryEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -92,19 +90,20 @@ type MaryEraOnwardsConstraints era = , Typeable era ) -maryEraOnwardsConstraints :: () +maryEraOnwardsConstraints + :: () => MaryEraOnwards era -> (MaryEraOnwardsConstraints era => a) -> a maryEraOnwardsConstraints = \case - MaryEraOnwardsMary -> id - MaryEraOnwardsAlonzo -> id + MaryEraOnwardsMary -> id + MaryEraOnwardsAlonzo -> id MaryEraOnwardsBabbage -> id - MaryEraOnwardsConway -> id + MaryEraOnwardsConway -> id maryEraOnwardsToShelleyBasedEra :: MaryEraOnwards era -> ShelleyBasedEra era maryEraOnwardsToShelleyBasedEra = \case - MaryEraOnwardsMary -> ShelleyBasedEraMary - MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo + MaryEraOnwardsMary -> ShelleyBasedEraMary + MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo MaryEraOnwardsBabbage -> ShelleyBasedEraBabbage - MaryEraOnwardsConway -> ShelleyBasedEraConway + MaryEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index c7fe9d96f5..2e7a788e66 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -12,10 +12,10 @@ module Cardano.Api.Eon.ShelleyBasedEra ( -- * Shelley-based eras - ShelleyBasedEra(..) - , IsShelleyBasedEra(..) - , AnyShelleyBasedEra(..) - , InAnyShelleyBasedEra(..) + ShelleyBasedEra (..) + , IsShelleyBasedEra (..) + , AnyShelleyBasedEra (..) + , InAnyShelleyBasedEra (..) , inAnyShelleyBasedEra , inEonForShelleyBasedEra , inEonForShelleyBasedEraMaybe @@ -29,41 +29,46 @@ module Cardano.Api.Eon.ShelleyBasedEra -- ** Mapping to era types from the Shelley ledger library , ShelleyLedgerEra , eraProtVerLow - , ShelleyBasedEraConstraints , shelleyBasedEraConstraints - ) where - -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Orphans () -import Cardano.Api.Pretty (Pretty) + ) +where +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Orphans () +import Cardano.Api.Pretty (Pretty) import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.BaseTypes as L -import Cardano.Ledger.Binary (FromCBOR) +import Cardano.Ledger.Binary (FromCBOR) import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.Rules as L import qualified Cardano.Ledger.UTxO as L +import Control.DeepSeq +import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) +import qualified Data.Text as Text +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus -import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, - StandardBabbage, StandardConway, StandardMary, StandardShelley) +import Ouroboros.Consensus.Shelley.Eras as Consensus + ( StandardAllegra + , StandardAlonzo + , StandardBabbage + , StandardConway + , StandardMary + , StandardShelley + ) import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus - -import Control.DeepSeq -import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) -import qualified Data.Text as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) -import Data.Typeable (Typeable) -import Text.Pretty (Pretty (..)) +import Text.Pretty (Pretty (..)) -- | Determine the value to use for a feature in a given 'ShelleyBasedEra'. -inEonForShelleyBasedEra :: () +inEonForShelleyBasedEra + :: () => Eon eon => a -> (eon era -> a) @@ -72,7 +77,8 @@ inEonForShelleyBasedEra :: () inEonForShelleyBasedEra no yes = inEonForEra no yes . toCardanoEra -inEonForShelleyBasedEraMaybe :: () +inEonForShelleyBasedEraMaybe + :: () => Eon eon => (eon era -> a) -> ShelleyBasedEra era @@ -80,14 +86,16 @@ inEonForShelleyBasedEraMaybe :: () inEonForShelleyBasedEraMaybe yes = inEonForShelleyBasedEra Nothing (Just . yes) -forShelleyBasedEraMaybeEon :: () +forShelleyBasedEraMaybeEon + :: () => Eon eon => ShelleyBasedEra era -> Maybe (eon era) forShelleyBasedEraMaybeEon = inEonForEra Nothing Just . toCardanoEra -forShelleyBasedEraInEon :: () +forShelleyBasedEraInEon + :: () => Eon eon => ShelleyBasedEra era -> a @@ -96,7 +104,8 @@ forShelleyBasedEraInEon :: () forShelleyBasedEraInEon era no yes = inEonForShelleyBasedEra no yes era -forShelleyBasedEraInEonMaybe :: () +forShelleyBasedEraInEonMaybe + :: () => Eon eon => ShelleyBasedEra era -> (eon era -> a) @@ -115,86 +124,86 @@ forShelleyBasedEraInEonMaybe era yes = -- Values of this type witness the fact that the era is Shelley-based. This -- can be used to constrain the era to being a Shelley-based on. It allows -- non-uniform handling making case distinctions on the constructor. --- data ShelleyBasedEra era where - ShelleyBasedEraShelley :: ShelleyBasedEra ShelleyEra - ShelleyBasedEraAllegra :: ShelleyBasedEra AllegraEra - ShelleyBasedEraMary :: ShelleyBasedEra MaryEra - ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra - ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra - ShelleyBasedEraConway :: ShelleyBasedEra ConwayEra + ShelleyBasedEraShelley :: ShelleyBasedEra ShelleyEra + ShelleyBasedEraAllegra :: ShelleyBasedEra AllegraEra + ShelleyBasedEraMary :: ShelleyBasedEra MaryEra + ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra + ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra + ShelleyBasedEraConway :: ShelleyBasedEra ConwayEra instance NFData (ShelleyBasedEra era) where rnf = \case ShelleyBasedEraShelley -> () ShelleyBasedEraAllegra -> () - ShelleyBasedEraMary -> () - ShelleyBasedEraAlonzo -> () + ShelleyBasedEraMary -> () + ShelleyBasedEraAlonzo -> () ShelleyBasedEraBabbage -> () - ShelleyBasedEraConway -> () + ShelleyBasedEraConway -> () + +deriving instance Eq (ShelleyBasedEra era) + +deriving instance Ord (ShelleyBasedEra era) -deriving instance Eq (ShelleyBasedEra era) -deriving instance Ord (ShelleyBasedEra era) deriving instance Show (ShelleyBasedEra era) instance Pretty (ShelleyBasedEra era) where pretty = pretty . toCardanoEra instance ToJSON (ShelleyBasedEra era) where - toJSON = toJSON . toCardanoEra + toJSON = toJSON . toCardanoEra instance TestEquality ShelleyBasedEra where - testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl - testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl - testEquality ShelleyBasedEraMary ShelleyBasedEraMary = Just Refl - testEquality ShelleyBasedEraAlonzo ShelleyBasedEraAlonzo = Just Refl - testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl - testEquality ShelleyBasedEraConway ShelleyBasedEraConway = Just Refl - testEquality _ _ = Nothing + testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl + testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl + testEquality ShelleyBasedEraMary ShelleyBasedEraMary = Just Refl + testEquality ShelleyBasedEraAlonzo ShelleyBasedEraAlonzo = Just Refl + testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl + testEquality ShelleyBasedEraConway ShelleyBasedEraConway = Just Refl + testEquality _ _ = Nothing instance Eon ShelleyBasedEra where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyBasedEraShelley - AllegraEra -> yes ShelleyBasedEraAllegra - MaryEra -> yes ShelleyBasedEraMary - AlonzoEra -> yes ShelleyBasedEraAlonzo - BabbageEra -> yes ShelleyBasedEraBabbage - ConwayEra -> yes ShelleyBasedEraConway + ByronEra -> no + ShelleyEra -> yes ShelleyBasedEraShelley + AllegraEra -> yes ShelleyBasedEraAllegra + MaryEra -> yes ShelleyBasedEraMary + AlonzoEra -> yes ShelleyBasedEraAlonzo + BabbageEra -> yes ShelleyBasedEraBabbage + ConwayEra -> yes ShelleyBasedEraConway instance ToCardanoEra ShelleyBasedEra where toCardanoEra = \case ShelleyBasedEraShelley -> ShelleyEra ShelleyBasedEraAllegra -> AllegraEra - ShelleyBasedEraMary -> MaryEra - ShelleyBasedEraAlonzo -> AlonzoEra + ShelleyBasedEraMary -> MaryEra + ShelleyBasedEraAlonzo -> AlonzoEra ShelleyBasedEraBabbage -> BabbageEra - ShelleyBasedEraConway -> ConwayEra + ShelleyBasedEraConway -> ConwayEra -- | The class of eras that are based on Shelley. This allows uniform handling -- of Shelley-based eras, but also non-uniform by making case distinctions on -- the 'ShelleyBasedEra' constructors. --- class IsCardanoEra era => IsShelleyBasedEra era where - shelleyBasedEra :: ShelleyBasedEra era + shelleyBasedEra :: ShelleyBasedEra era instance IsShelleyBasedEra ShelleyEra where - shelleyBasedEra = ShelleyBasedEraShelley + shelleyBasedEra = ShelleyBasedEraShelley instance IsShelleyBasedEra AllegraEra where - shelleyBasedEra = ShelleyBasedEraAllegra + shelleyBasedEra = ShelleyBasedEraAllegra instance IsShelleyBasedEra MaryEra where - shelleyBasedEra = ShelleyBasedEraMary + shelleyBasedEra = ShelleyBasedEraMary instance IsShelleyBasedEra AlonzoEra where - shelleyBasedEra = ShelleyBasedEraAlonzo + shelleyBasedEra = ShelleyBasedEraAlonzo instance IsShelleyBasedEra BabbageEra where - shelleyBasedEra = ShelleyBasedEraBabbage + shelleyBasedEra = ShelleyBasedEraBabbage instance IsShelleyBasedEra ConwayEra where - shelleyBasedEra = ShelleyBasedEraConway + shelleyBasedEra = ShelleyBasedEraConway type ShelleyBasedEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -220,17 +229,18 @@ type ShelleyBasedEraConstraints era = , Typeable era ) -shelleyBasedEraConstraints :: () +shelleyBasedEraConstraints + :: () => ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a shelleyBasedEraConstraints = \case ShelleyBasedEraShelley -> id ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id + ShelleyBasedEraConway -> id data AnyShelleyBasedEra where AnyShelleyBasedEra @@ -241,56 +251,56 @@ data AnyShelleyBasedEra where deriving instance Show AnyShelleyBasedEra instance Eq AnyShelleyBasedEra where - AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = - case testEquality sbe sbe' of - Nothing -> False - Just Refl -> True -- since no constructors share types + AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = + case testEquality sbe sbe' of + Nothing -> False + Just Refl -> True -- since no constructors share types instance Bounded AnyShelleyBasedEra where - minBound = AnyShelleyBasedEra ShelleyBasedEraShelley - maxBound = AnyShelleyBasedEra ShelleyBasedEraConway + minBound = AnyShelleyBasedEra ShelleyBasedEraShelley + maxBound = AnyShelleyBasedEra ShelleyBasedEraConway instance Enum AnyShelleyBasedEra where - enumFrom e = enumFromTo e maxBound - - fromEnum = \case - AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 - AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 - AnyShelleyBasedEra ShelleyBasedEraMary -> 3 - AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 - AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 - AnyShelleyBasedEra ShelleyBasedEraConway -> 6 - - toEnum = \case - 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley - 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra - 3 -> AnyShelleyBasedEra ShelleyBasedEraMary - 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo - 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage - 6 -> AnyShelleyBasedEra ShelleyBasedEraConway - n -> - error $ - "AnyShelleyBasedEra.toEnum: " <> show n - <> " does not correspond to any known enumerated era." + enumFrom e = enumFromTo e maxBound + + fromEnum = \case + AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 + AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 + AnyShelleyBasedEra ShelleyBasedEraMary -> 3 + AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 + AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 + AnyShelleyBasedEra ShelleyBasedEraConway -> 6 + + toEnum = \case + 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley + 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra + 3 -> AnyShelleyBasedEra ShelleyBasedEraMary + 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo + 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage + 6 -> AnyShelleyBasedEra ShelleyBasedEraConway + n -> + error $ + "AnyShelleyBasedEra.toEnum: " + <> show n + <> " does not correspond to any known enumerated era." instance ToJSON AnyShelleyBasedEra where - toJSON (AnyShelleyBasedEra sbe) = toJSON sbe + toJSON (AnyShelleyBasedEra sbe) = toJSON sbe instance FromJSON AnyShelleyBasedEra where - parseJSON = withText "AnyShelleyBasedEra" - $ \case - "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary - "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway - wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong + parseJSON = withText "AnyShelleyBasedEra" $ + \case + "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley + "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary + "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway + wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong -- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that -- tells us what era it is, but hides the era type. This is useful when the era -- is not statically known, for example when deserialising from a file. --- data InAnyShelleyBasedEra thing where InAnyShelleyBasedEra :: Typeable era @@ -298,7 +308,8 @@ data InAnyShelleyBasedEra thing where -> thing era -> InAnyShelleyBasedEra thing -inAnyShelleyBasedEra :: () +inAnyShelleyBasedEra + :: () => ShelleyBasedEra era -> thing era -> InAnyShelleyBasedEra thing @@ -315,14 +326,13 @@ inAnyShelleyBasedEra sbe a = -- This type mapping connect types from this API with types in the Shelley -- ledger library which allows writing conversion functions in a more generic -- way. --- type family ShelleyLedgerEra era = ledgerera | ledgerera -> era where ShelleyLedgerEra ShelleyEra = Consensus.StandardShelley ShelleyLedgerEra AllegraEra = Consensus.StandardAllegra - ShelleyLedgerEra MaryEra = Consensus.StandardMary - ShelleyLedgerEra AlonzoEra = Consensus.StandardAlonzo + ShelleyLedgerEra MaryEra = Consensus.StandardMary + ShelleyLedgerEra AlonzoEra = Consensus.StandardAlonzo ShelleyLedgerEra BabbageEra = Consensus.StandardBabbage - ShelleyLedgerEra ConwayEra = Consensus.StandardConway + ShelleyLedgerEra ConwayEra = Consensus.StandardConway -- | Lookup the lower major protocol version for the shelley based era. In other words -- this is the major protocol version that the era has started in. @@ -330,12 +340,13 @@ eraProtVerLow :: ShelleyBasedEra era -> L.Version eraProtVerLow = \case ShelleyBasedEraShelley -> L.eraProtVerLow @L.Shelley ShelleyBasedEraAllegra -> L.eraProtVerLow @L.Allegra - ShelleyBasedEraMary -> L.eraProtVerLow @L.Mary - ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.Alonzo + ShelleyBasedEraMary -> L.eraProtVerLow @L.Mary + ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.Alonzo ShelleyBasedEraBabbage -> L.eraProtVerLow @L.Babbage - ShelleyBasedEraConway -> L.eraProtVerLow @L.Conway + ShelleyBasedEraConway -> L.eraProtVerLow @L.Conway -requireShelleyBasedEra :: () +requireShelleyBasedEra + :: () => Applicative m => CardanoEra era -> m (Maybe (ShelleyBasedEra era)) diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs index 43555a6893..83cad1f69a 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyEraOnly - ( ShelleyEraOnly(..) + ( ShelleyEraOnly (..) , shelleyEraOnlyConstraints , shelleyEraOnlyToShelleyBasedEra - , ShelleyEraOnlyConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -31,32 +30,32 @@ import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.TxCert as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ShelleyEraOnly era where - ShelleyEraOnlyShelley :: ShelleyEraOnly ShelleyEra + ShelleyEraOnlyShelley :: ShelleyEraOnly ShelleyEra deriving instance Show (ShelleyEraOnly era) + deriving instance Eq (ShelleyEraOnly era) instance Eon ShelleyEraOnly where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyEraOnlyShelley - AllegraEra -> no - MaryEra -> no - AlonzoEra -> no - BabbageEra -> no - ConwayEra -> no + ByronEra -> no + ShelleyEra -> yes ShelleyEraOnlyShelley + AllegraEra -> no + MaryEra -> no + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> no instance ToCardanoEra ShelleyEraOnly where toCardanoEra = \case - ShelleyEraOnlyShelley -> ShelleyEra + ShelleyEraOnlyShelley -> ShelleyEra type ShelleyEraOnlyConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -82,7 +81,6 @@ type ShelleyEraOnlyConstraints era = , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ShelleyTxCert (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.Coin - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -91,13 +89,14 @@ type ShelleyEraOnlyConstraints era = , Typeable era ) -shelleyEraOnlyConstraints :: () +shelleyEraOnlyConstraints + :: () => ShelleyEraOnly era -> (ShelleyEraOnlyConstraints era => a) -> a shelleyEraOnlyConstraints = \case - ShelleyEraOnlyShelley -> id + ShelleyEraOnlyShelley -> id shelleyEraOnlyToShelleyBasedEra :: ShelleyEraOnly era -> ShelleyBasedEra era shelleyEraOnlyToShelleyBasedEra = \case - ShelleyEraOnlyShelley -> ShelleyBasedEraShelley + ShelleyEraOnlyShelley -> ShelleyBasedEraShelley diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs index f6d7b85259..98fa3861df 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyToAllegraEra - ( ShelleyToAllegraEra(..) + ( ShelleyToAllegraEra (..) , shelleyToAllegraEraConstraints , shelleyToAllegraEraToShelleyBasedEra - , ShelleyToAllegraEraConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -32,34 +31,34 @@ import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.TxCert as L import qualified Cardano.Ledger.UTxO as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ShelleyToAllegraEra era where ShelleyToAllegraEraShelley :: ShelleyToAllegraEra ShelleyEra ShelleyToAllegraEraAllegra :: ShelleyToAllegraEra AllegraEra deriving instance Show (ShelleyToAllegraEra era) + deriving instance Eq (ShelleyToAllegraEra era) instance Eon ShelleyToAllegraEra where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyToAllegraEraShelley - AllegraEra -> yes ShelleyToAllegraEraAllegra - MaryEra -> no - AlonzoEra -> no - BabbageEra -> no - ConwayEra -> no + ByronEra -> no + ShelleyEra -> yes ShelleyToAllegraEraShelley + AllegraEra -> yes ShelleyToAllegraEraAllegra + MaryEra -> no + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> no instance ToCardanoEra ShelleyToAllegraEra where toCardanoEra = \case - ShelleyToAllegraEraShelley -> ShelleyEra - ShelleyToAllegraEraAllegra -> AllegraEra + ShelleyToAllegraEraShelley -> ShelleyEra + ShelleyToAllegraEraAllegra -> AllegraEra type ShelleyToAllegraEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -84,7 +83,6 @@ type ShelleyToAllegraEraConstraints era = , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ShelleyTxCert (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.Coin - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -93,7 +91,8 @@ type ShelleyToAllegraEraConstraints era = , Typeable era ) -shelleyToAllegraEraConstraints :: () +shelleyToAllegraEraConstraints + :: () => ShelleyToAllegraEra era -> (ShelleyToAllegraEraConstraints era => a) -> a diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs index b017c699bb..8f14eb5f86 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToAlonzoEra.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyToAlonzoEra - ( ShelleyToAlonzoEra(..) + ( ShelleyToAlonzoEra (..) , shelleyToAlonzoEraConstraints , shelleyToAlonzoEraToShelleyBasedEra - , ShelleyToAlonzoEraConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -30,13 +29,12 @@ import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.TxCert as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ShelleyToAlonzoEra era where ShelleyToAlonzoEraShelley :: ShelleyToAlonzoEra ShelleyEra ShelleyToAlonzoEraAllegra :: ShelleyToAlonzoEra AllegraEra @@ -44,24 +42,25 @@ data ShelleyToAlonzoEra era where ShelleyToAlonzoEraAlonzo :: ShelleyToAlonzoEra AlonzoEra deriving instance Show (ShelleyToAlonzoEra era) + deriving instance Eq (ShelleyToAlonzoEra era) instance Eon ShelleyToAlonzoEra where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyToAlonzoEraShelley - AllegraEra -> yes ShelleyToAlonzoEraAllegra - MaryEra -> yes ShelleyToAlonzoEraMary - AlonzoEra -> yes ShelleyToAlonzoEraAlonzo - BabbageEra -> no - ConwayEra -> no + ByronEra -> no + ShelleyEra -> yes ShelleyToAlonzoEraShelley + AllegraEra -> yes ShelleyToAlonzoEraAllegra + MaryEra -> yes ShelleyToAlonzoEraMary + AlonzoEra -> yes ShelleyToAlonzoEraAlonzo + BabbageEra -> no + ConwayEra -> no instance ToCardanoEra ShelleyToAlonzoEra where toCardanoEra = \case - ShelleyToAlonzoEraShelley -> ShelleyEra - ShelleyToAlonzoEraAllegra -> AllegraEra - ShelleyToAlonzoEraMary -> MaryEra - ShelleyToAlonzoEraAlonzo -> AlonzoEra + ShelleyToAlonzoEraShelley -> ShelleyEra + ShelleyToAlonzoEraAllegra -> AllegraEra + ShelleyToAlonzoEraMary -> MaryEra + ShelleyToAlonzoEraAlonzo -> AlonzoEra type ShelleyToAlonzoEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -83,7 +82,6 @@ type ShelleyToAlonzoEraConstraints era = , L.ShelleyEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ShelleyTxCert (ShelleyLedgerEra era) - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -92,19 +90,20 @@ type ShelleyToAlonzoEraConstraints era = , Typeable era ) -shelleyToAlonzoEraConstraints :: () +shelleyToAlonzoEraConstraints + :: () => ShelleyToAlonzoEra era -> (ShelleyToAlonzoEraConstraints era => a) -> a shelleyToAlonzoEraConstraints = \case ShelleyToAlonzoEraShelley -> id ShelleyToAlonzoEraAllegra -> id - ShelleyToAlonzoEraMary -> id - ShelleyToAlonzoEraAlonzo -> id + ShelleyToAlonzoEraMary -> id + ShelleyToAlonzoEraAlonzo -> id shelleyToAlonzoEraToShelleyBasedEra :: ShelleyToAlonzoEra era -> ShelleyBasedEra era shelleyToAlonzoEraToShelleyBasedEra = \case ShelleyToAlonzoEraShelley -> ShelleyBasedEraShelley ShelleyToAlonzoEraAllegra -> ShelleyBasedEraAllegra - ShelleyToAlonzoEraMary -> ShelleyBasedEraMary - ShelleyToAlonzoEraAlonzo -> ShelleyBasedEraAlonzo + ShelleyToAlonzoEraMary -> ShelleyBasedEraMary + ShelleyToAlonzoEraAlonzo -> ShelleyBasedEraAlonzo diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index 20cc65eb11..aa4f6ca99a 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyToBabbageEra - ( ShelleyToBabbageEra(..) + ( ShelleyToBabbageEra (..) , shelleyToBabbageEraConstraints , shelleyToBabbageEraToShelleyBasedEra - , ShelleyToBabbageEraConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -30,13 +29,12 @@ import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.TxCert as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ShelleyToBabbageEra era where ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra ShelleyToBabbageEraAllegra :: ShelleyToBabbageEra AllegraEra @@ -45,25 +43,26 @@ data ShelleyToBabbageEra era where ShelleyToBabbageEraBabbage :: ShelleyToBabbageEra BabbageEra deriving instance Show (ShelleyToBabbageEra era) + deriving instance Eq (ShelleyToBabbageEra era) instance Eon ShelleyToBabbageEra where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyToBabbageEraShelley - AllegraEra -> yes ShelleyToBabbageEraAllegra - MaryEra -> yes ShelleyToBabbageEraMary - AlonzoEra -> yes ShelleyToBabbageEraAlonzo - BabbageEra -> yes ShelleyToBabbageEraBabbage - ConwayEra -> no + ByronEra -> no + ShelleyEra -> yes ShelleyToBabbageEraShelley + AllegraEra -> yes ShelleyToBabbageEraAllegra + MaryEra -> yes ShelleyToBabbageEraMary + AlonzoEra -> yes ShelleyToBabbageEraAlonzo + BabbageEra -> yes ShelleyToBabbageEraBabbage + ConwayEra -> no instance ToCardanoEra ShelleyToBabbageEra where toCardanoEra = \case - ShelleyToBabbageEraShelley -> ShelleyEra - ShelleyToBabbageEraAllegra -> AllegraEra - ShelleyToBabbageEraMary -> MaryEra - ShelleyToBabbageEraAlonzo -> AlonzoEra - ShelleyToBabbageEraBabbage -> BabbageEra + ShelleyToBabbageEraShelley -> ShelleyEra + ShelleyToBabbageEraAllegra -> AllegraEra + ShelleyToBabbageEraMary -> MaryEra + ShelleyToBabbageEraAlonzo -> AlonzoEra + ShelleyToBabbageEraBabbage -> BabbageEra type ShelleyToBabbageEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -84,7 +83,6 @@ type ShelleyToBabbageEraConstraints era = , L.ShelleyEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ShelleyTxCert (ShelleyLedgerEra era) - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -93,21 +91,22 @@ type ShelleyToBabbageEraConstraints era = , Typeable era ) -shelleyToBabbageEraConstraints :: () +shelleyToBabbageEraConstraints + :: () => ShelleyToBabbageEra era -> (ShelleyToBabbageEraConstraints era => a) -> a shelleyToBabbageEraConstraints = \case ShelleyToBabbageEraShelley -> id ShelleyToBabbageEraAllegra -> id - ShelleyToBabbageEraMary -> id - ShelleyToBabbageEraAlonzo -> id + ShelleyToBabbageEraMary -> id + ShelleyToBabbageEraAlonzo -> id ShelleyToBabbageEraBabbage -> id shelleyToBabbageEraToShelleyBasedEra :: ShelleyToBabbageEra era -> ShelleyBasedEra era shelleyToBabbageEraToShelleyBasedEra = \case ShelleyToBabbageEraShelley -> ShelleyBasedEraShelley ShelleyToBabbageEraAllegra -> ShelleyBasedEraAllegra - ShelleyToBabbageEraMary -> ShelleyBasedEraMary - ShelleyToBabbageEraAlonzo -> ShelleyBasedEraAlonzo + ShelleyToBabbageEraMary -> ShelleyBasedEraMary + ShelleyToBabbageEraAlonzo -> ShelleyBasedEraAlonzo ShelleyToBabbageEraBabbage -> ShelleyBasedEraBabbage diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs index b48ee997bd..06ab79e707 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToMaryEra.hs @@ -9,19 +9,18 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyToMaryEra - ( ShelleyToMaryEra(..) + ( ShelleyToMaryEra (..) , shelleyToMaryEraConstraints , shelleyToMaryEraToShelleyBasedEra - , ShelleyToMaryEraConstraints - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Query.Types + ) +where -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C @@ -30,36 +29,36 @@ import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.TxCert as L +import Data.Aeson +import Data.Typeable (Typeable) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus -import Data.Aeson -import Data.Typeable (Typeable) - data ShelleyToMaryEra era where ShelleyToMaryEraShelley :: ShelleyToMaryEra ShelleyEra ShelleyToMaryEraAllegra :: ShelleyToMaryEra AllegraEra - ShelleyToMaryEraMary :: ShelleyToMaryEra MaryEra + ShelleyToMaryEraMary :: ShelleyToMaryEra MaryEra deriving instance Show (ShelleyToMaryEra era) + deriving instance Eq (ShelleyToMaryEra era) instance Eon ShelleyToMaryEra where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyToMaryEraShelley - AllegraEra -> yes ShelleyToMaryEraAllegra - MaryEra -> yes ShelleyToMaryEraMary - AlonzoEra -> no - BabbageEra -> no - ConwayEra -> no + ByronEra -> no + ShelleyEra -> yes ShelleyToMaryEraShelley + AllegraEra -> yes ShelleyToMaryEraAllegra + MaryEra -> yes ShelleyToMaryEraMary + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> no instance ToCardanoEra ShelleyToMaryEra where toCardanoEra = \case - ShelleyToMaryEraShelley -> ShelleyEra - ShelleyToMaryEraAllegra -> AllegraEra - ShelleyToMaryEraMary -> MaryEra + ShelleyToMaryEraShelley -> ShelleyEra + ShelleyToMaryEraAllegra -> AllegraEra + ShelleyToMaryEraMary -> MaryEra type ShelleyToMaryEraConstraints era = ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) @@ -82,7 +81,6 @@ type ShelleyToMaryEraConstraints era = , L.ShelleyEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) , L.TxCert (ShelleyLedgerEra era) ~ L.ShelleyTxCert (ShelleyLedgerEra era) - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) , FromCBOR (DebugLedgerState era) , IsCardanoEra era @@ -91,17 +89,18 @@ type ShelleyToMaryEraConstraints era = , Typeable era ) -shelleyToMaryEraConstraints :: () +shelleyToMaryEraConstraints + :: () => ShelleyToMaryEra era -> (ShelleyToMaryEraConstraints era => a) -> a shelleyToMaryEraConstraints = \case ShelleyToMaryEraShelley -> id ShelleyToMaryEraAllegra -> id - ShelleyToMaryEraMary -> id + ShelleyToMaryEraMary -> id shelleyToMaryEraToShelleyBasedEra :: ShelleyToMaryEra era -> ShelleyBasedEra era shelleyToMaryEraToShelleyBasedEra = \case ShelleyToMaryEraShelley -> ShelleyBasedEraShelley ShelleyToMaryEraAllegra -> ShelleyBasedEraAllegra - ShelleyToMaryEraMary -> ShelleyBasedEraMary + ShelleyToMaryEraMary -> ShelleyBasedEraMary diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index b9b8bfabef..4889a904ca 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -1,5 +1,4 @@ -- | Cardano eras, sometimes we have to distinguish them. --- module Cardano.Api.Eras ( -- * Eras ByronEra @@ -11,20 +10,19 @@ module Cardano.Api.Eras , ConwayEra -- * CardanoEra - , CardanoEra(..) - , IsCardanoEra(..) - , AnyCardanoEra(..) + , CardanoEra (..) + , IsCardanoEra (..) + , AnyCardanoEra (..) , anyCardanoEra - , InAnyCardanoEra(..) + , InAnyCardanoEra (..) , inAnyCardanoEra , cardanoEraConstraints , CardanoLedgerEra - , ToCardanoEra(..) + , ToCardanoEra (..) -- * IsEon - , Eon(..) - , EraInEon(..) - + , Eon (..) + , EraInEon (..) , inEonForEraMaybe , forEraInEon , forEraInEonMaybe @@ -34,7 +32,7 @@ module Cardano.Api.Eras , monoidForEraInEonA -- * Data family instances - , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) + , AsType (AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) -- * Era case handling @@ -47,7 +45,8 @@ module Cardano.Api.Eras , caseShelleyToMaryOrAlonzoEraOnwards , caseShelleyToAlonzoOrBabbageEraOnwards , caseShelleyToBabbageOrConwayEraOnwards - ) where + ) +where -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core diff --git a/cardano-api/internal/Cardano/Api/Eras/Case.hs b/cardano-api/internal/Cardano/Api/Eras/Case.hs index d9746af1a3..7c205cbdbf 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Case.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Case.hs @@ -7,145 +7,151 @@ module Cardano.Api.Eras.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra , caseByronToAlonzoOrBabbageEraOnwards - - -- Case on ShelleyBasedEra + -- Case on ShelleyBasedEra , caseShelleyEraOnlyOrAllegraEraOnwards , caseShelleyToAllegraOrMaryEraOnwards , caseShelleyToMaryOrAlonzoEraOnwards , caseShelleyToAlonzoOrBabbageEraOnwards , caseShelleyToBabbageOrConwayEraOnwards - - -- Conversions + -- Conversions , shelleyToAlonzoEraToShelleyToBabbageEra , alonzoEraOnwardsToMaryEraOnwards , babbageEraOnwardsToMaryEraOnwards , babbageEraOnwardsToAlonzoEraOnwards - ) where - -import Cardano.Api.Eon.AllegraEraOnwards -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ByronToAlonzoEra -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyEraOnly -import Cardano.Api.Eon.ShelleyToAllegraEra -import Cardano.Api.Eon.ShelleyToAlonzoEra -import Cardano.Api.Eon.ShelleyToBabbageEra -import Cardano.Api.Eon.ShelleyToMaryEra -import Cardano.Api.Eras.Core + ) +where + +import Cardano.Api.Eon.AllegraEraOnwards +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ByronToAlonzoEra +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyEraOnly +import Cardano.Api.Eon.ShelleyToAllegraEra +import Cardano.Api.Eon.ShelleyToAlonzoEra +import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eon.ShelleyToMaryEra +import Cardano.Api.Eras.Core -- | @caseByronOrShelleyBasedEra f g era@ returns @f@ in Byron and applies @g@ to Shelley-based eras. -caseByronOrShelleyBasedEra :: () +caseByronOrShelleyBasedEra + :: () => a -> (ShelleyBasedEraConstraints era => ShelleyBasedEra era -> a) -> CardanoEra era -> a caseByronOrShelleyBasedEra l r = \case - ByronEra -> l -- We no longer provide the witness because Byron is isolated. - -- This function will be deleted shortly after build-raw --byron-era is - -- deprecated in cardano-cli - + ByronEra -> l -- We no longer provide the witness because Byron is isolated. + -- This function will be deleted shortly after build-raw --byron-era is + -- deprecated in cardano-cli ShelleyEra -> r ShelleyBasedEraShelley AllegraEra -> r ShelleyBasedEraAllegra - MaryEra -> r ShelleyBasedEraMary - AlonzoEra -> r ShelleyBasedEraAlonzo + MaryEra -> r ShelleyBasedEraMary + AlonzoEra -> r ShelleyBasedEraAlonzo BabbageEra -> r ShelleyBasedEraBabbage - ConwayEra -> r ShelleyBasedEraConway + ConwayEra -> r ShelleyBasedEraConway -- | @caseByronToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to byron, shelley, allegra, mary, and alonzo; -- and @g@ to babbage and later eras. -caseByronToAlonzoOrBabbageEraOnwards :: () +caseByronToAlonzoOrBabbageEraOnwards + :: () => (ByronToAlonzoEraConstraints era => ByronToAlonzoEra era -> a) -> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a) -> CardanoEra era -> a caseByronToAlonzoOrBabbageEraOnwards l r = \case - ByronEra -> l ByronToAlonzoEraByron + ByronEra -> l ByronToAlonzoEraByron ShelleyEra -> l ByronToAlonzoEraShelley AllegraEra -> l ByronToAlonzoEraAllegra - MaryEra -> l ByronToAlonzoEraMary - AlonzoEra -> l ByronToAlonzoEraAlonzo + MaryEra -> l ByronToAlonzoEraMary + AlonzoEra -> l ByronToAlonzoEraAlonzo BabbageEra -> r BabbageEraOnwardsBabbage - ConwayEra -> r BabbageEraOnwardsConway + ConwayEra -> r BabbageEraOnwardsConway -- | @caseShelleyEraOnlyOrAllegraEraOnwards f g era@ applies @f@ to shelley; -- and applies @g@ to allegra and later eras. -caseShelleyEraOnlyOrAllegraEraOnwards :: () +caseShelleyEraOnlyOrAllegraEraOnwards + :: () => (ShelleyEraOnlyConstraints era => ShelleyEraOnly era -> a) -> (AllegraEraOnwardsConstraints era => AllegraEraOnwards era -> a) -> ShelleyBasedEra era -> a caseShelleyEraOnlyOrAllegraEraOnwards l r = \case - ShelleyBasedEraShelley -> l ShelleyEraOnlyShelley - ShelleyBasedEraAllegra -> r AllegraEraOnwardsAllegra - ShelleyBasedEraMary -> r AllegraEraOnwardsMary - ShelleyBasedEraAlonzo -> r AllegraEraOnwardsAlonzo - ShelleyBasedEraBabbage -> r AllegraEraOnwardsBabbage - ShelleyBasedEraConway -> r AllegraEraOnwardsConway + ShelleyBasedEraShelley -> l ShelleyEraOnlyShelley + ShelleyBasedEraAllegra -> r AllegraEraOnwardsAllegra + ShelleyBasedEraMary -> r AllegraEraOnwardsMary + ShelleyBasedEraAlonzo -> r AllegraEraOnwardsAlonzo + ShelleyBasedEraBabbage -> r AllegraEraOnwardsBabbage + ShelleyBasedEraConway -> r AllegraEraOnwardsConway -- | @caseShelleyToAllegraOrMaryEraOnwards f g era@ applies @f@ to shelley and allegra; -- and applies @g@ to mary and later eras. -caseShelleyToAllegraOrMaryEraOnwards :: () +caseShelleyToAllegraOrMaryEraOnwards + :: () => (ShelleyToAllegraEraConstraints era => ShelleyToAllegraEra era -> a) -> (MaryEraOnwardsConstraints era => MaryEraOnwards era -> a) -> ShelleyBasedEra era -> a caseShelleyToAllegraOrMaryEraOnwards l r = \case - ShelleyBasedEraShelley -> l ShelleyToAllegraEraShelley - ShelleyBasedEraAllegra -> l ShelleyToAllegraEraAllegra - ShelleyBasedEraMary -> r MaryEraOnwardsMary - ShelleyBasedEraAlonzo -> r MaryEraOnwardsAlonzo - ShelleyBasedEraBabbage -> r MaryEraOnwardsBabbage - ShelleyBasedEraConway -> r MaryEraOnwardsConway + ShelleyBasedEraShelley -> l ShelleyToAllegraEraShelley + ShelleyBasedEraAllegra -> l ShelleyToAllegraEraAllegra + ShelleyBasedEraMary -> r MaryEraOnwardsMary + ShelleyBasedEraAlonzo -> r MaryEraOnwardsAlonzo + ShelleyBasedEraBabbage -> r MaryEraOnwardsBabbage + ShelleyBasedEraConway -> r MaryEraOnwardsConway -- | @caseShelleyToMaryOrAlonzoEraOnwards f g era@ applies @f@ to shelley, allegra, and mary; -- and applies @g@ to alonzo and later eras. -caseShelleyToMaryOrAlonzoEraOnwards :: () +caseShelleyToMaryOrAlonzoEraOnwards + :: () => (ShelleyToMaryEraConstraints era => ShelleyToMaryEra era -> a) -> (AlonzoEraOnwardsConstraints era => AlonzoEraOnwards era -> a) -> ShelleyBasedEra era -> a caseShelleyToMaryOrAlonzoEraOnwards l r = \case - ShelleyBasedEraShelley -> l ShelleyToMaryEraShelley - ShelleyBasedEraAllegra -> l ShelleyToMaryEraAllegra - ShelleyBasedEraMary -> l ShelleyToMaryEraMary - ShelleyBasedEraAlonzo -> r AlonzoEraOnwardsAlonzo - ShelleyBasedEraBabbage -> r AlonzoEraOnwardsBabbage - ShelleyBasedEraConway -> r AlonzoEraOnwardsConway + ShelleyBasedEraShelley -> l ShelleyToMaryEraShelley + ShelleyBasedEraAllegra -> l ShelleyToMaryEraAllegra + ShelleyBasedEraMary -> l ShelleyToMaryEraMary + ShelleyBasedEraAlonzo -> r AlonzoEraOnwardsAlonzo + ShelleyBasedEraBabbage -> r AlonzoEraOnwardsBabbage + ShelleyBasedEraConway -> r AlonzoEraOnwardsConway -- | @caseShelleyToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to shelley, allegra, mary, and alonzo; -- and applies @g@ to babbage and later eras. -caseShelleyToAlonzoOrBabbageEraOnwards :: () +caseShelleyToAlonzoOrBabbageEraOnwards + :: () => (ShelleyToAlonzoEraConstraints era => ShelleyToAlonzoEra era -> a) - -> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a) + -> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a) -> ShelleyBasedEra era -> a caseShelleyToAlonzoOrBabbageEraOnwards l r = \case ShelleyBasedEraShelley -> l ShelleyToAlonzoEraShelley ShelleyBasedEraAllegra -> l ShelleyToAlonzoEraAllegra - ShelleyBasedEraMary -> l ShelleyToAlonzoEraMary - ShelleyBasedEraAlonzo -> l ShelleyToAlonzoEraAlonzo + ShelleyBasedEraMary -> l ShelleyToAlonzoEraMary + ShelleyBasedEraAlonzo -> l ShelleyToAlonzoEraAlonzo ShelleyBasedEraBabbage -> r BabbageEraOnwardsBabbage - ShelleyBasedEraConway -> r BabbageEraOnwardsConway + ShelleyBasedEraConway -> r BabbageEraOnwardsConway -- | @caseShelleyToBabbageOrConwayEraOnwards f g era@ applies @f@ to eras before conway; -- and applies @g@ to conway and later eras. -caseShelleyToBabbageOrConwayEraOnwards :: () - => (ShelleyToBabbageEraConstraints era => ShelleyToBabbageEra era -> a) - -> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a) +caseShelleyToBabbageOrConwayEraOnwards + :: () + => (ShelleyToBabbageEraConstraints era => ShelleyToBabbageEra era -> a) + -> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a) -> ShelleyBasedEra era -> a caseShelleyToBabbageOrConwayEraOnwards l r = \case ShelleyBasedEraShelley -> l ShelleyToBabbageEraShelley ShelleyBasedEraAllegra -> l ShelleyToBabbageEraAllegra - ShelleyBasedEraMary -> l ShelleyToBabbageEraMary - ShelleyBasedEraAlonzo -> l ShelleyToBabbageEraAlonzo + ShelleyBasedEraMary -> l ShelleyToBabbageEraMary + ShelleyBasedEraAlonzo -> l ShelleyToBabbageEraAlonzo ShelleyBasedEraBabbage -> l ShelleyToBabbageEraBabbage - ShelleyBasedEraConway -> r ConwayEraOnwardsConway + ShelleyBasedEraConway -> r ConwayEraOnwardsConway -shelleyToAlonzoEraToShelleyToBabbageEra :: () +shelleyToAlonzoEraToShelleyToBabbageEra + :: () => ShelleyToAlonzoEra era -> ShelleyToBabbageEra era shelleyToAlonzoEraToShelleyToBabbageEra = \case @@ -154,24 +160,27 @@ shelleyToAlonzoEraToShelleyToBabbageEra = \case ShelleyToAlonzoEraMary -> ShelleyToBabbageEraMary ShelleyToAlonzoEraAlonzo -> ShelleyToBabbageEraAlonzo -alonzoEraOnwardsToMaryEraOnwards :: () +alonzoEraOnwardsToMaryEraOnwards + :: () => AlonzoEraOnwards era -> MaryEraOnwards era alonzoEraOnwardsToMaryEraOnwards = \case - AlonzoEraOnwardsAlonzo -> MaryEraOnwardsAlonzo + AlonzoEraOnwardsAlonzo -> MaryEraOnwardsAlonzo AlonzoEraOnwardsBabbage -> MaryEraOnwardsBabbage - AlonzoEraOnwardsConway -> MaryEraOnwardsConway + AlonzoEraOnwardsConway -> MaryEraOnwardsConway -babbageEraOnwardsToMaryEraOnwards :: () +babbageEraOnwardsToMaryEraOnwards + :: () => BabbageEraOnwards era -> MaryEraOnwards era babbageEraOnwardsToMaryEraOnwards = \case BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage - BabbageEraOnwardsConway -> MaryEraOnwardsConway + BabbageEraOnwardsConway -> MaryEraOnwardsConway -babbageEraOnwardsToAlonzoEraOnwards :: () +babbageEraOnwardsToAlonzoEraOnwards + :: () => BabbageEraOnwards era -> AlonzoEraOnwards era babbageEraOnwardsToAlonzoEraOnwards = \case - BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage - BabbageEraOnwardsConway -> AlonzoEraOnwardsConway + BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage + BabbageEraOnwardsConway -> AlonzoEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index 908846d6e5..9c21545a3d 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -10,7 +10,6 @@ {-# LANGUAGE TypeFamilyDependencies #-} -- | Cardano eras, sometimes we have to distinguish them. --- module Cardano.Api.Eras.Core ( -- * Eras ByronEra @@ -22,18 +21,18 @@ module Cardano.Api.Eras.Core , ConwayEra -- * CardanoEra - , CardanoEra(..) - , IsCardanoEra(..) - , AnyCardanoEra(..) + , CardanoEra (..) + , IsCardanoEra (..) + , AnyCardanoEra (..) , anyCardanoEra - , InAnyCardanoEra(..) + , InAnyCardanoEra (..) , inAnyCardanoEra , CardanoLedgerEra - , ToCardanoEra(..) + , ToCardanoEra (..) -- * IsEon - , Eon(..) - , EraInEon(..) + , Eon (..) + , EraInEon (..) , inEonForEraMaybe , forEraInEon , forEraInEonMaybe @@ -43,24 +42,22 @@ module Cardano.Api.Eras.Core , monoidForEraInEonA -- * Data family instances - , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) - + , AsType (AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) , CardanoEraConstraints , cardanoEraConstraints - ) where - -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty + ) +where +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty import qualified Cardano.Ledger.Api as L - -import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) -import Data.Kind -import Data.Maybe (isJust) -import Data.String (IsString) +import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) +import Data.Kind +import Data.Maybe (isJust) +import Data.String (IsString) import qualified Data.Text as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) -import Data.Typeable (Typeable, showsTypeRep, typeOf) +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Typeable (Typeable, showsTypeRep, typeOf) -- ---------------------------------------------------------------------------- -- Eras @@ -87,32 +84,32 @@ data BabbageEra data ConwayEra instance HasTypeProxy ByronEra where - data AsType ByronEra = AsByronEra - proxyToAsType _ = AsByronEra + data AsType ByronEra = AsByronEra + proxyToAsType _ = AsByronEra instance HasTypeProxy ShelleyEra where - data AsType ShelleyEra = AsShelleyEra - proxyToAsType _ = AsShelleyEra + data AsType ShelleyEra = AsShelleyEra + proxyToAsType _ = AsShelleyEra instance HasTypeProxy AllegraEra where - data AsType AllegraEra = AsAllegraEra - proxyToAsType _ = AsAllegraEra + data AsType AllegraEra = AsAllegraEra + proxyToAsType _ = AsAllegraEra instance HasTypeProxy MaryEra where - data AsType MaryEra = AsMaryEra - proxyToAsType _ = AsMaryEra + data AsType MaryEra = AsMaryEra + proxyToAsType _ = AsMaryEra instance HasTypeProxy AlonzoEra where - data AsType AlonzoEra = AsAlonzoEra - proxyToAsType _ = AsAlonzoEra + data AsType AlonzoEra = AsAlonzoEra + proxyToAsType _ = AsAlonzoEra instance HasTypeProxy BabbageEra where - data AsType BabbageEra = AsBabbageEra - proxyToAsType _ = AsBabbageEra + data AsType BabbageEra = AsBabbageEra + proxyToAsType _ = AsBabbageEra instance HasTypeProxy ConwayEra where - data AsType ConwayEra = AsConwayEra - proxyToAsType _ = AsConwayEra + data AsType ConwayEra = AsConwayEra + proxyToAsType _ = AsConwayEra -- ---------------------------------------------------------------------------- -- Eon @@ -124,52 +121,76 @@ class Eon (eon :: Type -> Type) where -- | Determine the value to use in an eon (a span of multiple eras). -- Note that the negative case is the first argument, and the positive case is the second as per -- the 'either' function convention. - inEonForEra :: () - => a -- ^ Value to use if the eon does not include the era - -> (eon era -> a) -- ^ Function to get the value to use if the eon includes the era - -> CardanoEra era -- ^ Era to check - -> a -- ^ The value to use + inEonForEra + :: () + => a + -- ^ Value to use if the eon does not include the era + -> (eon era -> a) + -- ^ Function to get the value to use if the eon includes the era + -> CardanoEra era + -- ^ Era to check + -> a + -- ^ The value to use -inEonForEraMaybe :: () +inEonForEraMaybe + :: () => Eon eon - => (eon era -> a) -- ^ Function to get the value to use if the eon includes the era - -> CardanoEra era -- ^ Era to check - -> Maybe a -- ^ The value to use + => (eon era -> a) + -- ^ Function to get the value to use if the eon includes the era + -> CardanoEra era + -- ^ Era to check + -> Maybe a + -- ^ The value to use inEonForEraMaybe yes = inEonForEra Nothing (Just . yes) -forEraInEon :: () +forEraInEon + :: () => Eon eon - => CardanoEra era -- ^ Era to check - -> a -- ^ Value to use if the eon does not include the era - -> (eon era -> a) -- ^ Function to get the value to use if the eon includes the era - -> a -- ^ The value to use + => CardanoEra era + -- ^ Era to check + -> a + -- ^ Value to use if the eon does not include the era + -> (eon era -> a) + -- ^ Function to get the value to use if the eon includes the era + -> a + -- ^ The value to use forEraInEon era no yes = inEonForEra no yes era -forEraInEonMaybe :: () +forEraInEonMaybe + :: () => Eon eon - => CardanoEra era -- ^ Era to check - -> (eon era -> a) -- ^ Function to get the value to use if the eon includes the era - -> Maybe a -- ^ The value to use + => CardanoEra era + -- ^ Era to check + -> (eon era -> a) + -- ^ Function to get the value to use if the eon includes the era + -> Maybe a + -- ^ The value to use forEraInEonMaybe era yes = forEraInEon era Nothing (Just . yes) -forEraMaybeEon :: () +forEraMaybeEon + :: () => Eon eon - => CardanoEra era -- ^ Era to check - -> Maybe (eon era) -- ^ The eon if supported in the era + => CardanoEra era + -- ^ Era to check + -> Maybe (eon era) + -- ^ The eon if supported in the era forEraMaybeEon = inEonForEra Nothing Just -maybeEon :: () +maybeEon + :: () => Eon eon => IsCardanoEra era - => Maybe (eon era) -- ^ The eon if supported in the era + => Maybe (eon era) + -- ^ The eon if supported in the era maybeEon = inEonForEra Nothing Just cardanoEra -monoidForEraInEon :: () +monoidForEraInEon + :: () => Eon eon => Monoid a => CardanoEra era @@ -177,7 +198,8 @@ monoidForEraInEon :: () -> a monoidForEraInEon sbe = forEraInEon sbe mempty -monoidForEraInEonA :: () +monoidForEraInEonA + :: () => Eon eon => Applicative f => Monoid a @@ -211,7 +233,8 @@ instance TestEquality eon => Eq (EraInEon eon) where -- ToCardanoEra class ToCardanoEra (eon :: Type -> Type) where - toCardanoEra :: () + toCardanoEra + :: () => eon era -> CardanoEra era @@ -228,20 +251,22 @@ class ToCardanoEra (eon :: Type -> Type) where -- -- In combination this can often enable code that handles all eras, and does -- so uniformly where possible, and non-uniformly where necessary. --- data CardanoEra era where - ByronEra :: CardanoEra ByronEra - ShelleyEra :: CardanoEra ShelleyEra - AllegraEra :: CardanoEra AllegraEra - MaryEra :: CardanoEra MaryEra - AlonzoEra :: CardanoEra AlonzoEra - BabbageEra :: CardanoEra BabbageEra - ConwayEra :: CardanoEra ConwayEra - -- when you add era here, change `instance Bounded AnyCardanoEra` - -deriving instance Eq (CardanoEra era) -deriving instance Ord (CardanoEra era) -deriving instance Show (CardanoEra era) + ByronEra :: CardanoEra ByronEra + ShelleyEra :: CardanoEra ShelleyEra + AllegraEra :: CardanoEra AllegraEra + MaryEra :: CardanoEra MaryEra + AlonzoEra :: CardanoEra AlonzoEra + BabbageEra :: CardanoEra BabbageEra + ConwayEra :: CardanoEra ConwayEra + +-- when you add era here, change `instance Bounded AnyCardanoEra` + +deriving instance Eq (CardanoEra era) + +deriving instance Ord (CardanoEra era) + +deriving instance Show (CardanoEra era) instance Pretty (CardanoEra era) where pretty = cardanoEraToStringLike @@ -250,14 +275,14 @@ instance ToJSON (CardanoEra era) where toJSON = cardanoEraToStringLike instance TestEquality CardanoEra where - testEquality ByronEra ByronEra = Just Refl - testEquality ShelleyEra ShelleyEra = Just Refl - testEquality AllegraEra AllegraEra = Just Refl - testEquality MaryEra MaryEra = Just Refl - testEquality AlonzoEra AlonzoEra = Just Refl - testEquality BabbageEra BabbageEra = Just Refl - testEquality ConwayEra ConwayEra = Just Refl - testEquality _ _ = Nothing + testEquality ByronEra ByronEra = Just Refl + testEquality ShelleyEra ShelleyEra = Just Refl + testEquality AllegraEra AllegraEra = Just Refl + testEquality MaryEra MaryEra = Just Refl + testEquality AlonzoEra AlonzoEra = Just Refl + testEquality BabbageEra BabbageEra = Just Refl + testEquality ConwayEra ConwayEra = Just Refl + testEquality _ _ = Nothing instance Eon CardanoEra where inEonForEra _ yes = yes @@ -268,48 +293,48 @@ instance ToCardanoEra CardanoEra where -- | The class of Cardano eras. This allows uniform handling of all Cardano -- eras, but also non-uniform by making case distinctions on the 'CardanoEra' -- constructors. --- class HasTypeProxy era => IsCardanoEra era where - cardanoEra :: CardanoEra era + cardanoEra :: CardanoEra era instance IsCardanoEra ByronEra where - cardanoEra = ByronEra + cardanoEra = ByronEra instance IsCardanoEra ShelleyEra where - cardanoEra = ShelleyEra + cardanoEra = ShelleyEra instance IsCardanoEra AllegraEra where - cardanoEra = AllegraEra + cardanoEra = AllegraEra instance IsCardanoEra MaryEra where - cardanoEra = MaryEra + cardanoEra = MaryEra instance IsCardanoEra AlonzoEra where - cardanoEra = AlonzoEra + cardanoEra = AlonzoEra instance IsCardanoEra BabbageEra where - cardanoEra = BabbageEra + cardanoEra = BabbageEra instance IsCardanoEra ConwayEra where - cardanoEra = ConwayEra + cardanoEra = ConwayEra type CardanoEraConstraints era = ( Typeable era , IsCardanoEra era ) -cardanoEraConstraints :: () +cardanoEraConstraints + :: () => CardanoEra era -> (CardanoEraConstraints era => a) -> a cardanoEraConstraints = \case - ByronEra -> id + ByronEra -> id ShelleyEra -> id AllegraEra -> id - MaryEra -> id - AlonzoEra -> id + MaryEra -> id + AlonzoEra -> id BabbageEra -> id - ConwayEra -> id + ConwayEra -> id data AnyCardanoEra where AnyCardanoEra @@ -324,61 +349,62 @@ instance Pretty AnyCardanoEra where -- | Assumes that 'CardanoEra era' are singletons instance Eq AnyCardanoEra where - AnyCardanoEra era == AnyCardanoEra era' = - isJust $ testEquality era era' + AnyCardanoEra era == AnyCardanoEra era' = + isJust $ testEquality era era' instance Bounded AnyCardanoEra where - minBound = AnyCardanoEra ByronEra - maxBound = AnyCardanoEra ConwayEra + minBound = AnyCardanoEra ByronEra + maxBound = AnyCardanoEra ConwayEra instance Enum AnyCardanoEra where - - -- [e..] = [e..maxBound] - enumFrom e = enumFromTo e maxBound - - fromEnum = \case - AnyCardanoEra ByronEra -> 0 - AnyCardanoEra ShelleyEra -> 1 - AnyCardanoEra AllegraEra -> 2 - AnyCardanoEra MaryEra -> 3 - AnyCardanoEra AlonzoEra -> 4 - AnyCardanoEra BabbageEra -> 5 - AnyCardanoEra ConwayEra -> 6 - - toEnum = \case - 0 -> AnyCardanoEra ByronEra - 1 -> AnyCardanoEra ShelleyEra - 2 -> AnyCardanoEra AllegraEra - 3 -> AnyCardanoEra MaryEra - 4 -> AnyCardanoEra AlonzoEra - 5 -> AnyCardanoEra BabbageEra - 6 -> AnyCardanoEra ConwayEra - n -> - error $ - "AnyCardanoEra.toEnum: " <> show n - <> " does not correspond to any known enumerated era." + -- [e..] = [e..maxBound] + enumFrom e = enumFromTo e maxBound + + fromEnum = \case + AnyCardanoEra ByronEra -> 0 + AnyCardanoEra ShelleyEra -> 1 + AnyCardanoEra AllegraEra -> 2 + AnyCardanoEra MaryEra -> 3 + AnyCardanoEra AlonzoEra -> 4 + AnyCardanoEra BabbageEra -> 5 + AnyCardanoEra ConwayEra -> 6 + + toEnum = \case + 0 -> AnyCardanoEra ByronEra + 1 -> AnyCardanoEra ShelleyEra + 2 -> AnyCardanoEra AllegraEra + 3 -> AnyCardanoEra MaryEra + 4 -> AnyCardanoEra AlonzoEra + 5 -> AnyCardanoEra BabbageEra + 6 -> AnyCardanoEra ConwayEra + n -> + error $ + "AnyCardanoEra.toEnum: " + <> show n + <> " does not correspond to any known enumerated era." instance ToJSON AnyCardanoEra where - toJSON (AnyCardanoEra era) = toJSON era + toJSON (AnyCardanoEra era) = toJSON era instance FromJSON AnyCardanoEra where - parseJSON = withText "AnyCardanoEra" - $ (\case - Right era -> pure era - Left era -> fail $ "Failed to parse unknown era: " <> Text.unpack era - ) . anyCardanoEraFromStringLike - + parseJSON = + withText "AnyCardanoEra" $ + ( \case + Right era -> pure era + Left era -> fail $ "Failed to parse unknown era: " <> Text.unpack era + ) + . anyCardanoEraFromStringLike cardanoEraToStringLike :: IsString a => CardanoEra era -> a {-# INLINE cardanoEraToStringLike #-} cardanoEraToStringLike = \case - ByronEra -> "Byron" + ByronEra -> "Byron" ShelleyEra -> "Shelley" AllegraEra -> "Allegra" - MaryEra -> "Mary" - AlonzoEra -> "Alonzo" + MaryEra -> "Mary" + AlonzoEra -> "Alonzo" BabbageEra -> "Babbage" - ConwayEra -> "Conway" + ConwayEra -> "Conway" anyCardanoEraFromStringLike :: (IsString a, Eq a) => a -> Either a AnyCardanoEra {-# INLINE anyCardanoEraFromStringLike #-} @@ -394,21 +420,19 @@ anyCardanoEraFromStringLike = \case -- | Like the 'AnyCardanoEra' constructor but does not demand a 'IsCardanoEra' -- class constraint. --- anyCardanoEra :: CardanoEra era -> AnyCardanoEra anyCardanoEra = \case - ByronEra -> AnyCardanoEra ByronEra - ShelleyEra -> AnyCardanoEra ShelleyEra - AllegraEra -> AnyCardanoEra AllegraEra - MaryEra -> AnyCardanoEra MaryEra - AlonzoEra -> AnyCardanoEra AlonzoEra - BabbageEra -> AnyCardanoEra BabbageEra - ConwayEra -> AnyCardanoEra ConwayEra + ByronEra -> AnyCardanoEra ByronEra + ShelleyEra -> AnyCardanoEra ShelleyEra + AllegraEra -> AnyCardanoEra AllegraEra + MaryEra -> AnyCardanoEra MaryEra + AlonzoEra -> AnyCardanoEra AlonzoEra + BabbageEra -> AnyCardanoEra BabbageEra + ConwayEra -> AnyCardanoEra ConwayEra -- | This pairs up some era-dependent type with a 'CardanoEra' value that tells -- us what era it is, but hides the era type. This is useful when the era is -- not statically known, for example when deserialising from a file. --- data InAnyCardanoEra thing where InAnyCardanoEra :: Typeable era @@ -416,7 +440,8 @@ data InAnyCardanoEra thing where -> thing era -> InAnyCardanoEra thing -inAnyCardanoEra :: () +inAnyCardanoEra + :: () => CardanoEra era -> thing era -> InAnyCardanoEra thing @@ -433,12 +458,11 @@ inAnyCardanoEra era a = -- This type mapping connect types from this API with types in the -- ledger library which allows writing conversion functions in a more generic -- way. - type family CardanoLedgerEra era = ledgerera | ledgerera -> era where - CardanoLedgerEra ByronEra = L.ByronEra L.StandardCrypto + CardanoLedgerEra ByronEra = L.ByronEra L.StandardCrypto CardanoLedgerEra ShelleyEra = L.ShelleyEra L.StandardCrypto CardanoLedgerEra AllegraEra = L.AllegraEra L.StandardCrypto - CardanoLedgerEra MaryEra = L.MaryEra L.StandardCrypto - CardanoLedgerEra AlonzoEra = L.AlonzoEra L.StandardCrypto + CardanoLedgerEra MaryEra = L.MaryEra L.StandardCrypto + CardanoLedgerEra AlonzoEra = L.AlonzoEra L.StandardCrypto CardanoLedgerEra BabbageEra = L.BabbageEra L.StandardCrypto - CardanoLedgerEra ConwayEra = L.ConwayEra L.StandardCrypto + CardanoLedgerEra ConwayEra = L.ConwayEra L.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/Error.hs b/cardano-api/internal/Cardano/Api/Error.hs index 69bc22c5a5..c1aa28c110 100644 --- a/cardano-api/internal/Cardano/Api/Error.hs +++ b/cardano-api/internal/Cardano/Api/Error.hs @@ -5,25 +5,24 @@ {-# LANGUAGE OverloadedStrings #-} -- | Class of errors used in the Api. --- module Cardano.Api.Error - ( Error(..) + ( Error (..) , throwErrorAsException - , ErrorAsException(..) - , FileError(..) + , ErrorAsException (..) + , FileError (..) , fileIOExceptT , displayError - ) where - -import Cardano.Api.Pretty - -import Control.Exception (Exception (..), IOException, throwIO) -import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Except.Extra (handleIOExceptT) -import System.Directory (doesFileExist) -import System.IO (Handle) + ) +where + +import Cardano.Api.Pretty +import Control.Exception (Exception (..), IOException, throwIO) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except.Extra (handleIOExceptT) +import System.Directory (doesFileExist) +import System.IO (Handle) class Error e where prettyError :: e -> Doc ann @@ -33,7 +32,6 @@ instance Error () where -- | The preferred approach is to use 'Except' or 'ExceptT', but you can if -- necessary use IO exceptions. --- throwErrorAsException :: Error e => e -> IO a throwErrorAsException e = throwIO (ErrorAsException e) @@ -55,15 +53,16 @@ instance Exception ErrorAsException where displayError :: Error a => a -> String displayError = docToString . prettyError -data FileError e = FileError FilePath e - | FileErrorTempFile - FilePath - -- ^ Target path - FilePath - -- ^ Temporary path - Handle - | FileDoesNotExistError FilePath - | FileIOError FilePath IOException +data FileError e + = FileError FilePath e + | FileErrorTempFile + FilePath + -- ^ Target path + FilePath + -- ^ Temporary path + Handle + | FileDoesNotExistError FilePath + | FileIOError FilePath IOException deriving (Show, Eq, Functor) instance Error e => Error (FileError e) where @@ -84,12 +83,13 @@ instance Error e => Error (FileError e) where instance Error IOException where prettyError = pretty . show -fileIOExceptT :: MonadIO m - => FilePath - -> (FilePath -> IO s) - -> ExceptT (FileError e) m s +fileIOExceptT + :: MonadIO m + => FilePath + -> (FilePath -> IO s) + -> ExceptT (FileError e) m s fileIOExceptT fp readFile' = do fileExists <- handleIOExceptT (FileIOError fp) $ doesFileExist fp - if fileExists then handleIOExceptT (FileIOError fp) $ readFile' fp - else throwError (FileDoesNotExistError fp) - + if fileExists + then handleIOExceptT (FileIOError fp) $ readFile' fp + else throwError (FileDoesNotExistError fp) diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index ff909c0000..74e193e073 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -2,7 +2,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} - {-# OPTIONS_GHC -Wno-deprecations #-} module Cardano.Api.Feature @@ -10,10 +9,11 @@ module Cardano.Api.Feature , unFeatured , asFeaturedInEra , asFeaturedInShelleyBasedEra - ) where + ) +where -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Core +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Core -- | A value only if the eon includes era data Featured eon era a where @@ -25,6 +25,7 @@ data Featured eon era a where -> Featured eon era a deriving instance (Eq a, Eq (eon era)) => Eq (Featured eon era a) + deriving instance (Show a, Show (eon era)) => Show (Featured eon era a) instance Functor (Featured eon era) where @@ -35,7 +36,8 @@ unFeatured (Featured _ a) = a -- | Attempt to construct a 'FeatureValue' from a value and era. -- If the eon is not supported in the era, then 'NoFeatureValue' is returned. -asFeaturedInEra :: () +asFeaturedInEra + :: () => Eon eon => a -> CardanoEra era @@ -43,7 +45,8 @@ asFeaturedInEra :: () asFeaturedInEra value = inEonForEra Nothing (Just . flip Featured value) -- | Attempt to construct a 'FeatureValue' from a value and a shelley-based-era. -asFeaturedInShelleyBasedEra :: () +asFeaturedInShelleyBasedEra + :: () => Eon eon => a -> ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index c98457db4d..a3f687dc3c 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -9,66 +9,63 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} - {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- | Fee calculation --- -module Cardano.Api.Fees ( - -- * Transaction fees - evaluateTransactionFee, - calculateMinTxFee, - estimateTransactionKeyWitnessCount, +module Cardano.Api.Fees + ( -- * Transaction fees + evaluateTransactionFee + , calculateMinTxFee + , estimateTransactionKeyWitnessCount -- * Script execution units - evaluateTransactionExecutionUnits, - ScriptExecutionError(..), - TransactionValidityError(..), + , evaluateTransactionExecutionUnits + , ScriptExecutionError (..) + , TransactionValidityError (..) -- * Transaction balance - evaluateTransactionBalance, + , evaluateTransactionBalance -- * Automated transaction building - estimateBalancedTxBody, - estimateOrCalculateBalancedTxBody, - makeTransactionBodyAutoBalance, - AutoBalanceError(..), - BalancedTxBody(..), - FeeEstimationMode(..), - RequiredShelleyKeyWitnesses(..), - RequiredByronKeyWitnesses(..), - TotalReferenceScriptsSize(..), - TxBodyErrorAutoBalance(..), - TxFeeEstimationError(..), + , estimateBalancedTxBody + , estimateOrCalculateBalancedTxBody + , makeTransactionBodyAutoBalance + , AutoBalanceError (..) + , BalancedTxBody (..) + , FeeEstimationMode (..) + , RequiredShelleyKeyWitnesses (..) + , RequiredByronKeyWitnesses (..) + , TotalReferenceScriptsSize (..) + , TxBodyErrorAutoBalance (..) + , TxFeeEstimationError (..) -- * Minimum UTxO calculation - calculateMinimumUTxO, + , calculateMinimumUTxO -- * Internal helpers - mapTxScriptWitnesses, - - ResolvablePointers(..), - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core -import Cardano.Api.Error -import Cardano.Api.Feature + , mapTxScriptWitnesses + , ResolvablePointers (..) + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core +import Cardano.Api.Error +import Cardano.Api.Feature import qualified Cardano.Api.Ledger.Lens as A -import Cardano.Api.Pretty -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query -import Cardano.Api.Script -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.Value - +import Cardano.Api.Pretty +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query +import Cardano.Api.Script +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.Value import qualified Cardano.Ledger.Alonzo.Core as Ledger import qualified Cardano.Ledger.Alonzo.Plutus.Context as Plutus import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo @@ -76,29 +73,28 @@ import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.Governance as L import qualified Cardano.Ledger.Core as L -import Cardano.Ledger.Credential as Ledger (Credential) +import Cardano.Ledger.Credential as Ledger (Credential) import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Plutus.Language as Plutus -import qualified Ouroboros.Consensus.HardFork.History as Consensus -import qualified PlutusLedgerApi.V1 as Plutus - -import Control.Monad (forM_) -import Data.Bifunctor (bimap, first, second) -import Data.ByteString.Short (ShortByteString) -import Data.Foldable (toList) -import Data.Function ((&)) +import Control.Monad (forM_) +import Data.Bifunctor (bimap, first, second) +import Data.ByteString.Short (ShortByteString) +import Data.Foldable (toList) +import Data.Function ((&)) import qualified Data.List as List -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, maybeToList) import qualified Data.OSet.Strict as OSet -import Data.Ratio -import Data.Set (Set) +import Data.Ratio +import Data.Set (Set) import qualified Data.Set as Set +import Data.Text (Text) import qualified Data.Text as Text -import Data.Text (Text) -import Lens.Micro ((.~), (^.)) +import Lens.Micro ((.~), (^.)) +import qualified Ouroboros.Consensus.HardFork.History as Consensus +import qualified PlutusLedgerApi.V1 as Plutus {- HLINT ignore "Redundant return" -} @@ -109,14 +105,13 @@ type EvalTxExecutionUnitsLog = [Text] data AutoBalanceError era = AutoBalanceEstimationError (TxFeeEstimationError era) | AutoBalanceCalculationError (TxBodyErrorAutoBalance era) - deriving Show + deriving (Show) instance Error (AutoBalanceError era) where prettyError = \case AutoBalanceEstimationError e -> prettyError e AutoBalanceCalculationError e -> prettyError e - estimateOrCalculateBalancedTxBody :: ShelleyBasedEra era -> FeeEstimationMode era @@ -131,23 +126,46 @@ estimateOrCalculateBalancedTxBody era feeEstMode pparams txBodyContent poolids s case feeEstMode of CalculateWithSpendableUTxO utxo systemstart ledgerEpochInfo mOverride -> first AutoBalanceCalculationError $ - makeTransactionBodyAutoBalance era systemstart ledgerEpochInfo (LedgerProtocolParameters pparams) - poolids stakeDelegDeposits drepDelegDeposits utxo txBodyContent changeAddr mOverride - + makeTransactionBodyAutoBalance + era + systemstart + ledgerEpochInfo + (LedgerProtocolParameters pparams) + poolids + stakeDelegDeposits + drepDelegDeposits + utxo + txBodyContent + changeAddr + mOverride EstimateWithoutSpendableUTxO - totalPotentialCollateral totalUTxOValue exUnitsMap - (RequiredShelleyKeyWitnesses numKeyWits) (RequiredByronKeyWitnesses numByronWits) + totalPotentialCollateral + totalUTxOValue + exUnitsMap + (RequiredShelleyKeyWitnesses numKeyWits) + (RequiredByronKeyWitnesses numByronWits) (TotalReferenceScriptsSize totalRefScriptsSize) -> forShelleyBasedEraInEon era (Left $ AutoBalanceEstimationError TxFeeEstimationOnlyMaryOnwardsSupportedError) - (\w -> first AutoBalanceEstimationError $ - estimateBalancedTxBody w txBodyContent pparams poolids stakeDelegDeposits drepDelegDeposits - exUnitsMap totalPotentialCollateral numKeyWits numByronWits - totalRefScriptsSize changeAddr totalUTxOValue + ( \w -> + first AutoBalanceEstimationError $ + estimateBalancedTxBody + w + txBodyContent + pparams + poolids + stakeDelegDeposits + drepDelegDeposits + exUnitsMap + totalPotentialCollateral + numKeyWits + numByronWits + totalRefScriptsSize + changeAddr + totalUTxOValue ) - data TxFeeEstimationError era = TxFeeEstimationTransactionTranslationError (TransactionValidityError era) | TxFeeEstimationScriptExecutionError (TxBodyErrorAutoBalance era) @@ -155,9 +173,7 @@ data TxFeeEstimationError era | TxFeeEstimationxBodyError TxBodyError | TxFeeEstimationFinalConstructionError TxBodyError | TxFeeEstimationOnlyMaryOnwardsSupportedError - deriving Show - - + deriving (Show) instance Error (TxFeeEstimationError era) where prettyError = \case @@ -166,39 +182,59 @@ instance Error (TxFeeEstimationError era) where TxFeeEstimationBalanceError e -> prettyError e TxFeeEstimationxBodyError e -> prettyError e TxFeeEstimationFinalConstructionError e -> prettyError e - TxFeeEstimationOnlyMaryOnwardsSupportedError-> + TxFeeEstimationOnlyMaryOnwardsSupportedError -> "Only mary era onwards supported." -- | Use when you do not have access to the UTxOs you intend to spend estimateBalancedTxBody - :: forall era. MaryEraOnwards era + :: forall era + . MaryEraOnwards era -> TxBodyContent BuildTx era -> L.PParams (ShelleyLedgerEra era) - -> Set PoolId -- ^ The set of registered stake pools, that are being - -- unregistered in this transaction. + -> Set PoolId + -- ^ The set of registered stake pools, that are being + -- unregistered in this transaction. -> Map StakeCredential L.Coin - -- ^ Map of all deposits for stake credentials that are being - -- unregistered in this transaction + -- ^ Map of all deposits for stake credentials that are being + -- unregistered in this transaction -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin - -- ^ Map of all deposits for drep credentials that are being - -- unregistered in this transaction - -> Map ScriptWitnessIndex ExecutionUnits -- ^ Plutus script execution units - -> Coin -- ^ Total potential collateral amount - -> Int -- ^ The number of key witnesses still to be added to the transaction. - -> Int -- ^ The number of Byron key witnesses still to be added to the transaction. - -> Int -- ^ Size of all reference scripts in bytes - -> AddressInEra era -- ^ Change address - -> Value -- ^ Total value of UTxOs being spent + -- ^ Map of all deposits for drep credentials that are being + -- unregistered in this transaction + -> Map ScriptWitnessIndex ExecutionUnits + -- ^ Plutus script execution units + -> Coin + -- ^ Total potential collateral amount + -> Int + -- ^ The number of key witnesses still to be added to the transaction. + -> Int + -- ^ The number of Byron key witnesses still to be added to the transaction. + -> Int + -- ^ Size of all reference scripts in bytes + -> AddressInEra era + -- ^ Change address + -> Value + -- ^ Total value of UTxOs being spent -> Either (TxFeeEstimationError era) (BalancedTxBody era) -estimateBalancedTxBody w txbodycontent pparams poolids - stakeDelegDeposits drepDelegDeposits exUnitsMap totalPotentialCollateral - intendedKeyWits byronwits sizeOfAllReferenceScripts changeaddr - totalUTxOValue = do +estimateBalancedTxBody + w + txbodycontent + pparams + poolids + stakeDelegDeposits + drepDelegDeposits + exUnitsMap + totalPotentialCollateral + intendedKeyWits + byronwits + sizeOfAllReferenceScripts + changeaddr + totalUTxOValue = do -- Step 1. Substitute those execution units into the tx let sbe = maryEraOnwardsToShelleyBasedEra w - txbodycontent1 <- first TxFeeEstimationScriptExecutionError - $ substituteExecutionUnits exUnitsMap txbodycontent + txbodycontent1 <- + first TxFeeEstimationScriptExecutionError $ + substituteExecutionUnits exUnitsMap txbodycontent -- Step 2. We need to calculate the current balance of the tx. The user -- must at least provide the total value of the UTxOs they intend to spend @@ -224,44 +260,67 @@ estimateBalancedTxBody w txbodycontent pparams poolids -- type signature, we assume the user is trying to register a stake pool that has not been -- registered before and has not included duplicate stake pool registration certificates. let assumeStakePoolHasNotBeenRegistered = const False - in sum [ maryEraOnwardsConstraints w $ L.getTotalDepositsTxCerts pparams assumeStakePoolHasNotBeenRegistered certificates - , mconcat $ map (^. L.pProcDepositL) $ toList proposalProcedures - ] + in sum + [ maryEraOnwardsConstraints w $ + L.getTotalDepositsTxCerts pparams assumeStakePoolHasNotBeenRegistered certificates + , mconcat $ map (^. L.pProcDepositL) $ toList proposalProcedures + ] - availableUTxOValue = mconcat [ totalUTxOValue - , negateValue (lovelaceToValue totalDeposits) - ] + availableUTxOValue = + mconcat + [ totalUTxOValue + , negateValue (lovelaceToValue totalDeposits) + ] let change = toLedgerValue w $ calculateChangeValue sbe availableUTxOValue txbodycontent1 - maxLovelaceChange = L.Coin (2^(64 :: Integer)) - 1 + maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1 changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange - changeTxOut = forShelleyBasedEraInEon sbe - (lovelaceToTxOutValue sbe maxLovelaceChange) - (\w' -> maryEraOnwardsConstraints w' $ TxOutValueShelleyBased sbe changeWithMaxLovelace) + changeTxOut = + forShelleyBasedEraInEon + sbe + (lovelaceToTxOutValue sbe maxLovelaceChange) + (\w' -> maryEraOnwardsConstraints w' $ TxOutValueShelleyBased sbe changeWithMaxLovelace) let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr -- Step 3. Create a tx body with out max lovelace fee. This is strictly for -- calculating our fee with evaluateTransactionFee. - let maxLovelaceFee = L.Coin (2^(32 :: Integer) - 1) - txbody1ForFeeEstimateOnly <- first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody sbe txbodycontent1 { - txFee = TxFeeExplicit sbe maxLovelaceFee, - txOuts = TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone - : txOuts txbodycontent, - txReturnCollateral = dummyCollRet, - txTotalCollateral = dummyTotColl - } - let fee = evaluateTransactionFee sbe pparams txbody1ForFeeEstimateOnly (fromIntegral intendedKeyWits) (fromIntegral byronwits) sizeOfAllReferenceScripts - - -- Step 4. We use the fee to calculate the required collateral + let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1) + txbody1ForFeeEstimateOnly <- + first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now + createAndValidateTransactionBody + sbe + txbodycontent1 + { txFee = TxFeeExplicit sbe maxLovelaceFee + , txOuts = + TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone + : txOuts txbodycontent + , txReturnCollateral = dummyCollRet + , txTotalCollateral = dummyTotColl + } + let fee = + evaluateTransactionFee + sbe + pparams + txbody1ForFeeEstimateOnly + (fromIntegral intendedKeyWits) + (fromIntegral byronwits) + sizeOfAllReferenceScripts + + -- Step 4. We use the fee to calculate the required collateral (retColl, reqCol) = - caseShelleyToAlonzoOrBabbageEraOnwards + caseShelleyToAlonzoOrBabbageEraOnwards (const (TxReturnCollateralNone, TxTotalCollateralNone)) - (\w' -> - calcReturnAndTotalCollateral w' - fee pparams (txInsCollateral txbodycontent) (txReturnCollateral txbodycontent) - (txTotalCollateral txbodycontent) changeaddr totalPotentialCollateral + ( \w' -> + calcReturnAndTotalCollateral + w' + fee + pparams + (txInsCollateral txbodycontent) + (txReturnCollateral txbodycontent) + (txTotalCollateral txbodycontent) + changeaddr + totalPotentialCollateral ) sbe @@ -269,23 +328,26 @@ estimateBalancedTxBody w txbodycontent pparams poolids -- 1. The original outputs -- 2. Tx fee -- 3. Return and total collateral - txbody2 <- first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody sbe txbodycontent1 { - txFee = TxFeeExplicit sbe fee, - txReturnCollateral = retColl, - txTotalCollateral = reqCol - } + txbody2 <- + first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now + createAndValidateTransactionBody + sbe + txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } let fakeUTxO = createFakeUTxO sbe txbodycontent1 $ selectLovelace availableUTxOValue - balance = evaluateTransactionBalance sbe pparams poolids stakeDelegDeposits drepDelegDeposits fakeUTxO txbody2 + balance = + evaluateTransactionBalance sbe pparams poolids stakeDelegDeposits drepDelegDeposits fakeUTxO txbody2 -- check if the balance is positive or negative -- in one case we can produce change, in the other the inputs are insufficient first TxFeeEstimationBalanceError $ balanceCheck sbe pparams changeaddr balance -- Step 6. Check all txouts have the min required UTxO value - forM_ (txOuts txbodycontent1) - $ \txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe txout pparams - + forM_ (txOuts txbodycontent1) $ + \txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe txout pparams -- Step 7. @@ -294,20 +356,28 @@ estimateBalancedTxBody w txbodycontent pparams poolids -- fit within the encoding size we picked above when calculating the fee. -- Yes this could be an over-estimate by a few bytes if the fee or change -- would fit within 2^16-1. That's a possible optimisation. - let finalTxBodyContent = txbodycontent1 { - txFee = TxFeeExplicit sbe fee, - txOuts = accountForNoChange - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent), - txReturnCollateral = retColl, - txTotalCollateral = reqCol - } + let finalTxBodyContent = + txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txOuts = + accountForNoChange + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + (txOuts txbodycontent) + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } txbody3 <- first TxFeeEstimationFinalConstructionError $ -- TODO: impossible to fail now. We need to implement a function - -- that simply creates a transaction body because we have already - -- validated the transaction body earlier within makeTransactionBodyAutoBalance + -- that simply creates a transaction body because we have already + -- validated the transaction body earlier within makeTransactionBodyAutoBalance createAndValidateTransactionBody sbe finalTxBodyContent - return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) + return + ( BalancedTxBody + finalTxBodyContent + txbody3 + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + fee + ) --- ---------------------------------------------------------------------------- --- Transaction fees @@ -318,19 +388,24 @@ estimateBalancedTxBody w txbodycontent pparams poolids -- signatures). -- -- Use 'calculateMinTxFee' if possible as that function is more accurate. -evaluateTransactionFee :: forall era. () +evaluateTransactionFee + :: forall era + . () => ShelleyBasedEra era -> Ledger.PParams (ShelleyLedgerEra era) -> TxBody era - -> Word -- ^ The number of Shelley key witnesses - -> Word -- ^ The number of Byron key witnesses - -> Int -- ^ Reference script size in bytes + -> Word + -- ^ The number of Shelley key witnesses + -> Word + -- ^ The number of Byron key witnesses + -> Int + -- ^ Reference script size in bytes -> L.Coin evaluateTransactionFee sbe pp txbody keywitcount byronwitcount refScriptsSize = shelleyBasedEraConstraints sbe $ case makeSignedTransaction' (toCardanoEra sbe) [] txbody of ShelleyTx _ tx -> - L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize + L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize -- | Estimate minimum transaction fee for a proposed transaction by looking -- into the transaction and figuring out how many and what kind of key @@ -344,12 +419,15 @@ evaluateTransactionFee sbe pp txbody keywitcount byronwitcount refScriptsSize = -- -- For this reason number of witnesses needed for native scripts must be -- supplied as an extra argument. -calculateMinTxFee :: forall era. () +calculateMinTxFee + :: forall era + . () => ShelleyBasedEra era -> Ledger.PParams (ShelleyLedgerEra era) -> UTxO era -> TxBody era - -> Word -- ^ The number of Shelley key witnesses + -> Word + -- ^ The number of Shelley key witnesses -> L.Coin calculateMinTxFee sbe pp utxo txbody keywitcount = shelleyBasedEraConstraints sbe $ @@ -371,44 +449,38 @@ calculateMinTxFee sbe pp utxo txbody keywitcount = -- TODO: it is worth us considering a more precise count that relies on the -- UTxO to resolve which inputs are for distinct addresses, and also to count -- the number of Shelley vs Byron style witnesses. --- estimateTransactionKeyWitnessCount :: TxBodyContent BuildTx era -> Word -estimateTransactionKeyWitnessCount TxBodyContent { - txIns, - txInsCollateral, - txExtraKeyWits, - txWithdrawals, - txCertificates, - txUpdateProposal - } = - fromIntegral $ - length [ () | (_txin, BuildTxWith KeyWitness{}) <- txIns ] - - + case txInsCollateral of - TxInsCollateral _ txins - -> length txins - _ -> 0 - - + case txExtraKeyWits of - TxExtraKeyWitnesses _ khs - -> length khs - _ -> 0 - - + case txWithdrawals of - TxWithdrawals _ withdrawals - -> length [ () | (_, _, BuildTxWith KeyWitness{}) <- withdrawals ] - _ -> 0 - - + case txCertificates of - TxCertificates _ _ (BuildTxWith witnesses) - -> length [ () | KeyWitness{} <- Map.elems witnesses ] - _ -> 0 - - + case txUpdateProposal of - TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) - -> Map.size updatePerGenesisKey - _ -> 0 - +estimateTransactionKeyWitnessCount + TxBodyContent + { txIns + , txInsCollateral + , txExtraKeyWits + , txWithdrawals + , txCertificates + , txUpdateProposal + } = + fromIntegral $ + length [() | (_txin, BuildTxWith KeyWitness {}) <- txIns] + + case txInsCollateral of + TxInsCollateral _ txins -> + length txins + _ -> 0 + + case txExtraKeyWits of + TxExtraKeyWitnesses _ khs -> + length khs + _ -> 0 + + case txWithdrawals of + TxWithdrawals _ withdrawals -> + length [() | (_, _, BuildTxWith KeyWitness {}) <- withdrawals] + _ -> 0 + + case txCertificates of + TxCertificates _ _ (BuildTxWith witnesses) -> + length [() | KeyWitness {} <- Map.elems witnesses] + _ -> 0 + + case txUpdateProposal of + TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) -> + Map.size updatePerGenesisKey + _ -> 0 -- ---------------------------------------------------------------------------- -- Script execution units @@ -417,19 +489,19 @@ estimateTransactionKeyWitnessCount TxBodyContent { type PlutusScriptBytes = ShortByteString data ResolvablePointers where - ResolvablePointers :: - ( Ledger.Era (ShelleyLedgerEra era) - , Show (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) - , Show (L.PlutusPurpose L.AsItem (ShelleyLedgerEra era)) - , Show (Alonzo.PlutusScript (ShelleyLedgerEra era)) - ) + ResolvablePointers + :: ( Ledger.Era (ShelleyLedgerEra era) + , Show (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + , Show (L.PlutusPurpose L.AsItem (ShelleyLedgerEra era)) + , Show (Alonzo.PlutusScript (ShelleyLedgerEra era)) + ) => ShelleyBasedEra era - -> !(Map - (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) - ( L.PlutusPurpose L.AsItem (ShelleyLedgerEra era) - , Maybe (PlutusScriptBytes, Plutus.Language) - , Ledger.ScriptHash Ledger.StandardCrypto - ) + -> !( Map + (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + ( L.PlutusPurpose L.AsItem (ShelleyLedgerEra era) + , Maybe (PlutusScriptBytes, Plutus.Language) + , Ledger.ScriptHash Ledger.StandardCrypto + ) ) -> ResolvablePointers @@ -444,84 +516,69 @@ deriving instance Show ResolvablePointers -- TODO: We should replace ScriptWitnessIndex with ledger's -- PlutusPurpose AsIx ledgerera. This would necessitate the -- parameterization of ScriptExecutionError. -data ScriptExecutionError = - - -- | The script depends on a 'TxIn' that has not been provided in the - -- given 'UTxO' subset. The given 'UTxO' must cover all the inputs - -- the transaction references. - ScriptErrorMissingTxIn TxIn - - -- | The 'TxIn' the script is spending does not have a 'ScriptDatum'. - -- All inputs guarded by Plutus scripts need to have been created with - -- a 'ScriptDatum'. - | ScriptErrorTxInWithoutDatum TxIn - - -- | The 'ScriptDatum' provided does not match the one from the 'UTxO'. - -- This means the wrong 'ScriptDatum' value has been provided. - -- - | ScriptErrorWrongDatum (Hash ScriptData) - - -- | The script evaluation failed. This usually means it evaluated to an - -- error value. This is not a case of running out of execution units - -- (which is not possible for 'evaluateTransactionExecutionUnits' since - -- the whole point of it is to discover how many execution units are - -- needed). - -- - | ScriptErrorEvaluationFailed Plutus.EvaluationError [Text.Text] - - -- | The execution units overflowed a 64bit word. Congratulations if - -- you encounter this error. With the current style of cost model this - -- would need a script to run for over 7 months, which is somewhat more - -- than the expected maximum of a few milliseconds. - -- - | ScriptErrorExecutionUnitsOverflow - - -- | An attempt was made to spend a key witnessed tx input - -- with a script witness. - | ScriptErrorNotPlutusWitnessedTxIn ScriptWitnessIndex ScriptHash - - -- | The redeemer pointer points to a script hash that does not exist - -- in the transaction nor in the UTxO as a reference script" - | ScriptErrorRedeemerPointsToUnknownScriptHash ScriptWitnessIndex - - -- | A redeemer pointer points to a script that does not exist. - | ScriptErrorMissingScript - ScriptWitnessIndex -- The invalid pointer - ResolvablePointers -- A mapping a pointers that are possible to resolve - - -- | A cost model was missing for a language which was used. - | ScriptErrorMissingCostModel Plutus.Language - - | forall era. ( Plutus.EraPlutusContext (ShelleyLedgerEra era) - , Show (Plutus.ContextError (ShelleyLedgerEra era)) - ) => ScriptErrorTranslationError (Plutus.ContextError (ShelleyLedgerEra era)) - +data ScriptExecutionError + = -- | The script depends on a 'TxIn' that has not been provided in the + -- given 'UTxO' subset. The given 'UTxO' must cover all the inputs + -- the transaction references. + ScriptErrorMissingTxIn TxIn + | -- | The 'TxIn' the script is spending does not have a 'ScriptDatum'. + -- All inputs guarded by Plutus scripts need to have been created with + -- a 'ScriptDatum'. + ScriptErrorTxInWithoutDatum TxIn + | -- | The 'ScriptDatum' provided does not match the one from the 'UTxO'. + -- This means the wrong 'ScriptDatum' value has been provided. + ScriptErrorWrongDatum (Hash ScriptData) + | -- | The script evaluation failed. This usually means it evaluated to an + -- error value. This is not a case of running out of execution units + -- (which is not possible for 'evaluateTransactionExecutionUnits' since + -- the whole point of it is to discover how many execution units are + -- needed). + ScriptErrorEvaluationFailed Plutus.EvaluationError [Text.Text] + | -- | The execution units overflowed a 64bit word. Congratulations if + -- you encounter this error. With the current style of cost model this + -- would need a script to run for over 7 months, which is somewhat more + -- than the expected maximum of a few milliseconds. + ScriptErrorExecutionUnitsOverflow + | -- | An attempt was made to spend a key witnessed tx input + -- with a script witness. + ScriptErrorNotPlutusWitnessedTxIn ScriptWitnessIndex ScriptHash + | -- | The redeemer pointer points to a script hash that does not exist + -- in the transaction nor in the UTxO as a reference script" + ScriptErrorRedeemerPointsToUnknownScriptHash ScriptWitnessIndex + | -- | A redeemer pointer points to a script that does not exist. + ScriptErrorMissingScript + ScriptWitnessIndex -- The invalid pointer + ResolvablePointers -- A mapping a pointers that are possible to resolve + | -- | A cost model was missing for a language which was used. + ScriptErrorMissingCostModel Plutus.Language + | forall era. + ( Plutus.EraPlutusContext (ShelleyLedgerEra era) + , Show (Plutus.ContextError (ShelleyLedgerEra era)) + ) => + ScriptErrorTranslationError (Plutus.ContextError (ShelleyLedgerEra era)) + deriving instance Show ScriptExecutionError instance Error ScriptExecutionError where prettyError = \case ScriptErrorMissingTxIn txin -> "The supplied UTxO is missing the txin " <> pretty (renderTxIn txin) - ScriptErrorTxInWithoutDatum txin -> mconcat [ "The Plutus script witness for the txin does not have a script datum " , "(according to the UTxO). The txin in question is " , pretty (renderTxIn txin) ] - ScriptErrorWrongDatum dh -> mconcat [ "The Plutus script witness has the wrong datum (according to the UTxO). " , "The expected datum value has hash " <> pshow dh ] - ScriptErrorEvaluationFailed evalErr logs -> mconcat [ "The Plutus script evaluation failed: " <> pretty evalErr , "\nScript debugging logs: " <> mconcat (map (\t -> pretty $ t `Text.append` "\n") logs) ] - ScriptErrorExecutionUnitsOverflow -> mconcat [ "The execution units required by this Plutus script overflows a 64bit " @@ -529,56 +586,49 @@ instance Error ScriptExecutionError where , "impossible. So this probably indicates a chain configuration problem, " , "perhaps with the values in the cost model." ] - ScriptErrorNotPlutusWitnessedTxIn scriptWitness scriptHash -> mconcat [ pretty (renderScriptWitnessIndex scriptWitness) , " is not a Plutus script witnessed tx input and cannot be spent using a " , "Plutus script witness.The script hash is " <> pshow scriptHash <> "." ] - ScriptErrorRedeemerPointsToUnknownScriptHash scriptWitness -> mconcat [ pretty (renderScriptWitnessIndex scriptWitness) , " points to a script hash that is not known." ] - ScriptErrorMissingScript rdmrPtr resolveable -> mconcat [ "The redeemer pointer: " <> pshow rdmrPtr <> " points to a Plutus " , "script that does not exist.\n" , "The pointers that can be resolved are: " <> pshow resolveable ] - ScriptErrorMissingCostModel language -> "No cost model was found for language " <> pshow language - - ScriptErrorTranslationError e -> + ScriptErrorTranslationError e -> "Error translating the transaction context: " <> pshow e - -data TransactionValidityError era where - -- | The transaction validity interval is too far into the future. - -- - -- Transactions with Plutus scripts need to have a validity interval that is - -- not so far in the future that we cannot reliably determine the UTC time - -- corresponding to the validity interval expressed in slot numbers. - -- - -- This is because the Plutus scripts get given the transaction validity - -- interval in UTC time, so that they are not sensitive to slot lengths. - -- - -- If either end of the validity interval is beyond the so called \"time - -- horizon\" then the consensus algorithm is not able to reliably determine - -- the relationship between slots and time. This is this situation in which - -- this error is reported. For the Cardano mainnet the time horizon is 36 - -- hours beyond the current time. This effectively means we cannot submit - -- check or submit transactions that use Plutus scripts that have the end - -- of their validity interval more than 36 hours into the future. - TransactionValidityIntervalError - :: Consensus.PastHorizonException -> TransactionValidityError era - - TransactionValidityCostModelError - :: (Map AnyPlutusScriptVersion CostModel) -> String -> TransactionValidityError era +data TransactionValidityError era where + -- | The transaction validity interval is too far into the future. + -- + -- Transactions with Plutus scripts need to have a validity interval that is + -- not so far in the future that we cannot reliably determine the UTC time + -- corresponding to the validity interval expressed in slot numbers. + -- + -- This is because the Plutus scripts get given the transaction validity + -- interval in UTC time, so that they are not sensitive to slot lengths. + -- + -- If either end of the validity interval is beyond the so called \"time + -- horizon\" then the consensus algorithm is not able to reliably determine + -- the relationship between slots and time. This is this situation in which + -- this error is reported. For the Cardano mainnet the time horizon is 36 + -- hours beyond the current time. This effectively means we cannot submit + -- check or submit transactions that use Plutus scripts that have the end + -- of their validity interval more than 36 hours into the future. + TransactionValidityIntervalError + :: Consensus.PastHorizonException -> TransactionValidityError era + TransactionValidityCostModelError + :: (Map AnyPlutusScriptVersion CostModel) -> String -> TransactionValidityError era deriving instance Show (TransactionValidityError era) @@ -594,17 +644,15 @@ instance Error (TransactionValidityError era) where , "are close enough in the future that we can reliably turn the slot " , "numbers into UTC wall clock times.)" ] - where - timeHorizonSlots :: Consensus.PastHorizonException -> Word - timeHorizonSlots Consensus.PastHorizon{Consensus.pastHorizonSummary} - | eraSummaries@(_:_) <- pastHorizonSummary - , Consensus.StandardSafeZone slots <- - (Consensus.eraSafeZone . Consensus.eraParams . last) eraSummaries - = fromIntegral slots - - | otherwise - = 0 -- This should be impossible. - + where + timeHorizonSlots :: Consensus.PastHorizonException -> Word + timeHorizonSlots Consensus.PastHorizon {Consensus.pastHorizonSummary} + | eraSummaries@(_ : _) <- pastHorizonSummary + , Consensus.StandardSafeZone slots <- + (Consensus.eraSafeZone . Consensus.eraParams . last) eraSummaries = + fromIntegral slots + | otherwise = + 0 -- This should be impossible. TransactionValidityCostModelError cModels err -> mconcat [ "An error occurred while converting from the cardano-api cost" @@ -616,84 +664,93 @@ instance Error (TransactionValidityError era) where -- -- This works by running all the scripts and counting how many execution units -- are actually used. --- -evaluateTransactionExecutionUnits :: forall era. () +evaluateTransactionExecutionUnits + :: forall era + . () => CardanoEra era -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era -> UTxO era -> TxBody era - -> Either (TransactionValidityError era) - (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) + -> Either + (TransactionValidityError era) + (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody = - case makeSignedTransaction' era [] txbody of - ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx' + case makeSignedTransaction' era [] txbody of + ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx' -evaluateTransactionExecutionUnitsShelley :: forall era. () +evaluateTransactionExecutionUnitsShelley + :: forall era + . () => ShelleyBasedEra era -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era -> UTxO era -> L.Tx (ShelleyLedgerEra era) - -> Either (TransactionValidityError era) - (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) + -> Either + (TransactionValidityError era) + (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx = caseShelleyToMaryOrAlonzoEraOnwards (const (Right Map.empty)) - (\w -> pure . fromLedgerScriptExUnitsMap w - $ alonzoEraOnwardsConstraints w - $ L.evalTxExUnitsWithLogs pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart + ( \w -> + pure . fromLedgerScriptExUnitsMap w $ + alonzoEraOnwardsConstraints w $ + L.evalTxExUnitsWithLogs pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart ) sbe - where - LedgerEpochInfo ledgerEpochInfo = epochInfo - - fromLedgerScriptExUnitsMap - :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) - => AlonzoEraOnwards era - -> Map (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) - (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits)) - -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)) - fromLedgerScriptExUnitsMap aOnwards exmap = - Map.fromList - [ (toScriptIndex aOnwards rdmrptr, - bimap (fromAlonzoScriptExecutionError aOnwards) (second fromAlonzoExUnits) exunitsOrFailure) - | (rdmrptr, exunitsOrFailure) <- Map.toList exmap ] - - fromAlonzoScriptExecutionError - :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) - => AlonzoEraOnwards era - -> L.TransactionScriptFailure (ShelleyLedgerEra era) - -> ScriptExecutionError - fromAlonzoScriptExecutionError aOnwards = - shelleyBasedEraConstraints sbe $ \case - L.UnknownTxIn txin -> ScriptErrorMissingTxIn txin' - where txin' = fromShelleyTxIn txin - L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' - where txin' = fromShelleyTxIn txin - L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) - L.ValidationFailure _ evalErr logs _ -> - -- TODO: Include additional information from ValidationFailure - ScriptErrorEvaluationFailed evalErr logs - - L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow - - L.RedeemerPointsToUnknownScriptHash rdmrPtr -> - ScriptErrorRedeemerPointsToUnknownScriptHash $ toScriptIndex aOnwards rdmrPtr - -- This should not occur while using cardano-cli because we zip together - -- the Plutus script and the use site (txin, certificate etc). Therefore - -- the redeemer pointer will always point to a Plutus script. - L.MissingScript indexOfScriptWitnessedItem resolveable -> - let scriptWitnessedItemIndex = toScriptIndex aOnwards indexOfScriptWitnessedItem - in ScriptErrorMissingScript scriptWitnessedItemIndex - $ ResolvablePointers sbe $ Map.map extractScriptBytesAndLanguage resolveable - L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l - L.ContextError e -> - alonzoEraOnwardsConstraints aOnwards - $ ScriptErrorTranslationError e - + where + LedgerEpochInfo ledgerEpochInfo = epochInfo + + fromLedgerScriptExUnitsMap + :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) + => AlonzoEraOnwards era + -> Map + (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits)) + -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)) + fromLedgerScriptExUnitsMap aOnwards exmap = + Map.fromList + [ ( toScriptIndex aOnwards rdmrptr + , bimap (fromAlonzoScriptExecutionError aOnwards) (second fromAlonzoExUnits) exunitsOrFailure + ) + | (rdmrptr, exunitsOrFailure) <- Map.toList exmap + ] + + fromAlonzoScriptExecutionError + :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) + => AlonzoEraOnwards era + -> L.TransactionScriptFailure (ShelleyLedgerEra era) + -> ScriptExecutionError + fromAlonzoScriptExecutionError aOnwards = + shelleyBasedEraConstraints sbe $ \case + L.UnknownTxIn txin -> ScriptErrorMissingTxIn txin' + where + txin' = fromShelleyTxIn txin + L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' + where + txin' = fromShelleyTxIn txin + L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) + L.ValidationFailure _ evalErr logs _ -> + -- TODO: Include additional information from ValidationFailure + ScriptErrorEvaluationFailed evalErr logs + L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow + L.RedeemerPointsToUnknownScriptHash rdmrPtr -> + ScriptErrorRedeemerPointsToUnknownScriptHash $ toScriptIndex aOnwards rdmrPtr + -- This should not occur while using cardano-cli because we zip together + -- the Plutus script and the use site (txin, certificate etc). Therefore + -- the redeemer pointer will always point to a Plutus script. + L.MissingScript indexOfScriptWitnessedItem resolveable -> + let scriptWitnessedItemIndex = toScriptIndex aOnwards indexOfScriptWitnessedItem + in ScriptErrorMissingScript scriptWitnessedItemIndex $ + ResolvablePointers sbe $ + Map.map extractScriptBytesAndLanguage resolveable + L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l + L.ContextError e -> + alonzoEraOnwardsConstraints aOnwards $ + ScriptErrorTranslationError e extractScriptBytesAndLanguage :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) @@ -708,7 +765,6 @@ extractScriptBytesAndLanguage extractScriptBytesAndLanguage (purpose, mbScript, scriptHash) = (purpose, fmap extractPlutusScriptAndLanguage mbScript, scriptHash) - extractPlutusScriptAndLanguage :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) => Alonzo.PlutusScript (ShelleyLedgerEra era) @@ -716,7 +772,8 @@ extractPlutusScriptAndLanguage extractPlutusScriptAndLanguage p = let bin = Plutus.unPlutusBinary $ Alonzo.plutusScriptBinary p l = Alonzo.plutusScriptLanguage p - in (bin, l) + in (bin, l) + -- ---------------------------------------------------------------------------- -- Transaction balance -- @@ -726,106 +783,92 @@ extractPlutusScriptAndLanguage p = -- -- Finding the (non-zero) balance of partially constructed transaction is -- useful for adjusting a transaction to be fully balanced. --- -evaluateTransactionBalance :: forall era. () - => ShelleyBasedEra era - -> Ledger.PParams (ShelleyLedgerEra era) - -> Set PoolId - -> Map StakeCredential L.Coin - -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin - -> UTxO era - -> TxBody era - -> TxOutValue era +evaluateTransactionBalance + :: forall era + . () + => ShelleyBasedEra era + -> Ledger.PParams (ShelleyLedgerEra era) + -> Set PoolId + -> Map StakeCredential L.Coin + -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin + -> UTxO era + -> TxBody era + -> TxOutValue era evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody _ txbody _ _ _ _) = - shelleyBasedEraConstraints sbe - $ TxOutValueShelleyBased sbe - $ L.evalBalanceTxBody + shelleyBasedEraConstraints sbe $ + TxOutValueShelleyBased sbe $ + L.evalBalanceTxBody pp lookupDelegDeposit lookupDRepDeposit isRegPool (toLedgerUTxO sbe utxo) txbody - where - isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool - isRegPool kh = StakePoolKeyHash kh `Set.member` poolids + where + isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool + isRegPool kh = StakePoolKeyHash kh `Set.member` poolids - lookupDelegDeposit :: - Ledger.Credential 'Ledger.Staking L.StandardCrypto -> Maybe L.Coin - lookupDelegDeposit stakeCred = - Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits + lookupDelegDeposit + :: Ledger.Credential 'Ledger.Staking L.StandardCrypto -> Maybe L.Coin + lookupDelegDeposit stakeCred = + Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits - lookupDRepDeposit :: - Ledger.Credential 'Ledger.DRepRole L.StandardCrypto -> Maybe L.Coin - lookupDRepDeposit drepCred = - Map.lookup drepCred drepDelegDeposits + lookupDRepDeposit + :: Ledger.Credential 'Ledger.DRepRole L.StandardCrypto -> Maybe L.Coin + lookupDRepDeposit drepCred = + Map.lookup drepCred drepDelegDeposits -- ---------------------------------------------------------------------------- -- Automated transaction building -- -- | The possible errors that can arise from 'makeTransactionBodyAutoBalance'. --- -data TxBodyErrorAutoBalance era = - - -- | The same errors that can arise from 'makeTransactionBody'. - TxBodyError TxBodyError - - -- | One or more of the scripts fails to execute correctly. - | TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)] - - -- | One or more of the scripts were expected to fail validation, but none did. - | TxBodyScriptBadScriptValidity - - -- | There is not enough ada to cover both the outputs and the fees. - -- The transaction should be changed to provide more input ada, or - -- otherwise adjusted to need less (e.g. outputs, script etc). - -- - | TxBodyErrorAdaBalanceNegative L.Coin - - -- | There is enough ada to cover both the outputs and the fees, but the - -- resulting change is too small: it is under the minimum value for - -- new UTxO entries. The transaction should be changed to provide more - -- input ada. - -- - | TxBodyErrorAdaBalanceTooSmall - -- ^ Offending TxOut - TxOutInAnyEra - -- ^ Minimum UTxO - L.Coin - -- ^ Tx balance - L.Coin - - -- | 'makeTransactionBodyAutoBalance' does not yet support the Byron era. - | TxBodyErrorByronEraNotSupported - - -- | The 'ProtocolParameters' must provide the value for the min utxo - -- parameter, for eras that use this parameter. - | TxBodyErrorMissingParamMinUTxO - - -- | The transaction validity interval is too far into the future. - -- See 'TransactionValidityIntervalError' for details. - | TxBodyErrorValidityInterval (TransactionValidityError era) - - -- | The minimum spendable UTxO threshold has not been met. - | TxBodyErrorMinUTxONotMet - -- ^ Offending TxOut - TxOutInAnyEra - -- ^ Minimum UTxO - L.Coin - | TxBodyErrorNonAdaAssetsUnbalanced Value - | TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap - ScriptWitnessIndex - (Map ScriptWitnessIndex ExecutionUnits) - - deriving Show - +data TxBodyErrorAutoBalance era + = -- | The same errors that can arise from 'makeTransactionBody'. + TxBodyError TxBodyError + | -- | One or more of the scripts fails to execute correctly. + TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)] + | -- | One or more of the scripts were expected to fail validation, but none did. + TxBodyScriptBadScriptValidity + | -- | There is not enough ada to cover both the outputs and the fees. + -- The transaction should be changed to provide more input ada, or + -- otherwise adjusted to need less (e.g. outputs, script etc). + TxBodyErrorAdaBalanceNegative L.Coin + | -- | There is enough ada to cover both the outputs and the fees, but the + -- resulting change is too small: it is under the minimum value for + -- new UTxO entries. The transaction should be changed to provide more + -- input ada. + TxBodyErrorAdaBalanceTooSmall + -- \^ Offending TxOut + TxOutInAnyEra + -- ^ Minimum UTxO + L.Coin + -- ^ Tx balance + L.Coin + | -- | 'makeTransactionBodyAutoBalance' does not yet support the Byron era. + TxBodyErrorByronEraNotSupported + | -- | The 'ProtocolParameters' must provide the value for the min utxo + -- parameter, for eras that use this parameter. + TxBodyErrorMissingParamMinUTxO + | -- | The transaction validity interval is too far into the future. + -- See 'TransactionValidityIntervalError' for details. + TxBodyErrorValidityInterval (TransactionValidityError era) + | -- | The minimum spendable UTxO threshold has not been met. + TxBodyErrorMinUTxONotMet + -- \^ Offending TxOut + TxOutInAnyEra + -- ^ Minimum UTxO + L.Coin + | TxBodyErrorNonAdaAssetsUnbalanced Value + | TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap + ScriptWitnessIndex + (Map ScriptWitnessIndex ExecutionUnits) + deriving (Show) instance Error (TxBodyErrorAutoBalance era) where prettyError = \case TxBodyError err -> prettyError err - TxBodyScriptExecutionError failures -> mconcat [ "The following scripts have execution failures:\n" @@ -837,17 +880,14 @@ instance Error (TxBodyErrorAutoBalance era) where | (index, failure) <- failures ] ] - TxBodyScriptBadScriptValidity -> "One or more of the scripts were expected to fail validation, but none did." - TxBodyErrorAdaBalanceNegative lovelace -> mconcat [ "The transaction does not balance in its use of ada. The net balance " , "of the transaction is negative: " <> pretty lovelace <> ". " , "The usual solution is to provide more inputs, or inputs with more ada." ] - TxBodyErrorAdaBalanceTooSmall changeOutput minUTxO balance -> mconcat [ "The transaction does balance in its use of ada, however the net " @@ -858,42 +898,38 @@ instance Error (TxBodyErrorAutoBalance era) where , "The usual solution is to provide more inputs, or inputs with more ada to " , "meet the minimum UTxO threshold" ] - TxBodyErrorByronEraNotSupported -> "The Byron era is not yet supported by makeTransactionBodyAutoBalance" - TxBodyErrorMissingParamMinUTxO -> "The minUTxOValue protocol parameter is required but missing" - TxBodyErrorValidityInterval err -> prettyError err - TxBodyErrorMinUTxONotMet txout minUTxO -> mconcat [ "Minimum UTxO threshold not met for tx output: " <> pretty (prettyRenderTxOut txout) <> "\n" , "Minimum required UTxO: " <> pretty minUTxO ] - TxBodyErrorNonAdaAssetsUnbalanced val -> "Non-Ada assets are unbalanced: " <> pretty (renderValue val) - TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap sIndex eUnitsMap -> mconcat [ "ScriptWitnessIndex (redeemer pointer): " <> pshow sIndex <> " is missing from the execution " , "units (redeemer pointer) map: " <> pshow eUnitsMap ] -handleExUnitsErrors :: - ScriptValidity -- ^ Mark script as expected to pass or fail validation +handleExUnitsErrors + :: ScriptValidity + -- ^ Mark script as expected to pass or fail validation -> Map ScriptWitnessIndex ScriptExecutionError -> Map ScriptWitnessIndex ExecutionUnits -> Either (TxBodyErrorAutoBalance era) (Map ScriptWitnessIndex ExecutionUnits) handleExUnitsErrors ScriptValid failuresMap exUnitsMap = - if null failures - then Right exUnitsMap - else Left (TxBodyScriptExecutionError failures) - where failures :: [(ScriptWitnessIndex, ScriptExecutionError)] - failures = Map.toList failuresMap + if null failures + then Right exUnitsMap + else Left (TxBodyScriptExecutionError failures) + where + failures :: [(ScriptWitnessIndex, ScriptExecutionError)] + failures = Map.toList failuresMap handleExUnitsErrors ScriptInvalid failuresMap exUnitsMap | null failuresMap = Left TxBodyScriptBadScriptValidity | otherwise = Right $ Map.map (\_ -> ExecutionUnits 0 0) failuresMap <> exUnitsMap @@ -902,36 +938,47 @@ data BalancedTxBody era = BalancedTxBody (TxBodyContent BuildTx era) (TxBody era) - (TxOut CtxTx era) -- ^ Transaction balance (change output) - L.Coin -- ^ Estimated transaction fee - deriving Show + (TxOut CtxTx era) + -- ^ Transaction balance (change output) + L.Coin + -- ^ Estimated transaction fee + deriving (Show) newtype RequiredShelleyKeyWitnesses - = RequiredShelleyKeyWitnesses { unRequiredShelleyKeyWitnesses :: Int } - deriving Show + = RequiredShelleyKeyWitnesses {unRequiredShelleyKeyWitnesses :: Int} + deriving (Show) newtype RequiredByronKeyWitnesses - = RequiredByronKeyWitnesses { unRequiredByronKeyWitnesses :: Int } - deriving Show + = RequiredByronKeyWitnesses {unRequiredByronKeyWitnesses :: Int} + deriving (Show) newtype TotalReferenceScriptsSize - = TotalReferenceScriptsSize { unTotalReferenceScriptsSize :: Int } - deriving Show - + = TotalReferenceScriptsSize {unTotalReferenceScriptsSize :: Int} + deriving (Show) data FeeEstimationMode era - = CalculateWithSpendableUTxO -- ^ Accurate fee calculation. - (UTxO era) -- ^ Spendable UTxO + = -- | Accurate fee calculation. + CalculateWithSpendableUTxO + (UTxO era) + -- ^ Spendable UTxO SystemStart LedgerEpochInfo - (Maybe Word) -- ^ Override number of key witnesses - | EstimateWithoutSpendableUTxO -- ^ Less accurate fee estimation. - Coin -- ^ Total potential collateral amount - Value -- ^ Total value of UTxOs being spent - (Map ScriptWitnessIndex ExecutionUnits) -- ^ Plutus script execution units - RequiredShelleyKeyWitnesses -- ^ The number of key witnesses still to be added to the transaction. - RequiredByronKeyWitnesses -- ^ The number of Byron key witnesses still to be added to the transaction. - TotalReferenceScriptsSize -- ^ The total size in bytes of reference scripts + (Maybe Word) + -- ^ Override number of key witnesses + | -- | Less accurate fee estimation. + EstimateWithoutSpendableUTxO + Coin + -- ^ Total potential collateral amount + Value + -- ^ Total value of UTxOs being spent + (Map ScriptWitnessIndex ExecutionUnits) + -- ^ Plutus script execution units + RequiredShelleyKeyWitnesses + -- ^ The number of key witnesses still to be added to the transaction. + RequiredByronKeyWitnesses + -- ^ The number of Byron key witnesses still to be added to the transaction. + TotalReferenceScriptsSize + -- ^ The total size in bytes of reference scripts -- | This is much like 'makeTransactionBody' but with greater automation to -- calculate suitable values for several things. @@ -954,155 +1001,203 @@ data FeeEstimationMode era -- -- To do this it needs more information than 'makeTransactionBody', all of -- which can be queried from a local node. --- -makeTransactionBodyAutoBalance :: forall era. () +makeTransactionBodyAutoBalance + :: forall era + . () => ShelleyBasedEra era -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era - -> Set PoolId -- ^ The set of registered stake pools, that are being - -- unregistered in this transaction. + -> Set PoolId + -- ^ The set of registered stake pools, that are being + -- unregistered in this transaction. -> Map StakeCredential L.Coin - -- ^ Map of all deposits for stake credentials that are being - -- unregistered in this transaction + -- ^ Map of all deposits for stake credentials that are being + -- unregistered in this transaction -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin - -- ^ Map of all deposits for drep credentials that are being - -- unregistered in this transaction - -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. + -- ^ Map of all deposits for drep credentials that are being + -- unregistered in this transaction + -> UTxO era + -- ^ Just the transaction inputs, not the entire 'UTxO'. -> TxBodyContent BuildTx era - -> AddressInEra era -- ^ Change address - -> Maybe Word -- ^ Override key witnesses + -> AddressInEra era + -- ^ Change address + -> Maybe Word + -- ^ Override key witnesses -> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era) -makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits - drepDelegDeposits utxo txbodycontent changeaddr mnkeys = - shelleyBasedEraConstraints sbe $ do - -- Our strategy is to: - -- 1. evaluate all the scripts to get the exec units, update with ex units - -- 2. figure out the overall min fees - -- 3. update tx with fees - -- 4. balance the transaction and update tx change output - txbody0 <- - first TxBodyError $ createAndValidateTransactionBody sbe txbodycontent - { txOuts = txOuts txbodycontent ++ - [TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone] - --TODO: think about the size of the change output - -- 1,2,4 or 8 bytes? - } - - exUnitsMapWithLogs <- first TxBodyErrorValidityInterval $ - evaluateTransactionExecutionUnits - era - systemstart history - lpp - utxo - txbody0 - let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs - - exUnitsMap' <- - case Map.mapEither id exUnitsMap of - (failures, exUnitsMap') -> - handleExUnitsErrors - (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) - failures - exUnitsMap' - - txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent - - -- Make a txbody that we will use for calculating the fees. For the purpose - -- of fees we just need to make a txbody of the right size in bytes. We do - -- not need the right values for the fee or change output. We use - -- "big enough" values for the change output and set so that the CBOR - -- encoding size of the tx will be big enough to cover the size of the final - -- output and fee. Yes this means this current code will only work for - -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output - -- of less than around 18 trillion ada (2^64-1 lovelace). - -- However, since at this point we know how much non-Ada change to give - -- we can use the true values for that. - let maxLovelaceChange = L.Coin (2^(64 :: Integer)) - 1 - let maxLovelaceFee = L.Coin (2^(32 :: Integer) - 1) - - let totalValueAtSpendableUTxO = fromLedgerValue sbe $ calculateIncomingUTxOValue $ Map.elems $ unUTxO utxo - let change = forShelleyBasedEraInEon sbe - mempty - (\w -> toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent1) - let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange - let changeTxOut = forShelleyBasedEraInEon sbe - (lovelaceToTxOutValue sbe maxLovelaceChange) - (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) - - let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr - txbody1 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody sbe txbodycontent1 { - txFee = TxFeeExplicit sbe maxLovelaceFee, - txOuts = TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone - : txOuts txbodycontent, - txReturnCollateral = dummyCollRet, - txTotalCollateral = dummyTotColl - } - -- NB: This has the potential to over estimate the fees because estimateTransactionKeyWitnessCount - -- makes the conservative assumption that all inputs are from distinct - -- addresses. - let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1) - mnkeys - fee = calculateMinTxFee sbe pp utxo txbody1 nkeys - (retColl, reqCol) = - caseShelleyToAlonzoOrBabbageEraOnwards - (const (TxReturnCollateralNone, TxTotalCollateralNone)) - (\w -> - let collIns = case txInsCollateral txbodycontent of - TxInsCollateral _ collIns' -> collIns' - TxInsCollateralNone -> mempty - collateralOuts = catMaybes [ Map.lookup txin (unUTxO utxo) | txin <- collIns] - totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts - in calcReturnAndTotalCollateral w - fee pp (txInsCollateral txbodycontent) (txReturnCollateral txbodycontent) - (txTotalCollateral txbodycontent) changeaddr totalPotentialCollateral - ) +makeTransactionBodyAutoBalance + sbe + systemstart + history + lpp@(LedgerProtocolParameters pp) + poolids + stakeDelegDeposits + drepDelegDeposits + utxo + txbodycontent + changeaddr + mnkeys = + shelleyBasedEraConstraints sbe $ do + -- Our strategy is to: + -- 1. evaluate all the scripts to get the exec units, update with ex units + -- 2. figure out the overall min fees + -- 3. update tx with fees + -- 4. balance the transaction and update tx change output + txbody0 <- + first TxBodyError $ + createAndValidateTransactionBody sbe - - -- Make a txbody for calculating the balance. For this the size of the tx - -- does not matter, instead it's just the values of the fee and outputs. - -- Here we do not want to start with any change output, since that's what - -- we need to calculate. - txbody2 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody sbe txbodycontent1 { - txFee = TxFeeExplicit sbe fee, - txReturnCollateral = retColl, - txTotalCollateral = reqCol - } - let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 - - forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp - - -- check if the balance is positive or negative - -- in one case we can produce change, in the other the inputs are insufficient - balanceCheck sbe pp changeaddr balance - - --TODO: we could add the extra fee for the CBOR encoding of the change, - -- now that we know the magnitude of the change: i.e. 1-8 bytes extra. - - -- The txbody with the final fee and change output. This should work - -- provided that the fee and change are less than 2^32-1, and so will - -- fit within the encoding size we picked above when calculating the fee. - -- Yes this could be an over-estimate by a few bytes if the fee or change - -- would fit within 2^16-1. That's a possible optimisation. - let finalTxBodyContent = txbodycontent1 { - txFee = TxFeeExplicit sbe fee, - txOuts = accountForNoChange - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent), - txReturnCollateral = retColl, - txTotalCollateral = reqCol - } - txbody3 <- - first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function - -- that simply creates a transaction body because we have already - -- validated the transaction body earlier within makeTransactionBodyAutoBalance - createAndValidateTransactionBody sbe finalTxBodyContent - return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) - where - era :: CardanoEra era - era = toCardanoEra sbe + txbodycontent + { txOuts = + txOuts txbodycontent + ++ [TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone] + -- TODO: think about the size of the change output + -- 1,2,4 or 8 bytes? + } + + exUnitsMapWithLogs <- + first TxBodyErrorValidityInterval $ + evaluateTransactionExecutionUnits + era + systemstart + history + lpp + utxo + txbody0 + let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs + + exUnitsMap' <- + case Map.mapEither id exUnitsMap of + (failures, exUnitsMap') -> + handleExUnitsErrors + (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) + failures + exUnitsMap' + + txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent + + -- Make a txbody that we will use for calculating the fees. For the purpose + -- of fees we just need to make a txbody of the right size in bytes. We do + -- not need the right values for the fee or change output. We use + -- "big enough" values for the change output and set so that the CBOR + -- encoding size of the tx will be big enough to cover the size of the final + -- output and fee. Yes this means this current code will only work for + -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output + -- of less than around 18 trillion ada (2^64-1 lovelace). + -- However, since at this point we know how much non-Ada change to give + -- we can use the true values for that. + let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1 + let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1) + + let totalValueAtSpendableUTxO = fromLedgerValue sbe $ calculateIncomingUTxOValue $ Map.elems $ unUTxO utxo + let change = + forShelleyBasedEraInEon + sbe + mempty + (\w -> toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent1) + let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange + let changeTxOut = + forShelleyBasedEraInEon + sbe + (lovelaceToTxOutValue sbe maxLovelaceChange) + (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) + + let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr + txbody1 <- + first TxBodyError $ -- TODO: impossible to fail now + createAndValidateTransactionBody + sbe + txbodycontent1 + { txFee = TxFeeExplicit sbe maxLovelaceFee + , txOuts = + TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone + : txOuts txbodycontent + , txReturnCollateral = dummyCollRet + , txTotalCollateral = dummyTotColl + } + -- NB: This has the potential to over estimate the fees because estimateTransactionKeyWitnessCount + -- makes the conservative assumption that all inputs are from distinct + -- addresses. + let nkeys = + fromMaybe + (estimateTransactionKeyWitnessCount txbodycontent1) + mnkeys + fee = calculateMinTxFee sbe pp utxo txbody1 nkeys + (retColl, reqCol) = + caseShelleyToAlonzoOrBabbageEraOnwards + (const (TxReturnCollateralNone, TxTotalCollateralNone)) + ( \w -> + let collIns = case txInsCollateral txbodycontent of + TxInsCollateral _ collIns' -> collIns' + TxInsCollateralNone -> mempty + collateralOuts = catMaybes [Map.lookup txin (unUTxO utxo) | txin <- collIns] + totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts + in calcReturnAndTotalCollateral + w + fee + pp + (txInsCollateral txbodycontent) + (txReturnCollateral txbodycontent) + (txTotalCollateral txbodycontent) + changeaddr + totalPotentialCollateral + ) + sbe + + -- Make a txbody for calculating the balance. For this the size of the tx + -- does not matter, instead it's just the values of the fee and outputs. + -- Here we do not want to start with any change output, since that's what + -- we need to calculate. + txbody2 <- + first TxBodyError $ -- TODO: impossible to fail now + createAndValidateTransactionBody + sbe + txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } + let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 + + forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe txout pp + + -- check if the balance is positive or negative + -- in one case we can produce change, in the other the inputs are insufficient + balanceCheck sbe pp changeaddr balance + + -- TODO: we could add the extra fee for the CBOR encoding of the change, + -- now that we know the magnitude of the change: i.e. 1-8 bytes extra. + + -- The txbody with the final fee and change output. This should work + -- provided that the fee and change are less than 2^32-1, and so will + -- fit within the encoding size we picked above when calculating the fee. + -- Yes this could be an over-estimate by a few bytes if the fee or change + -- would fit within 2^16-1. That's a possible optimisation. + let finalTxBodyContent = + txbodycontent1 + { txFee = TxFeeExplicit sbe fee + , txOuts = + accountForNoChange + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + (txOuts txbodycontent) + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } + txbody3 <- + first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function + -- that simply creates a transaction body because we have already + -- validated the transaction body earlier within makeTransactionBodyAutoBalance + createAndValidateTransactionBody sbe finalTxBodyContent + return + ( BalancedTxBody + finalTxBodyContent + txbody3 + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + fee + ) + where + era :: CardanoEra era + era = toCardanoEra sbe -- | In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change @@ -1123,10 +1218,10 @@ checkMinUTxOValue -> Ledger.PParams (ShelleyLedgerEra era) -> Either (TxBodyErrorAutoBalance era) () checkMinUTxOValue sbe txout@(TxOut _ v _ _) bpp = do - let minUTxO = calculateMinimumUTxO sbe txout bpp - if txOutValueToLovelace v >= minUTxO - then Right () - else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra (toCardanoEra sbe) txout) minUTxO + let minUTxO = calculateMinimumUTxO sbe txout bpp + if txOutValueToLovelace v >= minUTxO + then Right () + else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra (toCardanoEra sbe) txout) minUTxO balanceCheck :: ShelleyBasedEra era @@ -1135,15 +1230,15 @@ balanceCheck -> TxOutValue era -> Either (TxBodyErrorAutoBalance era) () balanceCheck sbe bpparams changeaddr balance - | txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return () - | txOutValueToLovelace balance < 0 = - Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance - | otherwise = - case checkMinUTxOValue sbe (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) bpparams of - Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) -> - Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance) - Left err -> Left err - Right _ -> Right () + | txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return () + | txOutValueToLovelace balance < 0 = + Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance + | otherwise = + case checkMinUTxOValue sbe (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) bpparams of + Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) -> + Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance) + Left err -> Left err + Right _ -> Right () isNotAda :: AssetId -> Bool isNotAda AdaAssetId = False @@ -1152,67 +1247,77 @@ isNotAda _ = True onlyAda :: Value -> Bool onlyAda = null . valueToList . filterValue isNotAda - calculateIncomingUTxOValue :: Monoid (Ledger.Value (ShelleyLedgerEra era)) => [TxOut ctx era] -> Ledger.Value (ShelleyLedgerEra era) calculateIncomingUTxOValue providedUtxoOuts = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- providedUtxoOuts] - -- Calculation taken from validateInsufficientCollateral: https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335 -- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral. -calcReturnAndTotalCollateral :: () - => Ledger.AlonzoEraPParams (ShelleyLedgerEra era) - => BabbageEraOnwards era - -> L.Coin -- ^ Fee - -> Ledger.PParams (ShelleyLedgerEra era) - -> TxInsCollateral era -- ^ From the initial TxBodyContent - -> TxReturnCollateral CtxTx era -- ^ From the initial TxBodyContent - -> TxTotalCollateral era -- ^ From the initial TxBodyContent - -> AddressInEra era -- ^ Change address - -> Coin -- ^ Total available collateral in lovelace - -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) -calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _= (TxReturnCollateralNone, TxTotalCollateralNone) -calcReturnAndTotalCollateral _ _ _ _ rc@TxReturnCollateral{} tc@TxTotalCollateral{} _ _ = (rc,tc) -calcReturnAndTotalCollateral retColSup fee pp' TxInsCollateral{} txReturnCollateral txTotalCollateral cAddr totalAvailableAda = - do - let colPerc = pp' ^. Ledger.ppCollateralPercentageL - -- We must first figure out how much lovelace we have committed - -- as collateral and we must determine if we have enough lovelace at our - -- collateral tx inputs to cover the tx - let totalCollateralLovelace = totalAvailableAda - requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee - totalCollateral = TxTotalCollateral retColSup . L.rationalToCoinViaCeiling - $ reqAmt % 100 - -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee - -- We choose to multiply 100 rather than divide by 100 to make the calculation - -- easier to manage. At the end of the calculation we then use % 100 to perform our division - -- and round the returnCollateral down which has the effect of potentially slightly - -- overestimating the required collateral. - L.Coin amt = totalCollateralLovelace * 100 - requiredCollateral - returnCollateral = L.rationalToCoinViaFloor $ amt % 100 - case (txReturnCollateral, txTotalCollateral) of +calcReturnAndTotalCollateral + :: () + => Ledger.AlonzoEraPParams (ShelleyLedgerEra era) + => BabbageEraOnwards era + -> L.Coin + -- ^ Fee + -> Ledger.PParams (ShelleyLedgerEra era) + -> TxInsCollateral era + -- ^ From the initial TxBodyContent + -> TxReturnCollateral CtxTx era + -- ^ From the initial TxBodyContent + -> TxTotalCollateral era + -- ^ From the initial TxBodyContent + -> AddressInEra era + -- ^ Change address + -> Coin + -- ^ Total available collateral in lovelace + -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) +calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _ = (TxReturnCollateralNone, TxTotalCollateralNone) +calcReturnAndTotalCollateral _ _ _ _ rc@TxReturnCollateral {} tc@TxTotalCollateral {} _ _ = (rc, tc) +calcReturnAndTotalCollateral retColSup fee pp' TxInsCollateral {} txReturnCollateral txTotalCollateral cAddr totalAvailableAda = + do + let colPerc = pp' ^. Ledger.ppCollateralPercentageL + -- We must first figure out how much lovelace we have committed + -- as collateral and we must determine if we have enough lovelace at our + -- collateral tx inputs to cover the tx + let totalCollateralLovelace = totalAvailableAda + requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee + totalCollateral = + TxTotalCollateral retColSup . L.rationalToCoinViaCeiling $ + reqAmt % 100 + -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee + -- We choose to multiply 100 rather than divide by 100 to make the calculation + -- easier to manage. At the end of the calculation we then use % 100 to perform our division + -- and round the returnCollateral down which has the effect of potentially slightly + -- overestimating the required collateral. + L.Coin amt = totalCollateralLovelace * 100 - requiredCollateral + returnCollateral = L.rationalToCoinViaFloor $ amt % 100 + case (txReturnCollateral, txTotalCollateral) of #if MIN_VERSION_base(4,16,0) #else - -- For ghc-9.2, this pattern match is redundant, but ghc-8.10 will complain if its missing. - (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> - (rc, tc) + -- For ghc-9.2, this pattern match is redundant, but ghc-8.10 will complain if its missing. + (rc@TxReturnCollateral {}, tc@TxTotalCollateral {}) -> + (rc, tc) #endif - (rc@TxReturnCollateral{}, TxTotalCollateralNone) -> - (rc, TxTotalCollateralNone) - (TxReturnCollateralNone, tc@TxTotalCollateral{}) -> - (TxReturnCollateralNone, tc) - (TxReturnCollateralNone, TxTotalCollateralNone) -> - if totalCollateralLovelace * 100 >= requiredCollateral - then - ( TxReturnCollateral - retColSup - (TxOut cAddr (lovelaceToTxOutValue (babbageEraOnwardsToShelleyBasedEra retColSup) returnCollateral) TxOutDatumNone ReferenceScriptNone) - , totalCollateral - ) - else (TxReturnCollateralNone, TxTotalCollateralNone) - + (rc@TxReturnCollateral {}, TxTotalCollateralNone) -> + (rc, TxTotalCollateralNone) + (TxReturnCollateralNone, tc@TxTotalCollateral {}) -> + (TxReturnCollateralNone, tc) + (TxReturnCollateralNone, TxTotalCollateralNone) -> + if totalCollateralLovelace * 100 >= requiredCollateral + then + ( TxReturnCollateral + retColSup + ( TxOut + cAddr + (lovelaceToTxOutValue (babbageEraOnwardsToShelleyBasedEra retColSup) returnCollateral) + TxOutDatumNone + ReferenceScriptNone + ) + , totalCollateral + ) + else (TxReturnCollateralNone, TxTotalCollateralNone) calculateCreatedUTOValue :: ShelleyBasedEra era -> TxBodyContent build era -> Value @@ -1222,11 +1327,11 @@ calculateCreatedUTOValue sbe txbodycontent = calculateChangeValue :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value calculateChangeValue sbe incoming txbodycontent = - let outgoing = calculateCreatedUTOValue sbe txbodycontent - minted = case txMintValue txbodycontent of - TxMintNone -> mempty - TxMintValue _ v _ -> v - in mconcat [incoming, minted, negateValue outgoing] + let outgoing = calculateCreatedUTOValue sbe txbodycontent + minted = case txMintValue txbodycontent of + TxMintNone -> mempty + TxMintValue _ v _ -> v + in mconcat [incoming, minted, negateValue outgoing] -- | This is used in the balance calculation in the event where -- the user does not supply the UTxO(s) they intend to spend @@ -1240,15 +1345,18 @@ calculateChangeValue sbe incoming txbodycontent = createFakeUTxO :: ShelleyBasedEra era -> TxBodyContent BuildTx era -> Coin -> UTxO era createFakeUTxO sbe txbodycontent totalAdaInUTxO = let singleTxIn = maybe [] (return . fst) $ List.uncons [txin | (txin, _) <- txIns txbodycontent] - singleTxOut = maybe [] (return . updateTxOut sbe totalAdaInUTxO . toCtxUTxOTxOut . fst) $ List.uncons $ txOuts txbodycontent - -- Take one txin and one txout. Replace the out value with totalAdaInUTxO + singleTxOut = + maybe [] (return . updateTxOut sbe totalAdaInUTxO . toCtxUTxOTxOut . fst) $ + List.uncons $ + txOuts txbodycontent + in -- Take one txin and one txout. Replace the out value with totalAdaInUTxO -- Return an empty UTxO if there are no txins or txouts - in UTxO $ Map.fromList $ zip singleTxIn singleTxOut + UTxO $ Map.fromList $ zip singleTxIn singleTxOut updateTxOut :: ShelleyBasedEra era -> Coin -> TxOut CtxUTxO era -> TxOut CtxUTxO era updateTxOut sbe updatedValue txout = let ledgerout = shelleyBasedEraConstraints sbe $ toShelleyTxOut sbe txout & L.coinTxOutL .~ updatedValue - in fromShelleyTxOut sbe ledgerout + in fromShelleyTxOut sbe ledgerout -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values @@ -1259,73 +1367,90 @@ maybeDummyTotalCollAndCollReturnOutput -> TxBodyContent BuildTx era -> AddressInEra era -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) -maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txReturnCollateral, txTotalCollateral} cAddr = +maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent {txInsCollateral, txReturnCollateral, txTotalCollateral} cAddr = case txInsCollateral of TxInsCollateralNone -> (TxReturnCollateralNone, TxTotalCollateralNone) - TxInsCollateral{} -> - forShelleyBasedEraInEon sbe - (TxReturnCollateralNone, TxTotalCollateralNone) - (\w -> - let dummyRetCol = - TxReturnCollateral w - ( TxOut cAddr - (lovelaceToTxOutValue sbe $ L.Coin (2^(64 :: Integer)) - 1) - TxOutDatumNone ReferenceScriptNone - ) - dummyTotCol = TxTotalCollateral w (L.Coin (2^(32 :: Integer) - 1)) - in case (txReturnCollateral, txTotalCollateral) of - (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> (rc, tc) - (rc@TxReturnCollateral{},TxTotalCollateralNone) -> (rc, dummyTotCol) - (TxReturnCollateralNone,tc@TxTotalCollateral{}) -> (dummyRetCol, tc) - (TxReturnCollateralNone, TxTotalCollateralNone) -> (dummyRetCol, dummyTotCol) - ) - - -substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits - -> TxBodyContent BuildTx era - -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) + TxInsCollateral {} -> + forShelleyBasedEraInEon + sbe + (TxReturnCollateralNone, TxTotalCollateralNone) + ( \w -> + let dummyRetCol = + TxReturnCollateral + w + ( TxOut + cAddr + (lovelaceToTxOutValue sbe $ L.Coin (2 ^ (64 :: Integer)) - 1) + TxOutDatumNone + ReferenceScriptNone + ) + dummyTotCol = TxTotalCollateral w (L.Coin (2 ^ (32 :: Integer) - 1)) + in case (txReturnCollateral, txTotalCollateral) of + (rc@TxReturnCollateral {}, tc@TxTotalCollateral {}) -> (rc, tc) + (rc@TxReturnCollateral {}, TxTotalCollateralNone) -> (rc, dummyTotCol) + (TxReturnCollateralNone, tc@TxTotalCollateral {}) -> (dummyRetCol, tc) + (TxReturnCollateralNone, TxTotalCollateralNone) -> (dummyRetCol, dummyTotCol) + ) + +substituteExecutionUnits + :: Map ScriptWitnessIndex ExecutionUnits + -> TxBodyContent BuildTx era + -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) substituteExecutionUnits exUnitsMap = - mapTxScriptWitnesses f - where - f :: ScriptWitnessIndex - -> ScriptWitness witctx era - -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era) - f _ wit@SimpleScriptWitness{} = Right wit - f idx (PlutusScriptWitness langInEra version script datum redeemer _) = - case Map.lookup idx exUnitsMap of - Nothing -> - Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap - Just exunits -> Right $ PlutusScriptWitness langInEra version script - datum redeemer exunits + mapTxScriptWitnesses f + where + f + :: ScriptWitnessIndex + -> ScriptWitness witctx era + -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era) + f _ wit@SimpleScriptWitness {} = Right wit + f idx (PlutusScriptWitness langInEra version script datum redeemer _) = + case Map.lookup idx exUnitsMap of + Nothing -> + Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap + Just exunits -> + Right $ + PlutusScriptWitness + langInEra + version + script + datum + redeemer + exunits + mapTxScriptWitnesses - :: forall era. - (forall witctx. ScriptWitnessIndex - -> ScriptWitness witctx era - -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) + :: forall era + . ( forall witctx + . ScriptWitnessIndex + -> ScriptWitness witctx era + -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era) + ) -> TxBodyContent BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) -mapTxScriptWitnesses f txbodycontent@TxBodyContent { - txIns, - txWithdrawals, - txCertificates, - txMintValue - } = do +mapTxScriptWitnesses + f + txbodycontent@TxBodyContent + { txIns + , txWithdrawals + , txCertificates + , txMintValue + } = do mappedTxIns <- mapScriptWitnessesTxIns txIns mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals mappedMintedVals <- mapScriptWitnessesMinting txMintValue mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates - Right $ txbodycontent - & setTxIns mappedTxIns - & setTxMintValue mappedMintedVals - & setTxCertificates mappedTxCertificates - & setTxWithdrawals mappedWithdrawals - - where + Right $ + txbodycontent + & setTxIns mappedTxIns + & setTxMintValue mappedMintedVals + & setTxCertificates mappedTxCertificates + & setTxWithdrawals mappedWithdrawals + where mapScriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] -> Either (TxBodyErrorAutoBalance era) [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] - mapScriptWitnessesTxIns txins = + mapScriptWitnessesTxIns txins = let mappedScriptWitnesses :: [ ( TxIn , Either (TxBodyErrorAutoBalance era) (BuildTxWith BuildTx (Witness WitCtxTxIn era)) @@ -1333,98 +1458,117 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { ] mappedScriptWitnesses = [ (txin, BuildTxWith <$> wit') - -- The tx ins are indexed in the map order by txid - | (ix, (txin, BuildTxWith wit)) <- zip [0..] (orderTxIns txins) + | -- The tx ins are indexed in the map order by txid + (ix, (txin, BuildTxWith wit)) <- zip [0 ..] (orderTxIns txins) , let wit' = case wit of - KeyWitness{} -> Right wit - ScriptWitness ctx witness -> ScriptWitness ctx <$> witness' - where - witness' = f (ScriptWitnessIndexTxIn ix) witness + KeyWitness {} -> Right wit + ScriptWitness ctx witness -> ScriptWitness ctx <$> witness' + where + witness' = f (ScriptWitnessIndexTxIn ix) witness ] - in traverse ( \(txIn, eWitness) -> - case eWitness of - Left e -> Left e - Right wit -> Right (txIn, wit) - ) mappedScriptWitnesses + in traverse + ( \(txIn, eWitness) -> + case eWitness of + Left e -> Left e + Right wit -> Right (txIn, wit) + ) + mappedScriptWitnesses mapScriptWitnessesWithdrawals :: TxWithdrawals BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxWithdrawals BuildTx era) - mapScriptWitnessesWithdrawals TxWithdrawalsNone = Right TxWithdrawalsNone + mapScriptWitnessesWithdrawals TxWithdrawalsNone = Right TxWithdrawalsNone mapScriptWitnessesWithdrawals (TxWithdrawals supported withdrawals) = let mappedWithdrawals - :: [( StakeAddress - , L.Coin - , Either (TxBodyErrorAutoBalance era) (BuildTxWith BuildTx (Witness WitCtxStake era)) - )] + :: [ ( StakeAddress + , L.Coin + , Either (TxBodyErrorAutoBalance era) (BuildTxWith BuildTx (Witness WitCtxStake era)) + ) + ] mappedWithdrawals = - [ (addr, withdrawal, BuildTxWith <$> mappedWitness) - -- The withdrawals are indexed in the map order by stake credential - | (ix, (addr, withdrawal, BuildTxWith wit)) <- zip [0..] (orderStakeAddrs withdrawals) - , let mappedWitness = adjustWitness (f (ScriptWitnessIndexWithdrawal ix)) wit - ] - in TxWithdrawals supported - <$> traverse ( \(sAddr, ll, eWitness) -> - case eWitness of - Left e -> Left e - Right wit -> Right (sAddr, ll, wit) - ) mappedWithdrawals - where - adjustWitness - :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) - -> Witness witctx era - -> Either (TxBodyErrorAutoBalance era) (Witness witctx era) - adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx - adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' + [ (addr, withdrawal, BuildTxWith <$> mappedWitness) + | -- The withdrawals are indexed in the map order by stake credential + (ix, (addr, withdrawal, BuildTxWith wit)) <- zip [0 ..] (orderStakeAddrs withdrawals) + , let mappedWitness = adjustWitness (f (ScriptWitnessIndexWithdrawal ix)) wit + ] + in TxWithdrawals supported + <$> traverse + ( \(sAddr, ll, eWitness) -> + case eWitness of + Left e -> Left e + Right wit -> Right (sAddr, ll, wit) + ) + mappedWithdrawals + where + adjustWitness + :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) + -> Witness witctx era + -> Either (TxBodyErrorAutoBalance era) (Witness witctx era) + adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx + adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' mapScriptWitnessesCertificates :: TxCertificates BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era) mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates (TxCertificates supported certs - (BuildTxWith witnesses)) = - let mappedScriptWitnesses - :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] - mappedScriptWitnesses = + mapScriptWitnessesCertificates + ( TxCertificates + supported + certs + (BuildTxWith witnesses) + ) = + let mappedScriptWitnesses + :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] + mappedScriptWitnesses = [ (stakecred, ScriptWitness ctx <$> witness') - -- The certs are indexed in list order - | (ix, cert) <- zip [0..] certs - , stakecred <- maybeToList (selectStakeCredentialWitness cert) - , ScriptWitness ctx witness - <- maybeToList (Map.lookup stakecred witnesses) + | -- The certs are indexed in list order + (ix, cert) <- zip [0 ..] certs + , stakecred <- maybeToList (selectStakeCredentialWitness cert) + , ScriptWitness ctx witness <- + maybeToList (Map.lookup stakecred witnesses) , let witness' = f (ScriptWitnessIndexCertificate ix) witness ] - in TxCertificates supported certs . BuildTxWith . Map.fromList <$> - traverse ( \(sCred, eScriptWitness) -> - case eScriptWitness of - Left e -> Left e - Right wit -> Right (sCred, wit) - ) mappedScriptWitnesses + in TxCertificates supported certs . BuildTxWith . Map.fromList + <$> traverse + ( \(sCred, eScriptWitness) -> + case eScriptWitness of + Left e -> Left e + Right wit -> Right (sCred, wit) + ) + mappedScriptWitnesses mapScriptWitnessesMinting :: TxMintValue BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era) - mapScriptWitnessesMinting TxMintNone = Right TxMintNone - mapScriptWitnessesMinting (TxMintValue supported value - (BuildTxWith witnesses)) = - --TxMintValue supported value $ BuildTxWith $ Map.fromList - let mappedScriptWitnesses - :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] - mappedScriptWitnesses = - [ (policyid, witness') - -- The minting policies are indexed in policy id order in the value - | let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) - , let witness' = f (ScriptWitnessIndexMint ix) witness - ] - in do final <- traverse ( \(pid, eScriptWitness) -> - case eScriptWitness of - Left e -> Left e - Right wit -> Right (pid, wit) - ) mappedScriptWitnesses - Right . TxMintValue supported value . BuildTxWith - $ Map.fromList final + mapScriptWitnessesMinting TxMintNone = Right TxMintNone + mapScriptWitnessesMinting + ( TxMintValue + supported + value + (BuildTxWith witnesses) + ) = + -- TxMintValue supported value $ BuildTxWith $ Map.fromList + let mappedScriptWitnesses + :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] + mappedScriptWitnesses = + [ (policyid, witness') + | -- The minting policies are indexed in policy id order in the value + let ValueNestedRep bundle = valueToNestedRep value + , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle + , witness <- maybeToList (Map.lookup policyid witnesses) + , let witness' = f (ScriptWitnessIndexMint ix) witness + ] + in do + final <- + traverse + ( \(pid, eScriptWitness) -> + case eScriptWitness of + Left e -> Left e + Right wit -> Right (pid, wit) + ) + mappedScriptWitnesses + Right . TxMintValue supported value . BuildTxWith $ + Map.fromList final calculateMinimumUTxO :: ShelleyBasedEra era @@ -1432,6 +1576,6 @@ calculateMinimumUTxO -> Ledger.PParams (ShelleyLedgerEra era) -> L.Coin calculateMinimumUTxO sbe txout pp = - shelleyBasedEraConstraints sbe - $ let txOutWithMinCoin = L.setMinCoinTxOut pp (toShelleyTxOutAny sbe txout) - in txOutWithMinCoin ^. L.coinTxOutL + shelleyBasedEraConstraints sbe $ + let txOutWithMinCoin = L.setMinCoinTxOut pp (toShelleyTxOutAny sbe txout) + in txOutWithMinCoin ^. L.coinTxOutL diff --git a/cardano-api/internal/Cardano/Api/Genesis.hs b/cardano-api/internal/Cardano/Api/Genesis.hs index fc8962c729..598cf426fb 100644 --- a/cardano-api/internal/Cardano/Api/Genesis.hs +++ b/cardano-api/internal/Cardano/Api/Genesis.hs @@ -2,68 +2,71 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} module Cardano.Api.Genesis - ( ShelleyGenesis(..) + ( ShelleyGenesis (..) , shelleyGenesisDefaults , alonzoGenesisDefaults , conwayGenesisDefaults - -- ** Configuration + -- ** Configuration , ByronGenesisConfig , ShelleyGenesisConfig , AlonzoGenesisConfig , ConwayGenesisConfig + , ShelleyConfig (..) + , GenesisHashByron (..) + , GenesisHashShelley (..) + , GenesisHashAlonzo (..) + , GenesisHashConway (..) - , ShelleyConfig(..) - , GenesisHashByron(..) - , GenesisHashShelley(..) - , GenesisHashAlonzo(..) - , GenesisHashConway(..) - - -- ** Files + -- ** Files , ByronGenesisFile , ShelleyGenesisFile , AlonzoGenesisFile , ConwayGenesisFile - ) where - -import Cardano.Api.IO -import Cardano.Api.Utils (unsafeBoundedRational) + ) +where +import Cardano.Api.IO +import Cardano.Api.Utils (unsafeBoundedRational) import qualified Cardano.Chain.Genesis import qualified Cardano.Crypto.Hash.Blake2b import qualified Cardano.Crypto.Hash.Class -import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) -import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), Prices (..)) -import Cardano.Ledger.Api (CoinPerWord (..)) -import Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) -import Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..), - PoolVotingThresholds (..), UpgradeConwayPParams (..)) -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Plutus (Language (..)) -import Cardano.Ledger.Plutus.CostModels (mkCostModelsLenient) -import Cardano.Ledger.Shelley.Core -import Cardano.Ledger.Shelley.Genesis (NominalDiffTimeMicro, ShelleyGenesis (..), - emptyGenesisStaking) +import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) +import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), Prices (..)) +import Cardano.Ledger.Api (CoinPerWord (..)) +import Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.PParams + ( DRepVotingThresholds (..) + , PoolVotingThresholds (..) + , UpgradeConwayPParams (..) + ) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Plutus (Language (..)) +import Cardano.Ledger.Plutus.CostModels (mkCostModelsLenient) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.Genesis + ( NominalDiffTimeMicro + , ShelleyGenesis (..) + , emptyGenesisStaking + ) import qualified Cardano.Ledger.Shelley.Genesis as Ledger -import qualified Ouroboros.Consensus.Shelley.Eras as Shelley - -import Control.Monad.Trans.Fail.String (errorFail) -import Data.ByteString (ByteString) +import Control.Monad.Trans.Fail.String (errorFail) +import Data.ByteString (ByteString) import qualified Data.Default.Class as DefaultClass -import Data.Functor.Identity (Identity) +import Data.Functor.Identity (Identity) import qualified Data.ListMap as ListMap import qualified Data.Map.Strict as Map -import Data.Ratio -import Data.Text (Text) +import Data.Ratio +import Data.Text (Text) import qualified Data.Time as Time -import Data.Typeable -import GHC.Stack (HasCallStack) -import Lens.Micro - -import Test.Cardano.Ledger.Core.Rational ((%!)) -import Test.Cardano.Ledger.Plutus (testingCostModelV3) +import Data.Typeable +import GHC.Stack (HasCallStack) +import Lens.Micro +import qualified Ouroboros.Consensus.Shelley.Eras as Shelley +import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Cardano.Ledger.Plutus (testingCostModelV3) data ShelleyConfig = ShelleyConfig { scConfig :: !(Ledger.ShelleyGenesis Shelley.StandardCrypto) @@ -72,28 +75,41 @@ data ShelleyConfig = ShelleyConfig newtype GenesisHashByron = GenesisHashByron { unGenesisHashByron :: Text - } deriving newtype (Eq, Show) + } + deriving newtype (Eq, Show) newtype GenesisHashShelley = GenesisHashShelley - { unGenesisHashShelley :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString - } deriving newtype (Eq, Show) + { unGenesisHashShelley + :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString + } + deriving newtype (Eq, Show) newtype GenesisHashAlonzo = GenesisHashAlonzo - { unGenesisHashAlonzo :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString - } deriving newtype (Eq, Show) + { unGenesisHashAlonzo + :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString + } + deriving newtype (Eq, Show) newtype GenesisHashConway = GenesisHashConway - { unGenesisHashConway :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString - } deriving newtype (Eq, Show) + { unGenesisHashConway + :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString + } + deriving newtype (Eq, Show) type ByronGenesisConfig = Cardano.Chain.Genesis.Config + type ShelleyGenesisConfig = ShelleyConfig + type AlonzoGenesisConfig = AlonzoGenesis + type ConwayGenesisConfig = ConwayGenesis Shelley.StandardCrypto type ByronGenesisFile = File ByronGenesisConfig + type ShelleyGenesisFile = File ShelleyGenesisConfig + type AlonzoGenesisFile = File AlonzoGenesisConfig + type ConwayGenesisFile = File ConwayGenesisConfig -- | Some reasonable starting defaults for constructing a 'ShelleyGenesis'. @@ -106,140 +122,474 @@ type ConwayGenesisFile = File ConwayGenesisConfig -- * 'sgInitialFunds' to have any money in the system -- * 'sgMaxLovelaceSupply' must be at least the sum of the 'sgInitialFunds' -- but more if you want to allow for rewards. --- shelleyGenesisDefaults :: ShelleyGenesis StandardCrypto shelleyGenesisDefaults = ShelleyGenesis - { - -- parameters for this specific chain - sgSystemStart = zeroTime - , sgNetworkMagic = 42 - , sgNetworkId = Ledger.Testnet - - -- consensus protocol parameters - , sgSlotLength = 1.0 :: NominalDiffTimeMicro -- 1s slots - , sgActiveSlotsCoeff = unsafeBR (1 % 20) -- f ; 1/f = 20s block times on average - , sgSecurityParam = k - , sgEpochLength = Ledger.EpochSize (k * 10 * 20) -- 10k/f - , sgSlotsPerKESPeriod = 60 * 60 * 36 -- 1.5 days with 1s slots - , sgMaxKESEvolutions = 60 -- 90 days - , sgUpdateQuorum = 5 -- assuming 7 genesis keys - - -- ledger protocol parameters - , sgProtocolParams = + { -- parameters for this specific chain + sgSystemStart = zeroTime + , sgNetworkMagic = 42 + , sgNetworkId = Ledger.Testnet + , -- consensus protocol parameters + sgSlotLength = 1.0 :: NominalDiffTimeMicro -- 1s slots + , sgActiveSlotsCoeff = unsafeBR (1 % 20) -- f ; 1/f = 20s block times on average + , sgSecurityParam = k + , sgEpochLength = Ledger.EpochSize (k * 10 * 20) -- 10k/f + , sgSlotsPerKESPeriod = 60 * 60 * 36 -- 1.5 days with 1s slots + , sgMaxKESEvolutions = 60 -- 90 days + , sgUpdateQuorum = 5 -- assuming 7 genesis keys + , -- ledger protocol parameters + sgProtocolParams = emptyPParams - & ppDL .~ maxBound - & ppMaxBHSizeL .~ 1100 -- TODO: compute from crypto - & ppMaxBBSizeL .~ 64 * 1024 -- max 64kb blocks - & ppMaxTxSizeL .~ 16 * 1024 -- max 16kb txs - & ppEMaxL .~ EpochInterval 18 - & ppMinFeeAL .~ Coin 1 -- The linear factor for the minimum fee calculation - & ppMinFeeBL .~ Coin 0 -- The constant factor for the minimum fee calculation - -- pot = tx_fees + ρ * remaining_reserves - & ppRhoL .~ unsafeBR (1 % 10) -- How much of reserves goes into pot - & ppTauL .~ unsafeBR (1 % 10) -- τ * remaining_reserves is sent to treasury every epoch - - -- genesis keys and initial funds - , sgGenDelegs = Map.empty - , sgStaking = emptyGenesisStaking - , sgInitialFunds = ListMap.empty - , sgMaxLovelaceSupply = 0 + & ppDL .~ maxBound + & ppMaxBHSizeL .~ 1100 -- TODO: compute from crypto + & ppMaxBBSizeL .~ 64 * 1024 -- max 64kb blocks + & ppMaxTxSizeL .~ 16 * 1024 -- max 16kb txs + & ppEMaxL .~ EpochInterval 18 + & ppMinFeeAL .~ Coin 1 -- The linear factor for the minimum fee calculation + & ppMinFeeBL .~ Coin 0 -- The constant factor for the minimum fee calculation + -- pot = tx_fees + ρ * remaining_reserves + & ppRhoL .~ unsafeBR (1 % 10) -- How much of reserves goes into pot + & ppTauL .~ unsafeBR (1 % 10) -- τ * remaining_reserves is sent to treasury every epoch + , -- genesis keys and initial funds + sgGenDelegs = Map.empty + , sgStaking = emptyGenesisStaking + , sgInitialFunds = ListMap.empty + , sgMaxLovelaceSupply = 0 } - where - k = 2160 - zeroTime = Time.UTCTime (Time.fromGregorian 1970 1 1) 0 -- tradition - unsafeBR :: (HasCallStack, Typeable r, BoundedRational r) => Rational -> r - unsafeBR = unsafeBoundedRational + where + k = 2160 + zeroTime = Time.UTCTime (Time.fromGregorian 1970 1 1) 0 -- tradition + unsafeBR :: (HasCallStack, Typeable r, BoundedRational r) => Rational -> r + unsafeBR = unsafeBoundedRational -- | Some reasonable starting defaults for constructing a 'ConwayGenesis'. -- | Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs conwayGenesisDefaults :: ConwayGenesis StandardCrypto -conwayGenesisDefaults = ConwayGenesis { cgUpgradePParams = defaultUpgradeConwayParams - , cgConstitution = DefaultClass.def - , cgCommittee = DefaultClass.def - , cgDelegs = mempty - , cgInitialDReps = mempty - } - where +conwayGenesisDefaults = + ConwayGenesis + { cgUpgradePParams = defaultUpgradeConwayParams + , cgConstitution = DefaultClass.def + , cgCommittee = DefaultClass.def + , cgDelegs = mempty + , cgInitialDReps = mempty + } + where defaultUpgradeConwayParams :: UpgradeConwayPParams Identity - defaultUpgradeConwayParams = UpgradeConwayPParams { ucppPoolVotingThresholds = defaultPoolVotingThresholds - , ucppGovActionLifetime = EpochInterval 1 - , ucppGovActionDeposit = Coin 1000000 - , ucppDRepVotingThresholds = defaultDRepVotingThresholds - , ucppDRepDeposit = Coin 1000000 - , ucppDRepActivity = EpochInterval 100 - , ucppCommitteeMinSize = 0 - , ucppCommitteeMaxTermLength = EpochInterval 200 - , ucppMinFeeRefScriptCostPerByte = 0 %! 1 -- TODO: set to correct value after benchmarking - , ucppPlutusV3CostModel = testingCostModelV3 - } - where + defaultUpgradeConwayParams = + UpgradeConwayPParams + { ucppPoolVotingThresholds = defaultPoolVotingThresholds + , ucppGovActionLifetime = EpochInterval 1 + , ucppGovActionDeposit = Coin 1000000 + , ucppDRepVotingThresholds = defaultDRepVotingThresholds + , ucppDRepDeposit = Coin 1000000 + , ucppDRepActivity = EpochInterval 100 + , ucppCommitteeMinSize = 0 + , ucppCommitteeMaxTermLength = EpochInterval 200 + , ucppMinFeeRefScriptCostPerByte = 0 %! 1 -- TODO: set to correct value after benchmarking + , ucppPlutusV3CostModel = testingCostModelV3 + } + where defaultPoolVotingThresholds :: PoolVotingThresholds - defaultPoolVotingThresholds = PoolVotingThresholds { pvtPPSecurityGroup = 1 %! 2 - , pvtMotionNoConfidence = 1 %! 2 - , pvtHardForkInitiation = 1 %! 2 - , pvtCommitteeNormal = 1 %! 2 - , pvtCommitteeNoConfidence = 1 %! 2 - } + defaultPoolVotingThresholds = + PoolVotingThresholds + { pvtPPSecurityGroup = 1 %! 2 + , pvtMotionNoConfidence = 1 %! 2 + , pvtHardForkInitiation = 1 %! 2 + , pvtCommitteeNormal = 1 %! 2 + , pvtCommitteeNoConfidence = 1 %! 2 + } defaultDRepVotingThresholds :: DRepVotingThresholds - defaultDRepVotingThresholds = DRepVotingThresholds { dvtUpdateToConstitution = 0 %! 1 - , dvtTreasuryWithdrawal = 1 %! 2 - , dvtPPTechnicalGroup = 1 %! 2 - , dvtPPNetworkGroup = 1 %! 2 - , dvtPPGovGroup = 1 %! 2 - , dvtPPEconomicGroup = 1 %! 2 - , dvtMotionNoConfidence = 0 %! 1 - , dvtHardForkInitiation = 1 %! 2 - , dvtCommitteeNormal = 1 %! 2 - , dvtCommitteeNoConfidence = 0 %! 1 - } + defaultDRepVotingThresholds = + DRepVotingThresholds + { dvtUpdateToConstitution = 0 %! 1 + , dvtTreasuryWithdrawal = 1 %! 2 + , dvtPPTechnicalGroup = 1 %! 2 + , dvtPPNetworkGroup = 1 %! 2 + , dvtPPGovGroup = 1 %! 2 + , dvtPPEconomicGroup = 1 %! 2 + , dvtMotionNoConfidence = 0 %! 1 + , dvtHardForkInitiation = 1 %! 2 + , dvtCommitteeNormal = 1 %! 2 + , dvtCommitteeNoConfidence = 0 %! 1 + } -- | Some reasonable starting defaults for constructing a 'AlonzoGenesis'. -- | Based on https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Defaults.hs alonzoGenesisDefaults :: AlonzoGenesis -alonzoGenesisDefaults = AlonzoGenesis { agPrices = Prices { prSteps = 721 %! 10000000 - , prMem = 577 %! 10000 - } - , agMaxValSize = 5000 - , agMaxTxExUnits = ExUnits { exUnitsMem = 140000000 - , exUnitsSteps = 10000000000 - } - , agMaxCollateralInputs = 3 - , agMaxBlockExUnits = ExUnits { exUnitsMem = 62000000 - , exUnitsSteps = 20000000000 - } - , agCostModels = errorFail apiCostModels - , agCollateralPercentage = 150 - , agCoinsPerUTxOWord = CoinPerWord $ Coin 34482 - } - where - apiCostModels = mkCostModelsLenient $ Map.fromList [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel) - , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel) - ] - where - defaultV1CostModel = [ 205665, 812, 1, 1, 1000, 571, 0, 1, 1000, 24177, 4, 1, 1000, 32, 117366, 10475, 4 - , 23000, 100, 23000, 100, 23000, 100, 23000, 100, 23000, 100, 23000, 100, 100, 100 - , 23000, 100, 19537, 32, 175354, 32, 46417, 4, 221973, 511, 0, 1, 89141, 32, 497525 - , 14068, 4, 2, 196500, 453240, 220, 0, 1, 1, 1000, 28662, 4, 2, 245000, 216773, 62 - , 1, 1060367, 12586, 1, 208512, 421, 1, 187000, 1000, 52998, 1, 80436, 32, 43249, 32 - , 1000, 32, 80556, 1, 57667, 4, 1000, 10, 197145, 156, 1, 197145, 156, 1, 204924, 473 - , 1, 208896, 511, 1, 52467, 32, 64832, 32, 65493, 32, 22558, 32, 16563, 32, 76511, 32 - , 196500, 453240, 220, 0, 1, 1, 69522, 11687, 0, 1, 60091, 32, 196500, 453240, 220, 0 - , 1, 1, 196500, 453240, 220, 0, 1, 1, 806990, 30482, 4, 1927926, 82523, 4, 265318, 0 - , 4, 0, 85931, 32, 205665, 812, 1, 1, 41182, 32, 212342, 32, 31220, 32, 32696, 32, 43357 - , 32, 32247, 32, 38314, 32, 57996947, 18975, 10 - ] - defaultV2CostModel = [ 205665, 812, 1, 1, 1000, 571, 0, 1, 1000, 24177, 4, 1, 1000, 32, 117366, 10475, 4 - , 23000, 100, 23000, 100, 23000, 100, 23000, 100, 23000, 100, 23000, 100, 100, 100 - , 23000, 100, 19537, 32, 175354, 32, 46417, 4, 221973, 511, 0, 1, 89141, 32, 497525 - , 14068, 4, 2, 196500, 453240, 220, 0, 1, 1, 1000, 28662, 4, 2, 245000, 216773, 62 - , 1, 1060367, 12586, 1, 208512, 421, 1, 187000, 1000, 52998, 1, 80436, 32, 43249, 32 - , 1000, 32, 80556, 1, 57667, 4, 1000, 10, 197145, 156, 1, 197145, 156, 1, 204924, 473 - , 1, 208896, 511, 1, 52467, 32, 64832, 32, 65493, 32, 22558, 32, 16563, 32, 76511, 32 - , 196500, 453240, 220, 0, 1, 1, 69522, 11687, 0, 1, 60091, 32, 196500, 453240, 220, 0 - , 1, 1, 196500, 453240, 220, 0, 1, 1, 1159724, 392670, 0, 2, 806990, 30482, 4, 1927926 - , 82523, 4, 265318, 0, 4, 0, 85931, 32, 205665, 812, 1, 1, 41182, 32, 212342, 32, 31220 - , 32, 32696, 32, 43357, 32, 32247, 32, 38314, 32, 35892428, 10, 9462713, 1021, 10, 38887044 - , 32947, 10 - ] +alonzoGenesisDefaults = + AlonzoGenesis + { agPrices = + Prices + { prSteps = 721 %! 10000000 + , prMem = 577 %! 10000 + } + , agMaxValSize = 5000 + , agMaxTxExUnits = + ExUnits + { exUnitsMem = 140000000 + , exUnitsSteps = 10000000000 + } + , agMaxCollateralInputs = 3 + , agMaxBlockExUnits = + ExUnits + { exUnitsMem = 62000000 + , exUnitsSteps = 20000000000 + } + , agCostModels = errorFail apiCostModels + , agCollateralPercentage = 150 + , agCoinsPerUTxOWord = CoinPerWord $ Coin 34482 + } + where + apiCostModels = + mkCostModelsLenient $ + Map.fromList + [ (fromIntegral $ fromEnum PlutusV1, defaultV1CostModel) + , (fromIntegral $ fromEnum PlutusV2, defaultV2CostModel) + ] + where + defaultV1CostModel = + [ 205665 + , 812 + , 1 + , 1 + , 1000 + , 571 + , 0 + , 1 + , 1000 + , 24177 + , 4 + , 1 + , 1000 + , 32 + , 117366 + , 10475 + , 4 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 100 + , 100 + , 23000 + , 100 + , 19537 + , 32 + , 175354 + , 32 + , 46417 + , 4 + , 221973 + , 511 + , 0 + , 1 + , 89141 + , 32 + , 497525 + , 14068 + , 4 + , 2 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 1000 + , 28662 + , 4 + , 2 + , 245000 + , 216773 + , 62 + , 1 + , 1060367 + , 12586 + , 1 + , 208512 + , 421 + , 1 + , 187000 + , 1000 + , 52998 + , 1 + , 80436 + , 32 + , 43249 + , 32 + , 1000 + , 32 + , 80556 + , 1 + , 57667 + , 4 + , 1000 + , 10 + , 197145 + , 156 + , 1 + , 197145 + , 156 + , 1 + , 204924 + , 473 + , 1 + , 208896 + , 511 + , 1 + , 52467 + , 32 + , 64832 + , 32 + , 65493 + , 32 + , 22558 + , 32 + , 16563 + , 32 + , 76511 + , 32 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 69522 + , 11687 + , 0 + , 1 + , 60091 + , 32 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 806990 + , 30482 + , 4 + , 1927926 + , 82523 + , 4 + , 265318 + , 0 + , 4 + , 0 + , 85931 + , 32 + , 205665 + , 812 + , 1 + , 1 + , 41182 + , 32 + , 212342 + , 32 + , 31220 + , 32 + , 32696 + , 32 + , 43357 + , 32 + , 32247 + , 32 + , 38314 + , 32 + , 57996947 + , 18975 + , 10 + ] + defaultV2CostModel = + [ 205665 + , 812 + , 1 + , 1 + , 1000 + , 571 + , 0 + , 1 + , 1000 + , 24177 + , 4 + , 1 + , 1000 + , 32 + , 117366 + , 10475 + , 4 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 23000 + , 100 + , 100 + , 100 + , 23000 + , 100 + , 19537 + , 32 + , 175354 + , 32 + , 46417 + , 4 + , 221973 + , 511 + , 0 + , 1 + , 89141 + , 32 + , 497525 + , 14068 + , 4 + , 2 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 1000 + , 28662 + , 4 + , 2 + , 245000 + , 216773 + , 62 + , 1 + , 1060367 + , 12586 + , 1 + , 208512 + , 421 + , 1 + , 187000 + , 1000 + , 52998 + , 1 + , 80436 + , 32 + , 43249 + , 32 + , 1000 + , 32 + , 80556 + , 1 + , 57667 + , 4 + , 1000 + , 10 + , 197145 + , 156 + , 1 + , 197145 + , 156 + , 1 + , 204924 + , 473 + , 1 + , 208896 + , 511 + , 1 + , 52467 + , 32 + , 64832 + , 32 + , 65493 + , 32 + , 22558 + , 32 + , 16563 + , 32 + , 76511 + , 32 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 69522 + , 11687 + , 0 + , 1 + , 60091 + , 32 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 196500 + , 453240 + , 220 + , 0 + , 1 + , 1 + , 1159724 + , 392670 + , 0 + , 2 + , 806990 + , 30482 + , 4 + , 1927926 + , 82523 + , 4 + , 265318 + , 0 + , 4 + , 0 + , 85931 + , 32 + , 205665 + , 812 + , 1 + , 1 + , 41182 + , 32 + , 212342 + , 32 + , 31220 + , 32 + , 32696 + , 32 + , 43357 + , 32 + , 32247 + , 32 + , 38314 + , 32 + , 35892428 + , 10 + , 9462713 + , 1021 + , 10 + , 38887044 + , 32947 + , 10 + ] diff --git a/cardano-api/internal/Cardano/Api/GenesisParameters.hs b/cardano-api/internal/Cardano/Api/GenesisParameters.hs index 63d34de3f8..1eb37477f3 100644 --- a/cardano-api/internal/Cardano/Api/GenesisParameters.hs +++ b/cardano-api/internal/Cardano/Api/GenesisParameters.hs @@ -4,96 +4,68 @@ {-# LANGUAGE TypeFamilies #-} -- | Parameters fixed in the genesis file: 'GenesisParameters' --- -module Cardano.Api.GenesisParameters ( - - -- * Protocol parameters fixed in the genesis file - GenesisParameters(..), - EpochSize(..), +module Cardano.Api.GenesisParameters + ( -- * Protocol parameters fixed in the genesis file + GenesisParameters (..) + , EpochSize (..) -- * Internal conversion functions - fromShelleyGenesis, - - ) where + , fromShelleyGenesis + ) +where -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.NetworkId +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.NetworkId import qualified Cardano.Api.ReexposeLedger as Ledger - import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Shelley.Genesis as Shelley -import Cardano.Slotting.Slot (EpochSize (..)) - -import Data.Time (NominalDiffTime, UTCTime) - +import Cardano.Slotting.Slot (EpochSize (..)) +import Data.Time (NominalDiffTime, UTCTime) -- ---------------------------------------------------------------------------- -- Genesis parameters -- -- TODO: Conway era - remove GenesisParameters and use ledger types directly -data GenesisParameters era = - GenesisParameters { - - -- | The reference time the system started. The time of slot zero. - -- The time epoch against which all Ouroboros time slots are measured. - -- - protocolParamSystemStart :: UTCTime, - - -- | The network identifier for this blockchain instance. This - -- distinguishes the mainnet from testnets, and different testnets from - -- each other. - -- - protocolParamNetworkId :: NetworkId, - - -- | The Ouroboros Praos active slot coefficient, aka @f@. - -- - protocolParamActiveSlotsCoefficient :: Rational, - - -- | The Ouroboros security parameters, aka @k@. This is the maximum - -- number of blocks the node would ever be prepared to roll back by. - -- - -- Clients of the node following the chain should be prepared to handle - -- the node switching forks up to this long. - -- - protocolParamSecurity :: Int, - - -- | The number of Ouroboros time slots in an Ouroboros epoch. - -- - protocolParamEpochLength :: EpochSize, - - -- | The time duration of a slot. - -- - protocolParamSlotLength :: NominalDiffTime, - - -- | For Ouroboros Praos, the length of a KES period as a number of time - -- slots. The KES keys get evolved once per KES period. - -- - protocolParamSlotsPerKESPeriod :: Int, - - -- | The maximum number of times a KES key can be evolved before it is - -- no longer considered valid. This can be less than the maximum number - -- of times given the KES key size. For example the mainnet KES key size - -- would allow 64 evolutions, but the max KES evolutions param is 62. - -- - protocolParamMaxKESEvolutions :: Int, - - -- | In the Shelley era, prior to decentralised governance, this is the - -- number of genesis key delegates that need to agree for an update - -- proposal to be enacted. - -- - protocolParamUpdateQuorum :: Int, - - -- | The maximum supply for Lovelace. This determines the initial value - -- of the reserves. - -- - protocolParamMaxLovelaceSupply :: L.Coin, - - -- | The initial values of the updateable 'ProtocolParameters'. - -- - protocolInitialUpdateableProtocolParameters :: Ledger.PParams (ShelleyLedgerEra era) - } - +data GenesisParameters era + = GenesisParameters + { protocolParamSystemStart :: UTCTime + -- ^ The reference time the system started. The time of slot zero. + -- The time epoch against which all Ouroboros time slots are measured. + , protocolParamNetworkId :: NetworkId + -- ^ The network identifier for this blockchain instance. This + -- distinguishes the mainnet from testnets, and different testnets from + -- each other. + , protocolParamActiveSlotsCoefficient :: Rational + -- ^ The Ouroboros Praos active slot coefficient, aka @f@. + , protocolParamSecurity :: Int + -- ^ The Ouroboros security parameters, aka @k@. This is the maximum + -- number of blocks the node would ever be prepared to roll back by. + -- + -- Clients of the node following the chain should be prepared to handle + -- the node switching forks up to this long. + , protocolParamEpochLength :: EpochSize + -- ^ The number of Ouroboros time slots in an Ouroboros epoch. + , protocolParamSlotLength :: NominalDiffTime + -- ^ The time duration of a slot. + , protocolParamSlotsPerKESPeriod :: Int + -- ^ For Ouroboros Praos, the length of a KES period as a number of time + -- slots. The KES keys get evolved once per KES period. + , protocolParamMaxKESEvolutions :: Int + -- ^ The maximum number of times a KES key can be evolved before it is + -- no longer considered valid. This can be less than the maximum number + -- of times given the KES key size. For example the mainnet KES key size + -- would allow 64 evolutions, but the max KES evolutions param is 62. + , protocolParamUpdateQuorum :: Int + -- ^ In the Shelley era, prior to decentralised governance, this is the + -- number of genesis key delegates that need to agree for an update + -- proposal to be enacted. + , protocolParamMaxLovelaceSupply :: L.Coin + -- ^ The maximum supply for Lovelace. This determines the initial value + -- of the reserves. + , protocolInitialUpdateableProtocolParameters :: Ledger.PParams (ShelleyLedgerEra era) + -- ^ The initial values of the updateable 'ProtocolParameters'. + } -- ---------------------------------------------------------------------------- -- Conversion functions @@ -101,8 +73,8 @@ data GenesisParameters era = fromShelleyGenesis :: Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters ShelleyEra fromShelleyGenesis - sg@Shelley.ShelleyGenesis { - Shelley.sgSystemStart + sg@Shelley.ShelleyGenesis + { Shelley.sgSystemStart , Shelley.sgNetworkMagic , Shelley.sgNetworkId , Shelley.sgActiveSlotsCoeff @@ -113,22 +85,25 @@ fromShelleyGenesis , Shelley.sgSlotLength , Shelley.sgUpdateQuorum , Shelley.sgMaxLovelaceSupply - , Shelley.sgGenDelegs = _ -- unused, might be of interest - , Shelley.sgInitialFunds = _ -- unused, not retained by the node - , Shelley.sgStaking = _ -- unused, not retained by the node + , Shelley.sgGenDelegs = _ -- unused, might be of interest + , Shelley.sgInitialFunds = _ -- unused, not retained by the node + , Shelley.sgStaking = _ -- unused, not retained by the node } = - GenesisParameters { - protocolParamSystemStart = sgSystemStart - , protocolParamNetworkId = fromShelleyNetwork sgNetworkId - (NetworkMagic sgNetworkMagic) - , protocolParamActiveSlotsCoefficient = Ledger.unboundRational - sgActiveSlotsCoeff - , protocolParamSecurity = fromIntegral sgSecurityParam - , protocolParamEpochLength = sgEpochLength - , protocolParamSlotLength = Shelley.fromNominalDiffTimeMicro sgSlotLength - , protocolParamSlotsPerKESPeriod = fromIntegral sgSlotsPerKESPeriod - , protocolParamMaxKESEvolutions = fromIntegral sgMaxKESEvolutions - , protocolParamUpdateQuorum = fromIntegral sgUpdateQuorum - , protocolParamMaxLovelaceSupply = L.Coin $ fromIntegral sgMaxLovelaceSupply - , protocolInitialUpdateableProtocolParameters = Shelley.sgProtocolParams sg - } + GenesisParameters + { protocolParamSystemStart = sgSystemStart + , protocolParamNetworkId = + fromShelleyNetwork + sgNetworkId + (NetworkMagic sgNetworkMagic) + , protocolParamActiveSlotsCoefficient = + Ledger.unboundRational + sgActiveSlotsCoeff + , protocolParamSecurity = fromIntegral sgSecurityParam + , protocolParamEpochLength = sgEpochLength + , protocolParamSlotLength = Shelley.fromNominalDiffTimeMicro sgSlotLength + , protocolParamSlotsPerKESPeriod = fromIntegral sgSlotsPerKESPeriod + , protocolParamMaxKESEvolutions = fromIntegral sgMaxKESEvolutions + , protocolParamUpdateQuorum = fromIntegral sgUpdateQuorum + , protocolParamMaxLovelaceSupply = L.Coin $ fromIntegral sgMaxLovelaceSupply + , protocolInitialUpdateableProtocolParameters = Shelley.sgProtocolParams sg + } diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index 8575878245..d367154e62 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -12,34 +12,32 @@ module Cardano.Api.Governance.Actions.ProposalProcedure where -import Cardano.Api.Address -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Shelley -import Cardano.Api.ProtocolParameters +import Cardano.Api.Address +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Shelley +import Cardano.Api.ProtocolParameters import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.TxIn - +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.TxIn import qualified Cardano.Binary as CBOR import qualified Cardano.Ledger.Address as L -import Cardano.Ledger.BaseTypes +import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway as Conway import qualified Cardano.Ledger.Conway.Governance as Gov import qualified Cardano.Ledger.Conway.Governance as Ledger -import Cardano.Ledger.Core (EraCrypto) +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as Shelley import qualified Cardano.Ledger.Credential as L -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Keys (KeyRole (ColdCommitteeRole)) - -import Data.ByteString (ByteString) -import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) -import Data.Word -import GHC.Exts (IsList (..)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys (KeyRole (ColdCommitteeRole)) +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Data.Word +import GHC.Exts (IsList (..)) data AnyGovernanceAction = forall era. AnyGovernanceAction (Gov.GovAction era) @@ -53,22 +51,28 @@ data GovernanceAction era (StrictMaybe (Shelley.ScriptHash StandardCrypto)) | ProposeNewCommittee (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose (ShelleyLedgerEra era))) - [L.Credential ColdCommitteeRole StandardCrypto] -- ^ Old constitutional committee - (Map (L.Credential ColdCommitteeRole StandardCrypto) EpochNo) -- ^ New committee members with epoch number when each of them expires - Rational -- ^ Quorum of the committee that is necessary for a successful vote + [L.Credential ColdCommitteeRole StandardCrypto] + -- ^ Old constitutional committee + (Map (L.Credential ColdCommitteeRole StandardCrypto) EpochNo) + -- ^ New committee members with epoch number when each of them expires + Rational + -- ^ Quorum of the committee that is necessary for a successful vote | InfoAct - | TreasuryWithdrawal + | -- | Governance policy + TreasuryWithdrawal [(Network, StakeCredential, L.Coin)] - !(StrictMaybe (Shelley.ScriptHash StandardCrypto)) -- ^ Governance policy + !(StrictMaybe (Shelley.ScriptHash StandardCrypto)) | InitiateHardfork (StrictMaybe (Ledger.GovPurposeId Ledger.HardForkPurpose (ShelleyLedgerEra era))) ProtVer - | UpdatePParams + | -- | Governance policy + UpdatePParams (StrictMaybe (Ledger.GovPurposeId Ledger.PParamUpdatePurpose (ShelleyLedgerEra era))) (Ledger.PParamsUpdate (ShelleyLedgerEra era)) - !(StrictMaybe (Shelley.ScriptHash StandardCrypto)) -- ^ Governance policy + !(StrictMaybe (Shelley.ScriptHash StandardCrypto)) -toGovernanceAction :: () +toGovernanceAction + :: () => ShelleyBasedEra era -> GovernanceAction era -> Gov.GovAction (ShelleyLedgerEra era) @@ -77,25 +81,32 @@ toGovernanceAction sbe = MotionOfNoConfidence prevGovId -> Gov.NoConfidence prevGovId ProposeNewConstitution prevGovAction anchor mConstitutionScriptHash -> - Gov.NewConstitution prevGovAction Gov.Constitution - { Gov.constitutionAnchor = anchor - , Gov.constitutionScript = mConstitutionScriptHash - } + Gov.NewConstitution + prevGovAction + Gov.Constitution + { Gov.constitutionAnchor = anchor + , Gov.constitutionScript = mConstitutionScriptHash + } ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor -> Gov.UpdateCommittee prevGovId -- previous governance action id (fromList oldCommitteeMembers) -- members to remove newCommitteeMembers -- members to add - (fromMaybe (error $ mconcat ["toGovernanceAction: the given quorum " - , show quor - , " was outside of the unit interval!" - ]) - $ boundRational @UnitInterval quor) + ( fromMaybe + ( error $ + mconcat + [ "toGovernanceAction: the given quorum " + , show quor + , " was outside of the unit interval!" + ] + ) + $ boundRational @UnitInterval quor + ) InfoAct -> Gov.InfoAction TreasuryWithdrawal withdrawals govPol -> - let m = fromList [(L.RewardAccount nw (toShelleyStakeCredential sc), l) | (nw,sc,l) <- withdrawals] - in Gov.TreasuryWithdrawals m govPol + let m = fromList [(L.RewardAccount nw (toShelleyStakeCredential sc), l) | (nw, sc, l) <- withdrawals] + in Gov.TreasuryWithdrawals m govPol InitiateHardfork prevGovId pVer -> Gov.HardForkInitiation prevGovId pVer UpdatePParams preGovId ppup govPol -> @@ -109,7 +120,8 @@ fromGovernanceAction = \case Gov.NoConfidence prevGovId -> MotionOfNoConfidence prevGovId Gov.NewConstitution prevGovId constitution -> - ProposeNewConstitution prevGovId + ProposeNewConstitution + prevGovId (Gov.constitutionAnchor constitution) (Gov.constitutionScript constitution) Gov.ParameterChange prevGovId pparams govPolicy -> @@ -117,10 +129,11 @@ fromGovernanceAction = \case Gov.HardForkInitiation prevGovId pVer -> InitiateHardfork prevGovId pVer Gov.TreasuryWithdrawals withdrawlMap govPolicy -> - let res = [ (L.raNetwork rwdAcnt, fromShelleyStakeCredential (L.raCredential rwdAcnt), coin) - | (rwdAcnt, coin) <- toList withdrawlMap - ] - in TreasuryWithdrawal res govPolicy + let res = + [ (L.raNetwork rwdAcnt, fromShelleyStakeCredential (L.raCredential rwdAcnt), coin) + | (rwdAcnt, coin) <- toList withdrawlMap + ] + in TreasuryWithdrawal res govPolicy Gov.UpdateCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor -> ProposeNewCommittee prevGovId @@ -130,7 +143,7 @@ fromGovernanceAction = \case Gov.InfoAction -> InfoAct -newtype Proposal era = Proposal { unProposal :: Gov.ProposalProcedure (ShelleyLedgerEra era) } +newtype Proposal era = Proposal {unProposal :: Gov.ProposalProcedure (ShelleyLedgerEra era)} instance IsShelleyBasedEra era => Show (Proposal era) where show (Proposal pp) = do @@ -144,7 +157,8 @@ instance IsShelleyBasedEra era => ToCBOR (Proposal era) where toCBOR (Proposal vp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp instance IsShelleyBasedEra era => FromCBOR (Proposal era) where - fromCBOR = Proposal <$> shelleyBasedEraConstraints (shelleyBasedEra @era) (Shelley.fromEraCBOR @Conway.Conway) + fromCBOR = + Proposal <$> shelleyBasedEraConstraints (shelleyBasedEra @era) (Shelley.fromEraCBOR @Conway.Conway) instance IsShelleyBasedEra era => SerialiseAsCBOR (Proposal era) where serialiseToCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.serialize' @@ -154,58 +168,59 @@ instance IsShelleyBasedEra era => HasTextEnvelope (Proposal era) where textEnvelopeType _ = "Governance proposal" instance HasTypeProxy era => HasTypeProxy (Proposal era) where - data AsType (Proposal era) = AsProposal - proxyToAsType _ = AsProposal - + data AsType (Proposal era) = AsProposal + proxyToAsType _ = AsProposal createProposalProcedure :: ShelleyBasedEra era -> Network - -> L.Coin -- ^ Deposit - -> StakeCredential -- ^ Credential to return the deposit to. + -> L.Coin + -- ^ Deposit + -> StakeCredential + -- ^ Credential to return the deposit to. -> GovernanceAction era -> Ledger.Anchor StandardCrypto -> Proposal era createProposalProcedure sbe nw dep cred govAct anchor = shelleyBasedEraConstraints sbe $ - Proposal Gov.ProposalProcedure - { Gov.pProcDeposit = dep - , Gov.pProcReturnAddr = L.RewardAccount nw $ toShelleyStakeCredential cred - , Gov.pProcGovAction = toGovernanceAction sbe govAct - , Gov.pProcAnchor = anchor - } + Proposal + Gov.ProposalProcedure + { Gov.pProcDeposit = dep + , Gov.pProcReturnAddr = L.RewardAccount nw $ toShelleyStakeCredential cred + , Gov.pProcGovAction = toGovernanceAction sbe govAct + , Gov.pProcAnchor = anchor + } fromProposalProcedure :: ShelleyBasedEra era -> Proposal era -> (L.Coin, Hash StakeKey, GovernanceAction era) fromProposalProcedure sbe (Proposal pp) = - shelleyBasedEraConstraints sbe + shelleyBasedEraConstraints + sbe ( Gov.pProcDeposit pp , case fromShelleyStakeCredential (L.raCredential (Gov.pProcReturnAddr pp)) of - StakeCredentialByKey keyhash -> keyhash - StakeCredentialByScript _scripthash -> - error "fromProposalProcedure TODO: Conway era script reward addresses not yet supported" + StakeCredentialByKey keyhash -> keyhash + StakeCredentialByScript _scripthash -> + error "fromProposalProcedure TODO: Conway era script reward addresses not yet supported" , fromGovernanceAction (Gov.pProcGovAction pp) ) - createPreviousGovernanceActionId :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => TxId - -> Word16 -- ^ Governance action transation index + -> Word16 + -- ^ Governance action transation index -> Ledger.GovPurposeId (r :: Ledger.GovActionPurpose) (ShelleyLedgerEra era) -createPreviousGovernanceActionId txid index = - Ledger.GovPurposeId $ createGovernanceActionId txid index - +createPreviousGovernanceActionId txid index = + Ledger.GovPurposeId $ createGovernanceActionId txid index createGovernanceActionId :: TxId -> Word16 -> Gov.GovActionId StandardCrypto createGovernanceActionId txid index = - Ledger.GovActionId - { Ledger.gaidTxId = toShelleyTxId txid - , Ledger.gaidGovActionIx = Ledger.GovActionIx index - } - + Ledger.GovActionId + { Ledger.gaidTxId = toShelleyTxId txid + , Ledger.gaidGovActionIx = Ledger.GovActionIx index + } createAnchor :: Url -> ByteString -> Anchor StandardCrypto createAnchor url anchorData = diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 4d0a6387cc..c8bc00ae93 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -16,26 +16,24 @@ module Cardano.Api.Governance.Actions.VotingProcedure where -import Cardano.Api.Address -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Governance.Actions.ProposalProcedure -import Cardano.Api.HasTypeProxy +import Cardano.Api.Address +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Governance.Actions.ProposalProcedure +import Cardano.Api.HasTypeProxy import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseTextEnvelope - +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Binary as CBOR import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.Core (EraCrypto) +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as L - -import Control.Monad (foldM) +import Control.Monad (foldM) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text.Encoding as Text -import GHC.Generics +import GHC.Generics newtype GovernanceActionId era = GovernanceActionId { unGovernanceActionId :: Ledger.GovActionId (EraCrypto (ShelleyLedgerEra era)) @@ -63,7 +61,6 @@ instance IsShelleyBasedEra era => FromCBOR (Voter era) where !v <- shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.fromEraCBOR @(ShelleyLedgerEra era) pure $ Voter v - data Vote = No | Yes @@ -76,29 +73,36 @@ toVote = \case Yes -> Ledger.VoteYes Abstain -> Ledger.Abstain -createVotingProcedure :: () +createVotingProcedure + :: () => ConwayEraOnwards era -> Vote - -> Maybe (Ledger.Url, Text) -- ^ Anchor + -> Maybe (Ledger.Url, Text) + -- ^ Anchor -> VotingProcedure era createVotingProcedure eon vChoice mProposalAnchor = - let proposalAnchor = fmap Text.encodeUtf8 <$> mProposalAnchor - in conwayEraOnwardsConstraints eon - $ VotingProcedure $ Ledger.VotingProcedure - { Ledger.vProcVote = toVote vChoice - , Ledger.vProcAnchor = Ledger.maybeToStrictMaybe $ uncurry createAnchor <$> proposalAnchor - } + let proposalAnchor = fmap Text.encodeUtf8 <$> mProposalAnchor + in conwayEraOnwardsConstraints eon $ + VotingProcedure $ + Ledger.VotingProcedure + { Ledger.vProcVote = toVote vChoice + , Ledger.vProcAnchor = Ledger.maybeToStrictMaybe $ uncurry createAnchor <$> proposalAnchor + } newtype VotingProcedure era = VotingProcedure { unVotingProcedure :: Ledger.VotingProcedure (ShelleyLedgerEra era) - } deriving (Show, Eq) + } + deriving (Show, Eq) instance IsShelleyBasedEra era => ToCBOR (VotingProcedure era) where toCBOR (VotingProcedure vp) = shelleyBasedEraConstraints sbe $ L.toEraCBOR @(ShelleyLedgerEra era) vp - where sbe = shelleyBasedEra @era + where + sbe = shelleyBasedEra @era instance IsShelleyBasedEra era => FromCBOR (VotingProcedure era) where - fromCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) $ VotingProcedure <$> L.fromEraCBOR @(ShelleyLedgerEra era) + fromCBOR = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + VotingProcedure <$> L.fromEraCBOR @(ShelleyLedgerEra era) instance IsShelleyBasedEra era => SerialiseAsCBOR (VotingProcedure era) where serialiseToCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.serialize' @@ -112,23 +116,25 @@ instance HasTypeProxy era => HasTypeProxy (VotingProcedure era) where proxyToAsType _ = AsVote newtype VotingProcedures era = VotingProcedures - { unVotingProcedures :: L.VotingProcedures (ShelleyLedgerEra era) + { unVotingProcedures :: L.VotingProcedures (ShelleyLedgerEra era) } deriving instance Eq (VotingProcedures era) + deriving instance Generic (VotingProcedures era) + deriving instance Show (VotingProcedures era) instance IsShelleyBasedEra era => ToCBOR (VotingProcedures era) where toCBOR = \case VotingProcedures vp -> - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ L.toEraCBOR @(ShelleyLedgerEra era) vp + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + L.toEraCBOR @(ShelleyLedgerEra era) vp instance IsShelleyBasedEra era => FromCBOR (VotingProcedures era) where fromCBOR = - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ VotingProcedures <$> L.fromEraCBOR @(ShelleyLedgerEra era) + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + VotingProcedures <$> L.fromEraCBOR @(ShelleyLedgerEra era) instance IsShelleyBasedEra era => SerialiseAsCBOR (VotingProcedures era) where serialiseToCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.serialize' @@ -144,44 +150,51 @@ instance HasTypeProxy era => HasTypeProxy (VotingProcedures era) where emptyVotingProcedures :: VotingProcedures era emptyVotingProcedures = VotingProcedures $ L.VotingProcedures Map.empty -singletonVotingProcedures :: () +singletonVotingProcedures + :: () => ConwayEraOnwards era -> L.Voter (L.EraCrypto (ShelleyLedgerEra era)) -> L.GovActionId (L.EraCrypto (ShelleyLedgerEra era)) -> L.VotingProcedure (ShelleyLedgerEra era) -> VotingProcedures era singletonVotingProcedures _ voter govActionId votingProcedure = - VotingProcedures - $ L.VotingProcedures - $ Map.singleton voter - $ Map.singleton govActionId votingProcedure + VotingProcedures $ + L.VotingProcedures $ + Map.singleton voter $ + Map.singleton govActionId votingProcedure -- | A voter, and the conflicting votes of this voter (i.e. votes with the same governance action identifier) -newtype VotesMergingConflict era = - VotesMergingConflict - ( L.Voter (L.EraCrypto (ShelleyLedgerEra era)) - , [L.GovActionId (L.EraCrypto (ShelleyLedgerEra era))]) +newtype VotesMergingConflict era + = VotesMergingConflict + ( L.Voter (L.EraCrypto (ShelleyLedgerEra era)) + , [L.GovActionId (L.EraCrypto (ShelleyLedgerEra era))] + ) -- | @mergeVotingProcedures vote1 vote2@ merges @vote1@ and @vote2@ into a single vote, -- or fails if the votes are incompatible. -mergeVotingProcedures :: () - => VotingProcedures era -- ^ Votes to merge - -> VotingProcedures era -- ^ Votes to merge - -> Either (VotesMergingConflict era) (VotingProcedures era) -- ^ Either the conflict found, or the merged votes +mergeVotingProcedures + :: () + => VotingProcedures era + -- ^ Votes to merge + -> VotingProcedures era + -- ^ Votes to merge + -> Either (VotesMergingConflict era) (VotingProcedures era) + -- ^ Either the conflict found, or the merged votes mergeVotingProcedures vpsa vpsb = VotingProcedures . L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters - where - mapa = L.unVotingProcedures (unVotingProcedures vpsa) - mapb = L.unVotingProcedures (unVotingProcedures vpsb) - allVoters = Set.union (Map.keysSet mapa) (Map.keysSet mapb) - mergeVotesOfOneVoter acc voter = - Map.union acc <$> case (Map.lookup voter mapa, Map.lookup voter mapb) of - (Just v, Nothing) -> Right $ Map.singleton voter v -- Take only available value - (Nothing, Just v) -> Right $ Map.singleton voter v -- Take only available value - (Nothing, Nothing) -> Right Map.empty -- No value - (Just va, Just vb) -> -- Here's the case where we're unioning different votes for the same voter - if null intersection -- No conflict: sets of keys from left and right is disjoint + where + mapa = L.unVotingProcedures (unVotingProcedures vpsa) + mapb = L.unVotingProcedures (unVotingProcedures vpsb) + allVoters = Set.union (Map.keysSet mapa) (Map.keysSet mapb) + mergeVotesOfOneVoter acc voter = + Map.union acc <$> case (Map.lookup voter mapa, Map.lookup voter mapb) of + (Just v, Nothing) -> Right $ Map.singleton voter v -- Take only available value + (Nothing, Just v) -> Right $ Map.singleton voter v -- Take only available value + (Nothing, Nothing) -> Right Map.empty -- No value + (Just va, Just vb) -> + -- Here's the case where we're unioning different votes for the same voter + if null intersection -- No conflict: sets of keys from left and right is disjoint then Right $ Map.singleton voter (Map.union va vb) else Left $ VotesMergingConflict (voter, intersection) -- Ooops, a conflict! Let's report it! - where - intersection = Map.keys $ Map.intersection va vb + where + intersection = Map.keys $ Map.intersection va vb diff --git a/cardano-api/internal/Cardano/Api/Governance/Poll.hs b/cardano-api/internal/Cardano/Api/Governance/Poll.hs index 79f06865a1..c49a554b4a 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Poll.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Poll.hs @@ -18,55 +18,54 @@ -- parameters updates. This standard is meant to be an inclusive interim -- solution while the work on a larger governance framework such as -- CIP-1694 continues. -module Cardano.Api.Governance.Poll( - -- * Type Proxies - AsType (..), - Hash (..), +module Cardano.Api.Governance.Poll + ( -- * Type Proxies + AsType (..) + , Hash (..) -- * Types - GovernancePoll (..), - GovernancePollAnswer (..), + , GovernancePoll (..) + , GovernancePollAnswer (..) -- * Errors - GovernancePollError (..), - renderGovernancePollError, + , GovernancePollError (..) + , renderGovernancePollError -- * Functions - hashGovernancePoll, - verifyPollAnswer, - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Shelley -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.TxMetadata -import Cardano.Api.Utils - -import Cardano.Binary (DecoderError (..)) -import Cardano.Crypto.Hash (hashFromBytes, hashToBytes, hashWith) + , hashGovernancePoll + , verifyPollAnswer + ) +where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Shelley +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.TxMetadata +import Cardano.Api.Utils +import Cardano.Binary (DecoderError (..)) +import Cardano.Crypto.Hash (hashFromBytes, hashToBytes, hashWith) import qualified Cardano.Crypto.Hash as Hash -import Cardano.Ledger.Crypto (HASH, StandardCrypto) - -import Control.Arrow (left) -import Control.Monad (foldM, when) -import Data.Either.Combinators (maybeToRight) -import Data.Function ((&)) +import Cardano.Ledger.Crypto (HASH, StandardCrypto) +import Control.Arrow (left) +import Control.Monad (foldM, when) +import Data.Either.Combinators (maybeToRight) +import Data.Function ((&)) import qualified Data.Map.Strict as Map -import Data.String (IsString (..)) -import Data.Text (Text) +import Data.String (IsString (..)) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text.Builder -import Data.Word (Word64) -import Formatting (build, sformat) +import Data.Word (Word64) +import Formatting (build, sformat) -- | Associated metadata label as defined in CIP-0094 pollMetadataLabel :: Word64 @@ -104,96 +103,100 @@ pollMetadataKeyNonce = TxMetaText "_" -- are based on their hashes) if the same question/answers need to be asked -- multiple times. data GovernancePoll = GovernancePoll - { govPollQuestion :: Text - -- ^ A question as a human readable text; the text can be arbitrarily large. - , govPollAnswers :: [Text] - -- ^ Answers as human readable texts; their positions are used for answering. - , govPollNonce :: Maybe Word - -- ^ An optional nonce to make the poll unique if needs be. - } + { govPollQuestion :: Text + -- ^ A question as a human readable text; the text can be arbitrarily large. + , govPollAnswers :: [Text] + -- ^ Answers as human readable texts; their positions are used for answering. + , govPollNonce :: Maybe Word + -- ^ An optional nonce to make the poll unique if needs be. + } deriving (Show, Eq) instance HasTextEnvelope GovernancePoll where - textEnvelopeType _ = "GovernancePoll" + textEnvelopeType _ = "GovernancePoll" instance HasTypeProxy GovernancePoll where - data AsType GovernancePoll = AsGovernancePoll - proxyToAsType _ = AsGovernancePoll + data AsType GovernancePoll = AsGovernancePoll + proxyToAsType _ = AsGovernancePoll instance AsTxMetadata GovernancePoll where - asTxMetadata GovernancePoll{govPollQuestion, govPollAnswers, govPollNonce} = - makeTransactionMetadata $ Map.fromList - [ ( pollMetadataLabel + asTxMetadata GovernancePoll {govPollQuestion, govPollAnswers, govPollNonce} = + makeTransactionMetadata $ + Map.fromList + [ + ( pollMetadataLabel , TxMetaMap $ - [ ( pollMetadataKeyQuestion, metaTextChunks govPollQuestion ) - , ( pollMetadataKeyAnswers, TxMetaList (metaTextChunks <$> govPollAnswers) ) - ] ++ - case govPollNonce of - Nothing -> [] - Just nonce -> - [ ( pollMetadataKeyNonce, TxMetaNumber (toInteger nonce) ) - ] + [ (pollMetadataKeyQuestion, metaTextChunks govPollQuestion) + , (pollMetadataKeyAnswers, TxMetaList (metaTextChunks <$> govPollAnswers)) + ] + ++ case govPollNonce of + Nothing -> [] + Just nonce -> + [ (pollMetadataKeyNonce, TxMetaNumber (toInteger nonce)) + ] ) ] instance SerialiseAsCBOR GovernancePoll where - serialiseToCBOR = - serialiseToCBOR . asTxMetadata - - deserialiseFromCBOR AsGovernancePoll bs = do - metadata <- deserialiseFromCBOR AsTxMetadata bs - withNestedMap lbl pollMetadataLabel metadata $ \values -> - GovernancePoll - -- Question - <$> ( let key = pollMetadataKeyQuestion in case lookup key values of - Just x -> - expectTextChunks (fieldPath lbl key) x - Nothing -> - Left $ missingField (fieldPath lbl key) - ) - -- Answers - <*> ( let key = pollMetadataKeyAnswers in case lookup key values of - Just (TxMetaList xs) -> - traverse (expectTextChunks (fieldPath lbl key)) xs - Just _ -> - Left $ malformedField (fieldPath lbl key) "List of Text (answers)" - Nothing -> - Left $ missingField (fieldPath lbl key) - ) - -- Nonce (optional) - <*> ( let key = pollMetadataKeyNonce in case lookup key values of - Just (TxMetaNumber nonce) -> - Just <$> expectWord (fieldPath lbl key) nonce - Nothing -> - pure Nothing - Just _ -> - Left $ malformedField (fieldPath lbl key) "Number (nonce)" - ) - where - lbl = "GovernancePoll" + serialiseToCBOR = + serialiseToCBOR . asTxMetadata + + deserialiseFromCBOR AsGovernancePoll bs = do + metadata <- deserialiseFromCBOR AsTxMetadata bs + withNestedMap lbl pollMetadataLabel metadata $ \values -> + GovernancePoll + -- Question + <$> ( let key = pollMetadataKeyQuestion + in case lookup key values of + Just x -> + expectTextChunks (fieldPath lbl key) x + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + -- Answers + <*> ( let key = pollMetadataKeyAnswers + in case lookup key values of + Just (TxMetaList xs) -> + traverse (expectTextChunks (fieldPath lbl key)) xs + Just _ -> + Left $ malformedField (fieldPath lbl key) "List of Text (answers)" + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + -- Nonce (optional) + <*> ( let key = pollMetadataKeyNonce + in case lookup key values of + Just (TxMetaNumber nonce) -> + Just <$> expectWord (fieldPath lbl key) nonce + Nothing -> + pure Nothing + Just _ -> + Left $ malformedField (fieldPath lbl key) "Number (nonce)" + ) + where + lbl = "GovernancePoll" -- ---------------------------------------------------------------------------- -- Governance Poll Hash -- -newtype instance Hash GovernancePoll = - GovernancePollHash { unGovernancePollHash :: Hash.Hash (HASH StandardCrypto) GovernancePoll } +newtype instance Hash GovernancePoll + = GovernancePollHash {unGovernancePollHash :: Hash.Hash (HASH StandardCrypto) GovernancePoll} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GovernancePoll) instance SerialiseAsRawBytes (Hash GovernancePoll) where - serialiseToRawBytes = - hashToBytes . unGovernancePollHash + serialiseToRawBytes = + hashToBytes . unGovernancePollHash - deserialiseFromRawBytes (AsHash AsGovernancePoll) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash(GovernancePoll)") $ - GovernancePollHash <$> hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGovernancePoll) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash(GovernancePoll)") $ + GovernancePollHash <$> hashFromBytes bs hashGovernancePoll :: GovernancePoll -> Hash GovernancePoll hashGovernancePoll = GovernancePollHash . hashWith @(HASH StandardCrypto) serialiseToCBOR - -- ---------------------------------------------------------------------------- -- Governance Poll Answer -- @@ -201,64 +204,67 @@ hashGovernancePoll = -- | An (unauthenticated) answer to a poll from an SPO referring to a poll by -- hash digest value. data GovernancePollAnswer = GovernancePollAnswer - { govAnsPoll :: Hash GovernancePoll - -- ^ The target poll - , govAnsChoice :: Word - -- ^ The (0-based) index of the chosen answer from that poll - } + { govAnsPoll :: Hash GovernancePoll + -- ^ The target poll + , govAnsChoice :: Word + -- ^ The (0-based) index of the chosen answer from that poll + } deriving (Show, Eq) instance HasTypeProxy GovernancePollAnswer where - data AsType GovernancePollAnswer = AsGovernancePollAnswer - proxyToAsType _ = AsGovernancePollAnswer + data AsType GovernancePollAnswer = AsGovernancePollAnswer + proxyToAsType _ = AsGovernancePollAnswer instance AsTxMetadata GovernancePollAnswer where - asTxMetadata GovernancePollAnswer{govAnsPoll, govAnsChoice} = - makeTransactionMetadata $ Map.fromList - [ ( pollMetadataLabel + asTxMetadata GovernancePollAnswer {govAnsPoll, govAnsChoice} = + makeTransactionMetadata $ + Map.fromList + [ + ( pollMetadataLabel , TxMetaMap - [ ( pollMetadataKeyPoll, TxMetaBytes (serialiseToRawBytes govAnsPoll) ) - , ( pollMetadataKeyChoice, TxMetaNumber (toInteger govAnsChoice) ) - ] + [ (pollMetadataKeyPoll, TxMetaBytes (serialiseToRawBytes govAnsPoll)) + , (pollMetadataKeyChoice, TxMetaNumber (toInteger govAnsChoice)) + ] ) ] instance SerialiseAsCBOR GovernancePollAnswer where - serialiseToCBOR = - serialiseToCBOR . asTxMetadata - - deserialiseFromCBOR AsGovernancePollAnswer bs = do - metadata <- deserialiseFromCBOR AsTxMetadata bs - withNestedMap lbl pollMetadataLabel metadata $ \values -> - GovernancePollAnswer - -- Poll - <$> ( let key = pollMetadataKeyPoll in case lookup key values of - Nothing -> - Left $ missingField (fieldPath lbl key) - Just x -> - expectHash key x - ) - -- Answer - <*> ( let key = pollMetadataKeyChoice in case lookup key values of - Just (TxMetaNumber n) -> - expectWord (fieldPath lbl key) n - Just _ -> - Left $ malformedField (fieldPath lbl key) "Number (answer index)" - Nothing -> - Left $ missingField (fieldPath lbl key) - ) - where - lbl = "GovernancePollAnswer" - - expectHash key value = - case value of - TxMetaBytes bytes -> - left - (DecoderErrorCustom (fieldPath lbl key) . Text.pack . unSerialiseAsRawBytesError) - (deserialiseFromRawBytes (AsHash AsGovernancePoll) bytes) - _ -> - Left (malformedField (fieldPath lbl key) "Bytes (32 bytes hash digest)") - + serialiseToCBOR = + serialiseToCBOR . asTxMetadata + + deserialiseFromCBOR AsGovernancePollAnswer bs = do + metadata <- deserialiseFromCBOR AsTxMetadata bs + withNestedMap lbl pollMetadataLabel metadata $ \values -> + GovernancePollAnswer + -- Poll + <$> ( let key = pollMetadataKeyPoll + in case lookup key values of + Nothing -> + Left $ missingField (fieldPath lbl key) + Just x -> + expectHash key x + ) + -- Answer + <*> ( let key = pollMetadataKeyChoice + in case lookup key values of + Just (TxMetaNumber n) -> + expectWord (fieldPath lbl key) n + Just _ -> + Left $ malformedField (fieldPath lbl key) "Number (answer index)" + Nothing -> + Left $ missingField (fieldPath lbl key) + ) + where + lbl = "GovernancePollAnswer" + + expectHash key value = + case value of + TxMetaBytes bytes -> + left + (DecoderErrorCustom (fieldPath lbl key) . Text.pack . unSerialiseAsRawBytesError) + (deserialiseFromRawBytes (AsHash AsGovernancePoll) bytes) + _ -> + Left (malformedField (fieldPath lbl key) "Bytes (32 bytes hash digest)") -- ---------------------------------------------------------------------------- -- Governance Poll Verification @@ -270,55 +276,58 @@ data GovernancePollError | ErrGovernancePollUnauthenticated | ErrGovernancePollMalformedAnswer DecoderError | ErrGovernancePollInvalidAnswer GovernancePollInvalidAnswerError - deriving Show + deriving (Show) data GovernancePollInvalidAnswerError = GovernancePollInvalidAnswerError { invalidAnswerAcceptableAnswers :: [(Word, Text)] , invalidAnswerReceivedAnswer :: Word } - deriving Show + deriving (Show) data GovernancePollMismatchError = GovernancePollMismatchError { specifiedHashInAnswer :: Hash GovernancePoll , calculatedHashFromPoll :: Hash GovernancePoll } - deriving Show + deriving (Show) renderGovernancePollError :: GovernancePollError -> Text renderGovernancePollError err = case err of - ErrGovernancePollMismatch mismatchErr -> mconcat - [ "Answer's poll doesn't match provided poll (hash mismatch).\n" - , " Hash specified in answer: " <> textShow (specifiedHashInAnswer mismatchErr) - , "\n" - , " Hash calculated from poll: " <> textShow (calculatedHashFromPoll mismatchErr) - ] + ErrGovernancePollMismatch mismatchErr -> + mconcat + [ "Answer's poll doesn't match provided poll (hash mismatch).\n" + , " Hash specified in answer: " <> textShow (specifiedHashInAnswer mismatchErr) + , "\n" + , " Hash calculated from poll: " <> textShow (calculatedHashFromPoll mismatchErr) + ] ErrGovernancePollNoAnswer -> "No answer found in the provided transaction's metadata." - ErrGovernancePollUnauthenticated -> mconcat - [ "No (valid) signatories found for the answer. " - , "Signatories MUST be specified as extra signatories on the transaction " - , "and cannot be mere payment keys." - ] + ErrGovernancePollUnauthenticated -> + mconcat + [ "No (valid) signatories found for the answer. " + , "Signatories MUST be specified as extra signatories on the transaction " + , "and cannot be mere payment keys." + ] ErrGovernancePollMalformedAnswer decoderErr -> "Malformed metadata; couldn't deserialise answer: " <> sformat build decoderErr ErrGovernancePollInvalidAnswer invalidAnswer -> - mconcat - [ "Invalid answer (" - , textShow (invalidAnswerReceivedAnswer invalidAnswer) - , ") not part of the poll." - , "\n" - , "Accepted answers:" - , "\n" - , Text.intercalate "\n" - [ mconcat - [ textShow ix - , " → " - , answer - ] - | (ix, answer) <- invalidAnswerAcceptableAnswers invalidAnswer - ] - ] + mconcat + [ "Invalid answer (" + , textShow (invalidAnswerReceivedAnswer invalidAnswer) + , ") not part of the poll." + , "\n" + , "Accepted answers:" + , "\n" + , Text.intercalate + "\n" + [ mconcat + [ textShow ix + , " → " + , answer + ] + | (ix, answer) <- invalidAnswerAcceptableAnswers invalidAnswer + ] + ] -- | Verify a poll against a given transaction and returns the signatories -- (verification key only) when valid. @@ -336,29 +345,32 @@ verifyPollAnswer poll (InAnyShelleyBasedEra _era (getTxBody -> TxBody body)) = d extraKeyWitnesses (txExtraKeyWits body) where extractPollAnswer = \case - TxMetadataNone -> - Left ErrGovernancePollNoAnswer - TxMetadataInEra _era metadata -> - left ErrGovernancePollMalformedAnswer $ - deserialiseFromCBOR AsGovernancePollAnswer (serialiseToCBOR metadata) + TxMetadataNone -> + Left ErrGovernancePollNoAnswer + TxMetadataInEra _era metadata -> + left ErrGovernancePollMalformedAnswer $ + deserialiseFromCBOR AsGovernancePollAnswer (serialiseToCBOR metadata) hasMatchingHash answer calculatedHashFromPoll = do let specifiedHashInAnswer = govAnsPoll answer when (calculatedHashFromPoll /= specifiedHashInAnswer) $ - Left $ ErrGovernancePollMismatch $ - GovernancePollMismatchError - { specifiedHashInAnswer - , calculatedHashFromPoll - } + Left $ + ErrGovernancePollMismatch $ + GovernancePollMismatchError + { specifiedHashInAnswer + , calculatedHashFromPoll + } isAmongAcceptableChoices answer answers = when (govAnsChoice answer >= fromIntegral (length answers)) $ do let invalidAnswerReceivedAnswer = govAnsChoice answer - let invalidAnswerAcceptableAnswers = zip [0..] answers - Left $ ErrGovernancePollInvalidAnswer $ GovernancePollInvalidAnswerError - { invalidAnswerReceivedAnswer - , invalidAnswerAcceptableAnswers - } + let invalidAnswerAcceptableAnswers = zip [0 ..] answers + Left $ + ErrGovernancePollInvalidAnswer $ + GovernancePollInvalidAnswerError + { invalidAnswerReceivedAnswer + , invalidAnswerAcceptableAnswers + } extraKeyWitnesses = \case TxExtraKeyWitnesses _era witnesses -> @@ -381,11 +393,15 @@ withNestedMap lbl topLevelLabel (TxMetadata m) continueWith = Just (TxMetaMap values) -> continueWith values Nothing -> - Left $ DecoderErrorCustom lbl - ("missing expected label: " <> textShow topLevelLabel) + Left $ + DecoderErrorCustom + lbl + ("missing expected label: " <> textShow topLevelLabel) Just _ -> - Left $ DecoderErrorCustom lbl - "malformed data; expected a key:value map" + Left $ + DecoderErrorCustom + lbl + "malformed data; expected a key:value map" expectTextChunks :: Text -> TxMetadataValue -> Either DecoderError Text expectTextChunks lbl value = @@ -393,8 +409,8 @@ expectTextChunks lbl value = TxMetaList xs -> foldM expectText mempty xs & maybe - (Left (malformedField (lbl <> "[i]") "Text")) - (Right . Text.Lazy.toStrict . Text.Builder.toLazyText) + (Left (malformedField (lbl <> "[i]") "Text")) + (Right . Text.Lazy.toStrict . Text.Builder.toLazyText) _ -> Left (malformedField lbl "List") where @@ -408,24 +424,28 @@ expectWord lbl n | n >= 0 && n < toInteger (maxBound :: Word) = pure (fromInteger n) | otherwise = - Left $ DecoderErrorCustom lbl - "invalid number; must be non-negative word" + Left $ + DecoderErrorCustom + lbl + "invalid number; must be non-negative word" missingField :: Text -> DecoderError missingField lbl = - DecoderErrorCustom lbl + DecoderErrorCustom + lbl "missing mandatory field" malformedField :: Text -> Text -> DecoderError malformedField lbl hint = - DecoderErrorCustom lbl + DecoderErrorCustom + lbl ("malformed field; must be: " <> hint) fieldPath :: Text - -- ^ Label + -- ^ Label -> TxMetadataValue - -- ^ Field key + -- ^ Field key -> Text fieldPath lbl (TxMetaNumber i) = lbl <> "." <> textShow i fieldPath lbl (TxMetaText t) = lbl <> "." <> t diff --git a/cardano-api/internal/Cardano/Api/HasTypeProxy.hs b/cardano-api/internal/Cardano/Api/HasTypeProxy.hs index 256c2cb74b..f15a3e07df 100644 --- a/cardano-api/internal/Cardano/Api/HasTypeProxy.hs +++ b/cardano-api/internal/Cardano/Api/HasTypeProxy.hs @@ -3,27 +3,24 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.Api.HasTypeProxy - ( HasTypeProxy(AsType, proxyToAsType) - , Proxy(..) - , FromSomeType(..) - ) where - -import Data.Kind (Constraint, Type) -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) + ( HasTypeProxy (AsType, proxyToAsType) + , Proxy (..) + , FromSomeType (..) + ) +where +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) class Typeable t => HasTypeProxy t where -- | A family of singleton types used in this API to indicate which type to -- use where it would otherwise be ambiguous or merely unclear. -- -- Values of this type are passed to deserialisation functions for example. - -- data AsType t proxyToAsType :: Proxy t -> AsType t - data FromSomeType (c :: Type -> Constraint) b where - FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b - + FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b diff --git a/cardano-api/internal/Cardano/Api/Hash.hs b/cardano-api/internal/Cardano/Api/Hash.hs index 8fed5cf3a9..4e84aca4fa 100644 --- a/cardano-api/internal/Cardano/Api/Hash.hs +++ b/cardano-api/internal/Cardano/Api/Hash.hs @@ -3,31 +3,26 @@ module Cardano.Api.Hash ( Hash - , CastHash(..) - , AsType(AsHash) + , CastHash (..) + , AsType (AsHash) , renderSafeHashAsHex - ) where - -import Cardano.Api.HasTypeProxy + ) +where +import Cardano.Api.HasTypeProxy import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Ledger.SafeHash as Ledger - -import Data.Kind (Type) +import Data.Kind (Type) import qualified Data.Text as Text - data family Hash keyrole :: Type class CastHash roleA roleB where - - castHash :: Hash roleA -> Hash roleB - + castHash :: Hash roleA -> Hash roleB instance HasTypeProxy a => HasTypeProxy (Hash a) where - data AsType (Hash a) = AsHash (AsType a) - proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a)) - + data AsType (Hash a) = AsHash (AsType a) + proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a)) renderSafeHashAsHex :: Ledger.SafeHash c tag -> Text.Text renderSafeHashAsHex = Hash.hashToTextAsHex . Ledger.extractHash diff --git a/cardano-api/internal/Cardano/Api/IO.hs b/cardano-api/internal/Cardano/Api/IO.hs index 6bfbc835c1..4b26d37750 100644 --- a/cardano-api/internal/Cardano/Api/IO.hs +++ b/cardano-api/internal/Cardano/Api/IO.hs @@ -7,76 +7,78 @@ module Cardano.Api.IO ( readByteStringFile , readLazyByteStringFile , readTextFile - , writeByteStringFileWithOwnerPermissions , writeByteStringFile , writeByteStringOutput - , writeLazyByteStringFileWithOwnerPermissions , writeLazyByteStringFile , writeLazyByteStringOutput - , writeTextFileWithOwnerPermissions , writeTextFile , writeTextOutput - - , File(..) - , FileDirection(..) + , File (..) + , FileDirection (..) , SocketPath - , mapFile , onlyIn , onlyOut - , intoFile - , checkVrfFilePermissions , writeSecrets - ) where - -import Cardano.Api.Error (FileError (..), fileIOExceptT) -import Cardano.Api.IO.Base -import Cardano.Api.IO.Compat - -import Control.Monad.Except (runExceptT) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except.Extra (handleIOExceptT) -import Data.ByteString (ByteString) + ) +where + +import Cardano.Api.Error (FileError (..), fileIOExceptT) +import Cardano.Api.IO.Base +import Cardano.Api.IO.Compat +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except.Extra (handleIOExceptT) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBSC -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text.IO as Text -readByteStringFile :: () +readByteStringFile + :: () => MonadIO m => File content In -> m (Either (FileError e) ByteString) -readByteStringFile fp = runExceptT $ - fileIOExceptT (unFile fp) BS.readFile +readByteStringFile fp = + runExceptT $ + fileIOExceptT (unFile fp) BS.readFile -readLazyByteStringFile :: () +readLazyByteStringFile + :: () => MonadIO m => File content In -> m (Either (FileError e) LBS.ByteString) -readLazyByteStringFile fp = runExceptT $ - fileIOExceptT (unFile fp) LBS.readFile +readLazyByteStringFile fp = + runExceptT $ + fileIOExceptT (unFile fp) LBS.readFile -readTextFile :: () +readTextFile + :: () => MonadIO m => File content In -> m (Either (FileError e) Text) -readTextFile fp = runExceptT $ - fileIOExceptT (unFile fp) Text.readFile +readTextFile fp = + runExceptT $ + fileIOExceptT (unFile fp) Text.readFile -writeByteStringFile :: () +writeByteStringFile + :: () => MonadIO m => File content Out -> ByteString -> m (Either (FileError e) ()) -writeByteStringFile fp bs = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ BS.writeFile (unFile fp) bs +writeByteStringFile fp bs = + runExceptT $ + handleIOExceptT (FileIOError (unFile fp)) $ + BS.writeFile (unFile fp) bs writeByteStringFileWithOwnerPermissions :: FilePath @@ -86,7 +88,8 @@ writeByteStringFileWithOwnerPermissions fp bs = handleFileForWritingWithOwnerPermission fp $ \h -> BS.hPut h bs -writeByteStringOutput :: () +writeByteStringOutput + :: () => MonadIO m => Maybe (File content Out) -> ByteString @@ -96,13 +99,16 @@ writeByteStringOutput mOutput bs = runExceptT $ Just fp -> handleIOExceptT (FileIOError (unFile fp)) $ BS.writeFile (unFile fp) bs Nothing -> liftIO $ BSC.putStr bs -writeLazyByteStringFile :: () +writeLazyByteStringFile + :: () => MonadIO m => File content Out -> LBS.ByteString -> m (Either (FileError e) ()) -writeLazyByteStringFile fp bs = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ LBS.writeFile (unFile fp) bs +writeLazyByteStringFile fp bs = + runExceptT $ + handleIOExceptT (FileIOError (unFile fp)) $ + LBS.writeFile (unFile fp) bs writeLazyByteStringFileWithOwnerPermissions :: File content Out @@ -112,7 +118,8 @@ writeLazyByteStringFileWithOwnerPermissions fp lbs = handleFileForWritingWithOwnerPermission (unFile fp) $ \h -> LBS.hPut h lbs -writeLazyByteStringOutput :: () +writeLazyByteStringOutput + :: () => MonadIO m => Maybe (File content Out) -> LBS.ByteString @@ -122,13 +129,16 @@ writeLazyByteStringOutput mOutput bs = runExceptT $ Just fp -> handleIOExceptT (FileIOError (unFile fp)) $ LBS.writeFile (unFile fp) bs Nothing -> liftIO $ LBSC.putStr bs -writeTextFile :: () +writeTextFile + :: () => MonadIO m => File content Out -> Text -> m (Either (FileError e) ()) -writeTextFile fp t = runExceptT $ - handleIOExceptT (FileIOError (unFile fp)) $ Text.writeFile (unFile fp) t +writeTextFile fp t = + runExceptT $ + handleIOExceptT (FileIOError (unFile fp)) $ + Text.writeFile (unFile fp) t writeTextFileWithOwnerPermissions :: File content Out @@ -138,7 +148,8 @@ writeTextFileWithOwnerPermissions fp t = handleFileForWritingWithOwnerPermission (unFile fp) $ \h -> Text.hPutStr h t -writeTextOutput :: () +writeTextOutput + :: () => MonadIO m => Maybe (File content Out) -> Text @@ -166,7 +177,8 @@ onlyOut = File . unFile -- -- Using this function ensures that the content type of the file always matches with the -- content value and prevents any type mismatches. -intoFile :: () +intoFile + :: () => File content 'Out -> content -> (File content 'Out -> stream -> result) diff --git a/cardano-api/internal/Cardano/Api/IO/Base.hs b/cardano-api/internal/Cardano/Api/IO/Base.hs index 39eb14a814..2a53be3f0d 100644 --- a/cardano-api/internal/Cardano/Api/IO/Base.hs +++ b/cardano-api/internal/Cardano/Api/IO/Base.hs @@ -5,29 +5,31 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Api.IO.Base - ( FileDirection(..) - , File(..) + ( FileDirection (..) + , File (..) , Socket , SocketPath - , VRFPrivateKeyFilePermissionError(..) - ) where + , VRFPrivateKeyFilePermissionError (..) + ) +where -import Data.Aeson (FromJSON, ToJSON) -import Data.String (IsString) +import Data.Aeson (FromJSON, ToJSON) +import Data.String (IsString) data FileDirection - = In - -- ^ Indicate the file is to be used for reading. - | Out - -- ^ Indicate the file is to be used for writing. - | InOut - -- ^ Indicate the file is to be used for both reading and writing. + = -- | Indicate the file is to be used for reading. + In + | -- | Indicate the file is to be used for writing. + Out + | -- | Indicate the file is to be used for both reading and writing. + InOut -- | A file path with additional type information to indicate what the file is meant to -- contain and whether it is to be used for reading or writing. newtype File content (direction :: FileDirection) = File { unFile :: FilePath - } deriving newtype (Eq, Ord, Read, Show, IsString, FromJSON, ToJSON) + } + deriving newtype (Eq, Ord, Read, Show, IsString, FromJSON, ToJSON) data Socket @@ -37,4 +39,4 @@ data VRFPrivateKeyFilePermissionError = OtherPermissionsExist FilePath | GroupPermissionsExist FilePath | GenericPermissionsExist FilePath - deriving Show + deriving (Show) diff --git a/cardano-api/internal/Cardano/Api/IO/Compat.hs b/cardano-api/internal/Cardano/Api/IO/Compat.hs index 6f74ce206a..4e67cb5642 100644 --- a/cardano-api/internal/Cardano/Api/IO/Compat.hs +++ b/cardano-api/internal/Cardano/Api/IO/Compat.hs @@ -5,16 +5,16 @@ module Cardano.Api.IO.Compat ( checkVrfFilePermissions , handleFileForWritingWithOwnerPermission , writeSecrets - ) where + ) +where -import Cardano.Api.Error -import Cardano.Api.IO.Base -import Cardano.Api.IO.Compat.Posix -import Cardano.Api.IO.Compat.Win32 - -import Control.Monad.Except (ExceptT) -import Data.ByteString (ByteString) -import System.IO +import Cardano.Api.Error +import Cardano.Api.IO.Base +import Cardano.Api.IO.Compat.Posix +import Cardano.Api.IO.Compat.Win32 +import Control.Monad.Except (ExceptT) +import Data.ByteString (ByteString) +import System.IO handleFileForWritingWithOwnerPermission :: FilePath diff --git a/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs b/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs index a95f4a897b..1806807fff 100644 --- a/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs +++ b/cardano-api/internal/Cardano/Api/IO/Compat/Posix.hs @@ -8,40 +8,49 @@ module Cardano.Api.IO.Compat.Posix ( #ifdef UNIX - VRFPrivateKeyFilePermissionError, - checkVrfFilePermissionsImpl, - handleFileForWritingWithOwnerPermissionImpl, - writeSecretsImpl, + VRFPrivateKeyFilePermissionError + , checkVrfFilePermissionsImpl + , handleFileForWritingWithOwnerPermissionImpl + , writeSecretsImpl #endif - ) where + ) +where #ifdef UNIX -import Cardano.Api.Error (FileError (..)) -import Cardano.Api.IO.Base - -import Control.Exception (IOException, bracket, bracketOnError, try) -import Control.Monad (forM_, when) -import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.IO.Class -import Control.Monad.Trans.Except.Extra (handleIOExceptT, left) +import Cardano.Api.Error (FileError (..)) +import Cardano.Api.IO.Base +import Control.Exception (IOException, bracket, bracketOnError, try) +import Control.Monad (forM_, when) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.IO.Class +import Control.Monad.Trans.Except.Extra (handleIOExceptT, left) import qualified Data.ByteString as BS -import System.Directory () -import System.FilePath (()) +import System.Directory () +import System.FilePath (()) +import System.IO (Handle) import qualified System.IO as IO -import System.IO (Handle) -import System.Posix.Files (fileMode, getFileStatus, groupModes, intersectFileModes, - nullFileMode, otherModes, ownerModes, ownerReadMode, setFdOwnerAndGroup, - setFileMode, stdFileMode) +import System.Posix.Files + ( fileMode + , getFileStatus + , groupModes + , intersectFileModes + , nullFileMode + , otherModes + , ownerModes + , ownerReadMode + , setFdOwnerAndGroup + , setFileMode + , stdFileMode + ) # if MIN_VERSION_unix(2,8,0) -import System.Posix.IO (OpenFileFlags (..), OpenMode (..), closeFd, defaultFileFlags, - fdToHandle, openFd) +import System.Posix.IO (OpenFileFlags (..), OpenMode (..), closeFd, defaultFileFlags, fdToHandle, openFd) #else -import System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, fdToHandle, openFd) +import System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, fdToHandle, openFd) #endif -import System.Posix.Types (Fd, FileMode) -import System.Posix.User (getRealUserID) -import Text.Printf (printf) +import System.Posix.Types (Fd, FileMode) +import System.Posix.User (getRealUserID) +import Text.Printf (printf) handleFileForWritingWithOwnerPermissionImpl :: FilePath @@ -52,14 +61,15 @@ handleFileForWritingWithOwnerPermissionImpl path f = do -- Since we're holding the file descriptor at this point, we can be sure that -- what we're about to write to is owned by us if an error didn't occur. user <- getRealUserID - ownedFile <- try $ - -- We only close the FD on error here, otherwise we let it leak out, since - -- it will be immediately turned into a Handle (which will be closed when - -- the Handle is closed) - bracketOnError - (openFileDescriptor path WriteOnly) - closeFd - (\fd -> setFdOwnerAndGroup fd user (-1) >> pure fd) + ownedFile <- + try $ + -- We only close the FD on error here, otherwise we let it leak out, since + -- it will be immediately turned into a Handle (which will be closed when + -- the Handle is closed) + bracketOnError + (openFileDescriptor path WriteOnly) + closeFd + (\fd -> setFdOwnerAndGroup fd user (-1) >> pure fd) case ownedFile of Left (err :: IOException) -> do pure $ Left $ FileIOError path err @@ -71,24 +81,27 @@ handleFileForWritingWithOwnerPermissionImpl path f = do writeSecretsImpl :: FilePath -> [Char] -> [Char] -> (a -> BS.ByteString) -> [a] -> IO () writeSecretsImpl outDir prefix suffix secretOp xs = - forM_ (zip xs [0::Int ..]) $ - \(secret, nr)-> do - let filename = outDir prefix <> "." <> printf "%03d" nr <> "." <> suffix - BS.writeFile filename $ secretOp secret - setFileMode filename ownerReadMode + forM_ (zip xs [0 :: Int ..]) $ + \(secret, nr) -> do + let filename = outDir prefix <> "." <> printf "%03d" nr <> "." <> suffix + BS.writeFile filename $ secretOp secret + setFileMode filename ownerReadMode -- | Make sure the VRF private key file is readable only -- by the current process owner the node is running under. -checkVrfFilePermissionsImpl :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO () +checkVrfFilePermissionsImpl + :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO () checkVrfFilePermissionsImpl (File vrfPrivKey) = do fs <- liftIO $ getFileStatus vrfPrivKey let fm = fileMode fs -- Check the the VRF private key file does not give read/write/exec permissions to others. - when (hasOtherPermissions fm) - (left $ OtherPermissionsExist vrfPrivKey) + when + (hasOtherPermissions fm) + (left $ OtherPermissionsExist vrfPrivKey) -- Check the the VRF private key file does not give read/write/exec permissions to any group. - when (hasGroupPermissions fm) - (left $ GroupPermissionsExist vrfPrivKey) + when + (hasGroupPermissions fm) + (left $ GroupPermissionsExist vrfPrivKey) where hasPermission :: FileMode -> FileMode -> Bool hasPermission fModeA fModeB = fModeA `intersectFileModes` fModeB /= nullFileMode @@ -103,34 +116,35 @@ checkVrfFilePermissionsImpl (File vrfPrivKey) = do openFileDescriptor :: FilePath -> OpenMode -> IO Fd # if MIN_VERSION_unix(2,8,0) openFileDescriptor fp openMode = - openFd fp openMode fileFlags - where - fileFlags = - case openMode of - ReadOnly -> - defaultFileFlags - ReadWrite -> - defaultFileFlags { creat = Just stdFileMode } - WriteOnly -> - defaultFileFlags { creat = Just ownerModes } + openFd fp openMode fileFlags + where + fileFlags = + case openMode of + ReadOnly -> + defaultFileFlags + ReadWrite -> + defaultFileFlags {creat = Just stdFileMode} + WriteOnly -> + defaultFileFlags {creat = Just ownerModes} # else openFileDescriptor fp openMode = - openFd fp openMode fMode fileFlags - where - (fMode, fileFlags) = - case openMode of - ReadOnly -> - ( Nothing - , defaultFileFlags - ) - ReadWrite -> - ( Just stdFileMode - , defaultFileFlags - ) - WriteOnly -> - ( Just ownerModes - , defaultFileFlags - ) + openFd fp openMode fMode fileFlags + where + (fMode, fileFlags) = + case openMode of + ReadOnly -> + ( Nothing + , defaultFileFlags + ) + ReadWrite -> + ( Just stdFileMode + , defaultFileFlags + ) + WriteOnly -> + ( Just ownerModes + , defaultFileFlags + ) + # endif #endif diff --git a/cardano-api/internal/Cardano/Api/IO/Compat/Win32.hs b/cardano-api/internal/Cardano/Api/IO/Compat/Win32.hs index a1b8b150cc..b7cef470a7 100644 --- a/cardano-api/internal/Cardano/Api/IO/Compat/Win32.hs +++ b/cardano-api/internal/Cardano/Api/IO/Compat/Win32.hs @@ -7,32 +7,32 @@ module Cardano.Api.IO.Compat.Win32 ( #ifndef UNIX - checkVrfFilePermissionsImpl, - handleFileForWritingWithOwnerPermissionImpl, - writeSecretsImpl, + checkVrfFilePermissionsImpl + , handleFileForWritingWithOwnerPermissionImpl + , writeSecretsImpl #endif - ) where + ) +where #ifndef UNIX -import Cardano.Api.Error (FileError (..)) -import Cardano.Api.IO.Base - -import Control.Exception (bracketOnError) -import Control.Monad (forM_, when) -import Control.Monad.Except (ExceptT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except.Extra (left) -import Data.Bits -import Data.ByteString (ByteString) +import Cardano.Api.Error (FileError (..)) +import Cardano.Api.IO.Base +import Control.Exception (bracketOnError) +import Control.Monad (forM_, when) +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except.Extra (left) +import Data.Bits +import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import System.Directory (emptyPermissions, readable, setPermissions) import qualified System.Directory as IO -import System.Directory (emptyPermissions, readable, setPermissions) -import System.FilePath (splitFileName, (<.>), ()) +import System.FilePath (splitFileName, (<.>), ()) +import System.IO (Handle) import qualified System.IO as IO -import System.IO (Handle) -import System.Win32.File -import Text.Printf (printf) +import System.Win32.File +import Text.Printf (printf) handleFileForWritingWithOwnerPermissionImpl :: FilePath @@ -44,29 +44,31 @@ handleFileForWritingWithOwnerPermissionImpl path f = do -- won't work correctly with pseudo-files. bracketOnError (IO.openTempFile targetDir $ targetFile <.> "tmp") - (\(tmpPath, h) -> do - IO.hClose h >> IO.removeFile tmpPath - return . Left $ FileErrorTempFile path tmpPath h) - (\(tmpPath, h) -> do + ( \(tmpPath, h) -> do + IO.hClose h >> IO.removeFile tmpPath + return . Left $ FileErrorTempFile path tmpPath h + ) + ( \(tmpPath, h) -> do f h IO.hClose h IO.renameFile tmpPath path - return $ Right ()) - where - (targetDir, targetFile) = splitFileName path + return $ Right () + ) + where + (targetDir, targetFile) = splitFileName path writeSecretsImpl :: FilePath -> [Char] -> [Char] -> (a -> ByteString) -> [a] -> IO () writeSecretsImpl outDir prefix suffix secretOp xs = - forM_ (zip xs [0::Int ..]) $ - \(secret, nr)-> do - let filename = outDir prefix <> "." <> printf "%03d" nr <> "." <> suffix - BS.writeFile filename $ secretOp secret - setPermissions filename (emptyPermissions {readable = True}) - + forM_ (zip xs [0 :: Int ..]) $ + \(secret, nr) -> do + let filename = outDir prefix <> "." <> printf "%03d" nr <> "." <> suffix + BS.writeFile filename $ secretOp secret + setPermissions filename (emptyPermissions {readable = True}) -- | Make sure the VRF private key file is readable only -- by the current process owner the node is running under. -checkVrfFilePermissionsImpl :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO () +checkVrfFilePermissionsImpl + :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO () checkVrfFilePermissionsImpl (File vrfPrivKey) = do attribs <- liftIO $ getFileAttributes vrfPrivKey -- https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea @@ -74,8 +76,9 @@ checkVrfFilePermissionsImpl (File vrfPrivKey) = do -- https://docs.microsoft.com/en-us/windows/win32/secauthz/standard-access-rights -- https://docs.microsoft.com/en-us/windows/win32/secauthz/generic-access-rights -- https://docs.microsoft.com/en-us/windows/win32/secauthz/access-mask - when (attribs `hasPermission` genericPermissions) - (left $ GenericPermissionsExist vrfPrivKey) + when + (attribs `hasPermission` genericPermissions) + (left $ GenericPermissionsExist vrfPrivKey) where genericPermissions = gENERIC_ALL .|. gENERIC_READ .|. gENERIC_WRITE .|. gENERIC_EXECUTE hasPermission fModeA fModeB = fModeA .&. fModeB /= gENERIC_NONE diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs index 258769290c..862b85e767 100644 --- a/cardano-api/internal/Cardano/Api/IPC.hs +++ b/cardano-api/internal/Cardano/Api/IPC.hs @@ -7,92 +7,104 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} - -- The Shelley ledger uses promoted data kinds which we have to use, but we do -- not export any from this API. We also use them unticked as nature intended. {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- | Node IPC protocols --- -module Cardano.Api.IPC ( - -- * Node interaction +module Cardano.Api.IPC + ( -- * Node interaction + -- | Operations that involve talking to a local Cardano node. - connectToLocalNode, - connectToLocalNodeWithVersion, - LocalNodeConnectInfo(..), - LocalNodeClientParams(..), - mkLocalNodeClientParams, - LocalNodeClientProtocols(..), - LocalChainSyncClient(..), - LocalNodeClientProtocolsInMode, + connectToLocalNode + , connectToLocalNodeWithVersion + , LocalNodeConnectInfo (..) + , LocalNodeClientParams (..) + , mkLocalNodeClientParams + , LocalNodeClientProtocols (..) + , LocalChainSyncClient (..) + , LocalNodeClientProtocolsInMode -- ** Modes - -- | TODO move to Cardano.Api - ConsensusModeParams(..), - EpochSlots(..), --- connectToRemoteNode, + -- | TODO move to Cardano.Api + , ConsensusModeParams (..) + , EpochSlots (..) + -- connectToRemoteNode, -- *** Chain sync protocol - ChainSyncClient(..), - ChainSyncClientPipelined(..), - BlockInMode(..), + , ChainSyncClient (..) + , ChainSyncClientPipelined (..) + , BlockInMode (..) -- *** Local tx submission - LocalTxSubmissionClient(..), - TxInMode(..), - TxValidationErrorInCardanoMode, - TxValidationError, - submitTxToNodeLocal, - SubmitResult(..), + , LocalTxSubmissionClient (..) + , TxInMode (..) + , TxValidationErrorInCardanoMode + , TxValidationError + , submitTxToNodeLocal + , SubmitResult (..) -- *** Local state query - LocalStateQueryClient(..), - AcquiringFailure(..), - QueryInMode(..), - QueryInEra(..), - QueryInShelleyBasedEra(..), - queryNodeLocalState, + , LocalStateQueryClient (..) + , AcquiringFailure (..) + , QueryInMode (..) + , QueryInEra (..) + , QueryInShelleyBasedEra (..) + , queryNodeLocalState -- *** Local tx monitoring - LocalTxMonitorClient(..), - LocalTxMonitoringQuery(..), - LocalTxMonitoringResult(..), - Consensus.MempoolSizeAndCapacity(..), - queryTxMonitoringLocal, - - EraHistory(..), - getProgress, + , LocalTxMonitorClient (..) + , LocalTxMonitoringQuery (..) + , LocalTxMonitoringResult (..) + , Consensus.MempoolSizeAndCapacity (..) + , queryTxMonitoringLocal + , EraHistory (..) + , getProgress -- *** Common queries - getLocalChainTip, + , getLocalChainTip -- *** Helpers - --TODO: These should be exported via Cardano.Api.Mode - toAcquiringFailure, - - NodeToClientVersion(..), - - UnsupportedNtcVersionError(..), - ) where - -import Cardano.Api.Block -import Cardano.Api.HasTypeProxy -import Cardano.Api.InMode -import Cardano.Api.IO -import Cardano.Api.IPC.Version -import Cardano.Api.Modes -import Cardano.Api.Monad.Error (ExceptT (..)) -import Cardano.Api.NetworkId -import Cardano.Api.Protocol -import Cardano.Api.Query -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign + -- TODO: These should be exported via Cardano.Api.Mode + , toAcquiringFailure + , NodeToClientVersion (..) + , UnsupportedNtcVersionError (..) + ) +where + +import Cardano.Api.Block +import Cardano.Api.HasTypeProxy +import Cardano.Api.IO +import Cardano.Api.IPC.Version +import Cardano.Api.InMode +import Cardano.Api.Modes +import Cardano.Api.Monad.Error (ExceptT (..)) +import Cardano.Api.NetworkId +import Cardano.Api.Protocol +import Cardano.Api.Query +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign import qualified Cardano.Ledger.Api as L +import Control.Concurrent.STM + ( TMVar + , atomically + , newEmptyTMVarIO + , putTMVar + , takeTMVar + , tryPutTMVar + ) +import Control.Monad (void) +import Control.Monad.IO.Class +import Control.Tracer (nullTracer) +import Data.Aeson (ToJSON, object, toJSON, (.=)) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import Data.Void (Void) import qualified Ouroboros.Consensus.Block as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import Ouroboros.Consensus.Cardano.CanHardFork +import Ouroboros.Consensus.Cardano.CanHardFork import qualified Ouroboros.Consensus.Ledger.Query as Consensus import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus @@ -101,37 +113,33 @@ import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as Consensus import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus -import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import qualified Ouroboros.Network.Block as Net import qualified Ouroboros.Network.Mux as Net -import Ouroboros.Network.NodeToClient (NodeToClientProtocols (..), - NodeToClientVersionData (..)) +import Ouroboros.Network.NodeToClient + ( NodeToClientProtocols (..) + , NodeToClientVersionData (..) + ) import qualified Ouroboros.Network.NodeToClient as Net -import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) -import Ouroboros.Network.Protocol.ChainSync.Client as Net.Sync -import Ouroboros.Network.Protocol.ChainSync.ClientPipelined as Net.SyncP -import Ouroboros.Network.Protocol.LocalStateQuery.Client (LocalStateQueryClient (..)) +import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) +import Ouroboros.Network.Protocol.ChainSync.Client as Net.Sync +import Ouroboros.Network.Protocol.ChainSync.ClientPipelined as Net.SyncP +import Ouroboros.Network.Protocol.LocalStateQuery.Client (LocalStateQueryClient (..)) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query -import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..)) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query -import Ouroboros.Network.Protocol.LocalTxMonitor.Client (LocalTxMonitorClient (..), - localTxMonitorClientPeer) +import Ouroboros.Network.Protocol.LocalTxMonitor.Client + ( LocalTxMonitorClient (..) + , localTxMonitorClientPeer + ) import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Client as CTxMon import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as Consensus -import Ouroboros.Network.Protocol.LocalTxSubmission.Client (LocalTxSubmissionClient (..), - SubmitResult (..)) +import Ouroboros.Network.Protocol.LocalTxSubmission.Client + ( LocalTxSubmissionClient (..) + , SubmitResult (..) + ) import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx -import Control.Concurrent.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar, - tryPutTMVar) -import Control.Monad (void) -import Control.Monad.IO.Class -import Control.Tracer (nullTracer) -import Data.Aeson (ToJSON, object, toJSON, (.=)) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map.Strict as Map -import Data.Void (Void) - -- ---------------------------------------------------------------------------- -- The types for the client side of the node-to-client IPC protocols -- @@ -142,19 +150,18 @@ import Data.Void (Void) -- These protocols use the types from the rest of this API. The conversion -- to\/from the types used by the underlying wire formats is handled by -- 'connectToLocalNode'. --- -data LocalNodeClientProtocols block point tip slot tx txid txerr query m = - LocalNodeClientProtocols - { localChainSyncClient :: LocalChainSyncClient block point tip m - , localTxSubmissionClient :: Maybe (LocalTxSubmissionClient tx txerr m ()) - , localStateQueryClient :: Maybe (LocalStateQueryClient block point query m ()) - , localTxMonitoringClient :: Maybe (LocalTxMonitorClient txid tx slot m ()) - } +data LocalNodeClientProtocols block point tip slot tx txid txerr query m + = LocalNodeClientProtocols + { localChainSyncClient :: LocalChainSyncClient block point tip m + , localTxSubmissionClient :: Maybe (LocalTxSubmissionClient tx txerr m ()) + , localStateQueryClient :: Maybe (LocalStateQueryClient block point query m ()) + , localTxMonitoringClient :: Maybe (LocalTxMonitorClient txid tx slot m ()) + } data LocalChainSyncClient block point tip m = NoLocalChainSyncClient - | LocalChainSyncClientPipelined (ChainSyncClientPipelined block point tip m ()) - | LocalChainSyncClient (ChainSyncClient block point tip m ()) + | LocalChainSyncClientPipelined (ChainSyncClientPipelined block point tip m ()) + | LocalChainSyncClient (ChainSyncClient block point tip m ()) -- public, exported type LocalNodeClientProtocolsInMode = @@ -169,12 +176,12 @@ type LocalNodeClientProtocolsInMode = QueryInMode IO -data LocalNodeConnectInfo = - LocalNodeConnectInfo - { localConsensusModeParams :: ConsensusModeParams - , localNodeNetworkId :: NetworkId - , localNodeSocketPath :: SocketPath - } +data LocalNodeConnectInfo + = LocalNodeConnectInfo + { localConsensusModeParams :: ConsensusModeParams + , localNodeNetworkId :: NetworkId + , localNodeSocketPath :: SocketPath + } -- ---------------------------------------------------------------------------- -- Actually connect to the node @@ -182,39 +189,39 @@ data LocalNodeConnectInfo = -- | Establish a connection to a local node and execute the given set of -- protocol handlers. --- connectToLocalNode :: MonadIO m => LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> m () -connectToLocalNode localNodeConnectInfo handlers - = connectToLocalNodeWithVersion localNodeConnectInfo (const handlers) +connectToLocalNode localNodeConnectInfo handlers = + connectToLocalNodeWithVersion localNodeConnectInfo (const handlers) -- | Establish a connection to a local node and execute the given set of -- protocol handlers parameterized on the negotiated node-to-client protocol -- version. --- connectToLocalNodeWithVersion :: MonadIO m => LocalNodeConnectInfo -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> m () -connectToLocalNodeWithVersion LocalNodeConnectInfo { - localNodeSocketPath, - localNodeNetworkId, - localConsensusModeParams - } clients = +connectToLocalNodeWithVersion + LocalNodeConnectInfo + { localNodeSocketPath + , localNodeNetworkId + , localConsensusModeParams + } + clients = liftIO $ Net.withIOManager $ \iomgr -> Net.connectTo (Net.localSnocket iomgr) - Net.NetworkConnectTracers { - Net.nctMuxTracer = nullTracer, - Net.nctHandshakeTracer = nullTracer - } + Net.NetworkConnectTracers + { Net.nctMuxTracer = nullTracer + , Net.nctHandshakeTracer = nullTracer + } versionedProtocls (unFile localNodeSocketPath) - where + where versionedProtocls = -- First convert from the mode-parametrised view of things to the -- block-parametrised view and then do the final setup for the versioned @@ -225,105 +232,119 @@ connectToLocalNodeWithVersion LocalNodeConnectInfo { LocalNodeClientParamsCardano ptcl clients' -> mkVersionedProtocols localNodeNetworkId ptcl clients' -mkVersionedProtocols :: forall block. - ( Consensus.ShowQuery (Consensus.Query block) - , ProtocolClient block - ) - => NetworkId - -> ProtocolClientInfoArgs block - -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) - -> Net.Versions - Net.NodeToClientVersion - Net.NodeToClientVersionData - (Net.OuroborosApplicationWithMinimalCtx - Net.InitiatorMode - Net.LocalAddress - LBS.ByteString IO () Void) +mkVersionedProtocols + :: forall block + . ( Consensus.ShowQuery (Consensus.Query block) + , ProtocolClient block + ) + => NetworkId + -> ProtocolClientInfoArgs block + -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) + -> Net.Versions + Net.NodeToClientVersion + Net.NodeToClientVersionData + ( Net.OuroborosApplicationWithMinimalCtx + Net.InitiatorMode + Net.LocalAddress + LBS.ByteString + IO + () + Void + ) mkVersionedProtocols networkid ptcl unversionedClients = - --TODO: really we should construct specific combinations of - -- protocols for the versions we know about, with different protocol - -- versions taking different sets of typed client protocols. - Net.foldMapVersions - (\(ptclVersion, ptclBlockVersion) -> - Net.versionedNodeToClientProtocols - ptclVersion - NodeToClientVersionData { - networkMagic = toNetworkMagic networkid, - query = False + -- TODO: really we should construct specific combinations of + -- protocols for the versions we know about, with different protocol + -- versions taking different sets of typed client protocols. + Net.foldMapVersions + ( \(ptclVersion, ptclBlockVersion) -> + Net.versionedNodeToClientProtocols + ptclVersion + NodeToClientVersionData + { networkMagic = toNetworkMagic networkid + , query = False } - (protocols (unversionedClients ptclVersion) ptclBlockVersion ptclVersion)) - (Map.toList (Consensus.supportedNodeToClientVersions proxy)) - where - proxy :: Proxy block - proxy = Proxy - - protocols :: LocalNodeClientProtocolsForBlock block - -> Consensus.BlockNodeToClientVersion block - -> NodeToClientVersion - -> NodeToClientProtocols Net.InitiatorMode Net.LocalAddress LBS.ByteString IO () Void - protocols - LocalNodeClientProtocolsForBlock { - localChainSyncClientForBlock, - localTxSubmissionClientForBlock, - localStateQueryClientForBlock, - localTxMonitoringClientForBlock + (protocols (unversionedClients ptclVersion) ptclBlockVersion ptclVersion) + ) + (Map.toList (Consensus.supportedNodeToClientVersions proxy)) + where + proxy :: Proxy block + proxy = Proxy + + protocols + :: LocalNodeClientProtocolsForBlock block + -> Consensus.BlockNodeToClientVersion block + -> NodeToClientVersion + -> NodeToClientProtocols Net.InitiatorMode Net.LocalAddress LBS.ByteString IO () Void + protocols + LocalNodeClientProtocolsForBlock + { localChainSyncClientForBlock + , localTxSubmissionClientForBlock + , localStateQueryClientForBlock + , localTxMonitoringClientForBlock } - ptclBlockVersion - ptclVersion = - NodeToClientProtocols { - localChainSyncProtocol = + ptclBlockVersion + ptclVersion = + NodeToClientProtocols + { localChainSyncProtocol = Net.InitiatorProtocolOnly $ case localChainSyncClientForBlock of - NoLocalChainSyncClient - -> Net.mkMiniProtocolCbFromPeer $ const - (nullTracer, cChainSyncCodec, Net.chainSyncPeerNull) - LocalChainSyncClient client - -> Net.mkMiniProtocolCbFromPeer $ const - (nullTracer, cChainSyncCodec, Net.Sync.chainSyncClientPeer client) - LocalChainSyncClientPipelined clientPipelined - -> Net.mkMiniProtocolCbFromPeerPipelined $ const - (nullTracer, cChainSyncCodec, Net.SyncP.chainSyncClientPeerPipelined clientPipelined) - + NoLocalChainSyncClient -> + Net.mkMiniProtocolCbFromPeer $ + const + (nullTracer, cChainSyncCodec, Net.chainSyncPeerNull) + LocalChainSyncClient client -> + Net.mkMiniProtocolCbFromPeer $ + const + (nullTracer, cChainSyncCodec, Net.Sync.chainSyncClientPeer client) + LocalChainSyncClientPipelined clientPipelined -> + Net.mkMiniProtocolCbFromPeerPipelined $ + const + (nullTracer, cChainSyncCodec, Net.SyncP.chainSyncClientPeerPipelined clientPipelined) , localTxSubmissionProtocol = Net.InitiatorProtocolOnly $ - Net.mkMiniProtocolCbFromPeer $ const - ( nullTracer - , cTxSubmissionCodec - , maybe Net.localTxSubmissionPeerNull - Net.Tx.localTxSubmissionClientPeer - localTxSubmissionClientForBlock - ) - + Net.mkMiniProtocolCbFromPeer $ + const + ( nullTracer + , cTxSubmissionCodec + , maybe + Net.localTxSubmissionPeerNull + Net.Tx.localTxSubmissionClientPeer + localTxSubmissionClientForBlock + ) , localStateQueryProtocol = Net.InitiatorProtocolOnly $ - Net.mkMiniProtocolCbFromPeer $ const - ( nullTracer - , cStateQueryCodec - , maybe Net.localStateQueryPeerNull - Net.Query.localStateQueryClientPeer - localStateQueryClientForBlock - ) + Net.mkMiniProtocolCbFromPeer $ + const + ( nullTracer + , cStateQueryCodec + , maybe + Net.localStateQueryPeerNull + Net.Query.localStateQueryClientPeer + localStateQueryClientForBlock + ) , localTxMonitorProtocol = Net.InitiatorProtocolOnly $ - Net.mkMiniProtocolCbFromPeer $ const - ( nullTracer - , cTxMonitorCodec - , maybe Net.localTxMonitorPeerNull - localTxMonitorClientPeer - localTxMonitoringClientForBlock - ) + Net.mkMiniProtocolCbFromPeer $ + const + ( nullTracer + , cTxMonitorCodec + , maybe + Net.localTxMonitorPeerNull + localTxMonitorClientPeer + localTxMonitoringClientForBlock + ) } - where - Consensus.Codecs { - Consensus.cChainSyncCodec, - Consensus.cTxMonitorCodec, - Consensus.cTxSubmissionCodec, - Consensus.cStateQueryCodec + where + Consensus.Codecs + { Consensus.cChainSyncCodec + , Consensus.cTxMonitorCodec + , Consensus.cTxSubmissionCodec + , Consensus.cStateQueryCodec } = Consensus.clientCodecs codecConfig ptclBlockVersion ptclVersion - codecConfig :: Consensus.CodecConfig block - codecConfig = Consensus.pClientInfoCodecConfig - (protocolClientInfo ptcl) - + codecConfig :: Consensus.CodecConfig block + codecConfig = + Consensus.pClientInfoCodecConfig + (protocolClientInfo ptcl) -- | This type defines the boundary between the mode-parametrised style used in -- this API and the block-parametrised style used by the underlying network @@ -335,99 +356,108 @@ mkVersionedProtocols networkid ptcl unversionedClients = -- It bundles together all the necessary class instances, the consensus -- protocol client identifier, and the set of client side mini-protocol -- handlers for the node-to-client protocol. --- data LocalNodeClientParams where - LocalNodeClientParamsSingleBlock - :: (ProtocolClient block, - Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock + LocalNodeClientParamsSingleBlock + :: ( ProtocolClient block + , Consensus.LedgerSupportsProtocol + ( Consensus.ShelleyBlock (Consensus.TPraos Consensus.StandardCrypto) - (Consensus.ShelleyEra Consensus.StandardCrypto)) - - ) - => ProtocolClientInfoArgs block - -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) - -> LocalNodeClientParams - - LocalNodeClientParamsCardano - :: (ProtocolClient block, CardanoHardForkConstraints (ConsensusCryptoForBlock block)) - => ProtocolClientInfoArgs block - -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) - -> LocalNodeClientParams - -data LocalNodeClientProtocolsForBlock block = - LocalNodeClientProtocolsForBlock { - localChainSyncClientForBlock - :: LocalChainSyncClient block - (Consensus.Point block) - (Net.Tip block) - IO - - , localStateQueryClientForBlock - :: Maybe (LocalStateQueryClient block - (Consensus.Point block) - (Consensus.Query block) - IO ()) - - , localTxSubmissionClientForBlock - :: Maybe (LocalTxSubmissionClient (Consensus.GenTx block) - (Consensus.ApplyTxErr block) - IO ()) - , localTxMonitoringClientForBlock - :: Maybe (LocalTxMonitorClient (Consensus.TxId (Consensus.GenTx block)) - (Consensus.GenTx block) - SlotNo IO ()) - } - + (Consensus.ShelleyEra Consensus.StandardCrypto) + ) + ) + => ProtocolClientInfoArgs block + -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) + -> LocalNodeClientParams + LocalNodeClientParamsCardano + :: (ProtocolClient block, CardanoHardForkConstraints (ConsensusCryptoForBlock block)) + => ProtocolClientInfoArgs block + -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) + -> LocalNodeClientParams + +data LocalNodeClientProtocolsForBlock block + = LocalNodeClientProtocolsForBlock + { localChainSyncClientForBlock + :: LocalChainSyncClient + block + (Consensus.Point block) + (Net.Tip block) + IO + , localStateQueryClientForBlock + :: Maybe + ( LocalStateQueryClient + block + (Consensus.Point block) + (Consensus.Query block) + IO + () + ) + , localTxSubmissionClientForBlock + :: Maybe + ( LocalTxSubmissionClient + (Consensus.GenTx block) + (Consensus.ApplyTxErr block) + IO + () + ) + , localTxMonitoringClientForBlock + :: Maybe + ( LocalTxMonitorClient + (Consensus.TxId (Consensus.GenTx block)) + (Consensus.GenTx block) + SlotNo + IO + () + ) + } -- | Convert from the mode-parametrised style to the block-parametrised style. --- -mkLocalNodeClientParams :: - ConsensusModeParams +mkLocalNodeClientParams + :: ConsensusModeParams -> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> LocalNodeClientParams mkLocalNodeClientParams modeparams clients = - -- For each of the possible consensus modes we pick the concrete block type - -- (by picking the appropriate 'ProtocolClient' value). - -- - -- Though it is not immediately visible, this point where we use - -- 'LocalNodeClientParams' is also where we pick up the necessary class - -- instances. This works because in each case we have a monomorphic block - -- type and the instances are all in scope. This is why the use of - -- LocalNodeClientParams is repeated within each branch of the case: - -- because it is only within each branch that the GADT match makes the - -- block type monomorphic. - -- - case modeparams of - CardanoModeParams epochSlots -> - LocalNodeClientParamsCardano - (ProtocolClientInfoArgsCardano epochSlots) - (convLocalNodeClientProtocols . clients) - - -convLocalNodeClientProtocols :: () + -- For each of the possible consensus modes we pick the concrete block type + -- (by picking the appropriate 'ProtocolClient' value). + -- + -- Though it is not immediately visible, this point where we use + -- 'LocalNodeClientParams' is also where we pick up the necessary class + -- instances. This works because in each case we have a monomorphic block + -- type and the instances are all in scope. This is why the use of + -- LocalNodeClientParams is repeated within each branch of the case: + -- because it is only within each branch that the GADT match makes the + -- block type monomorphic. + -- + case modeparams of + CardanoModeParams epochSlots -> + LocalNodeClientParamsCardano + (ProtocolClientInfoArgsCardano epochSlots) + (convLocalNodeClientProtocols . clients) + +convLocalNodeClientProtocols + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => LocalNodeClientProtocolsInMode -> LocalNodeClientProtocolsForBlock block convLocalNodeClientProtocols - LocalNodeClientProtocols { - localChainSyncClient, - localTxSubmissionClient, - localStateQueryClient, - localTxMonitoringClient + LocalNodeClientProtocols + { localChainSyncClient + , localTxSubmissionClient + , localStateQueryClient + , localTxMonitoringClient } = - LocalNodeClientProtocolsForBlock { - localChainSyncClientForBlock = case localChainSyncClient of - NoLocalChainSyncClient -> NoLocalChainSyncClient - LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined clientPipelined - LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient client, - - localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient, - localStateQueryClientForBlock = convLocalStateQueryClient <$> localStateQueryClient, - localTxMonitoringClientForBlock = convLocalTxMonitoringClient <$> localTxMonitoringClient - } + LocalNodeClientProtocolsForBlock + { localChainSyncClientForBlock = case localChainSyncClient of + NoLocalChainSyncClient -> NoLocalChainSyncClient + LocalChainSyncClientPipelined clientPipelined -> LocalChainSyncClientPipelined $ convLocalChainSyncClientPipelined clientPipelined + LocalChainSyncClient client -> LocalChainSyncClient $ convLocalChainSyncClient client + , localTxSubmissionClientForBlock = convLocalTxSubmissionClient <$> localTxSubmissionClient + , localStateQueryClientForBlock = convLocalStateQueryClient <$> localStateQueryClient + , localTxMonitoringClientForBlock = convLocalTxMonitoringClient <$> localTxMonitoringClient + } -convLocalTxMonitoringClient :: forall block m a. () +convLocalTxMonitoringClient + :: forall block m a + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => LocalTxMonitorClient TxIdInMode TxInMode SlotNo m a @@ -438,19 +468,22 @@ convLocalTxMonitoringClient = fromConsensusGenTx convLocalChainSyncClient - :: forall block m a. () + :: forall block m a + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ChainSyncClient BlockInMode ChainPoint ChainTip m a -> ChainSyncClient block (Net.Point block) (Net.Tip block) m a convLocalChainSyncClient = - Net.Sync.mapChainSyncClient - toConsensusPointHF - fromConsensusPointHF - fromConsensusBlock - fromConsensusTip + Net.Sync.mapChainSyncClient + toConsensusPointHF + fromConsensusPointHF + fromConsensusBlock + fromConsensusTip -convLocalChainSyncClientPipelined :: forall block m a. () +convLocalChainSyncClientPipelined + :: forall block m a + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a @@ -462,7 +495,9 @@ convLocalChainSyncClientPipelined = fromConsensusBlock fromConsensusTip -convLocalTxSubmissionClient :: forall block m a. () +convLocalTxSubmissionClient + :: forall block m a + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m a @@ -471,108 +506,115 @@ convLocalTxSubmissionClient = Net.Tx.mapLocalTxSubmissionClient toConsensusGenTx fromConsensusApplyTxErr convLocalStateQueryClient - :: forall block m a. () + :: forall block m a + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => Functor m => LocalStateQueryClient BlockInMode ChainPoint QueryInMode m a -> LocalStateQueryClient block (Consensus.Point block) (Consensus.Query block) m a convLocalStateQueryClient = - Net.Query.mapLocalStateQueryClient - toConsensusPointHF - toConsensusQuery - fromConsensusQueryResult + Net.Query.mapLocalStateQueryClient + toConsensusPointHF + toConsensusQuery + fromConsensusQueryResult ---TODO: Move to consensus -mapLocalTxMonitoringClient :: forall txid txid' tx tx' m a. () +-- TODO: Move to consensus +mapLocalTxMonitoringClient + :: forall txid txid' tx tx' m a + . () => Functor m => (txid -> txid') - -> (tx'-> tx) + -> (tx' -> tx) -> LocalTxMonitorClient txid tx SlotNo m a -> LocalTxMonitorClient txid' tx' SlotNo m a mapLocalTxMonitoringClient convTxid convTx ltxmc = let LocalTxMonitorClient idleEff = ltxmc - in LocalTxMonitorClient (fmap convClientStateIdle idleEff) + in LocalTxMonitorClient (fmap convClientStateIdle idleEff) where - convClientStateIdle - :: CTxMon.ClientStIdle txid tx SlotNo m a - -> CTxMon.ClientStIdle txid' tx' SlotNo m a - convClientStateIdle (CTxMon.SendMsgAcquire f) = - CTxMon.SendMsgAcquire $ (fmap . fmap) convClientStateAcquired f - convClientStateIdle (CTxMon.SendMsgDone a) = CTxMon.SendMsgDone a - - convClientStateAcquired - :: CTxMon.ClientStAcquired txid tx SlotNo m a - -> CTxMon.ClientStAcquired txid' tx' SlotNo m a - convClientStateAcquired (CTxMon.SendMsgNextTx f) = - CTxMon.SendMsgNextTx (\mTx -> convClientStateAcquired <$> f (convTx <$> mTx)) - convClientStateAcquired (CTxMon.SendMsgHasTx txid f)= - CTxMon.SendMsgHasTx (convTxid txid) ((fmap . fmap) convClientStateAcquired f) - convClientStateAcquired (CTxMon.SendMsgGetSizes f) = - CTxMon.SendMsgGetSizes $ (fmap . fmap) convClientStateAcquired f - convClientStateAcquired (CTxMon.SendMsgAwaitAcquire f) = - CTxMon.SendMsgAwaitAcquire $ (fmap . fmap ) convClientStateAcquired f - convClientStateAcquired (CTxMon.SendMsgRelease eff) = - CTxMon.SendMsgRelease (convClientStateIdle <$> eff) + convClientStateIdle + :: CTxMon.ClientStIdle txid tx SlotNo m a + -> CTxMon.ClientStIdle txid' tx' SlotNo m a + convClientStateIdle (CTxMon.SendMsgAcquire f) = + CTxMon.SendMsgAcquire $ (fmap . fmap) convClientStateAcquired f + convClientStateIdle (CTxMon.SendMsgDone a) = CTxMon.SendMsgDone a + + convClientStateAcquired + :: CTxMon.ClientStAcquired txid tx SlotNo m a + -> CTxMon.ClientStAcquired txid' tx' SlotNo m a + convClientStateAcquired (CTxMon.SendMsgNextTx f) = + CTxMon.SendMsgNextTx (\mTx -> convClientStateAcquired <$> f (convTx <$> mTx)) + convClientStateAcquired (CTxMon.SendMsgHasTx txid f) = + CTxMon.SendMsgHasTx (convTxid txid) ((fmap . fmap) convClientStateAcquired f) + convClientStateAcquired (CTxMon.SendMsgGetSizes f) = + CTxMon.SendMsgGetSizes $ (fmap . fmap) convClientStateAcquired f + convClientStateAcquired (CTxMon.SendMsgAwaitAcquire f) = + CTxMon.SendMsgAwaitAcquire $ (fmap . fmap) convClientStateAcquired f + convClientStateAcquired (CTxMon.SendMsgRelease eff) = + CTxMon.SendMsgRelease (convClientStateIdle <$> eff) -- ---------------------------------------------------------------------------- -- Wrappers for specific protocol use-cases -- ---TODO: change this query to be just a protocol client handler to be used with +-- TODO: change this query to be just a protocol client handler to be used with -- connectToLocalNode. This would involve changing connectToLocalNode to be -- able to return protocol handler results properly. -- | Establish a connection to a node and execute a single query using the -- local state query protocol. --- - -data AcquiringFailure = AFPointTooOld - | AFPointNotOnChain - deriving (Eq, Show) +data AcquiringFailure + = AFPointTooOld + | AFPointNotOnChain + deriving (Eq, Show) toAcquiringFailure :: Net.Query.AcquireFailure -> AcquiringFailure toAcquiringFailure AcquireFailurePointTooOld = AFPointTooOld toAcquiringFailure AcquireFailurePointNotOnChain = AFPointNotOnChain -queryNodeLocalState :: forall result. () +queryNodeLocalState + :: forall result + . () => LocalNodeConnectInfo -> Net.Query.Target ChainPoint -> QueryInMode result -> ExceptT AcquiringFailure IO result queryNodeLocalState connctInfo mpoint query = do - resultVar <- liftIO newEmptyTMVarIO - connectToLocalNode - connctInfo - LocalNodeClientProtocols { - localChainSyncClient = NoLocalChainSyncClient, - localStateQueryClient = Just (singleQuery mpoint resultVar), - localTxSubmissionClient = Nothing, - localTxMonitoringClient = Nothing + resultVar <- liftIO newEmptyTMVarIO + connectToLocalNode + connctInfo + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = Just (singleQuery mpoint resultVar) + , localTxSubmissionClient = Nothing + , localTxMonitoringClient = Nothing } - ExceptT $ atomically (takeTMVar resultVar) - where - singleQuery - :: Net.Query.Target ChainPoint - -> TMVar (Either AcquiringFailure result) - -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO () - singleQuery mPointVar' resultVar' = - LocalStateQueryClient $ do + ExceptT $ atomically (takeTMVar resultVar) + where + singleQuery + :: Net.Query.Target ChainPoint + -> TMVar (Either AcquiringFailure result) + -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO () + singleQuery mPointVar' resultVar' = + LocalStateQueryClient $ do pure $ Net.Query.SendMsgAcquire mPointVar' $ - Net.Query.ClientStAcquiring - { Net.Query.recvMsgAcquired = - pure $ Net.Query.SendMsgQuery query $ - Net.Query.ClientStQuerying - { Net.Query.recvMsgResult = \result -> do - atomically $ putTMVar resultVar' (Right result) - - pure $ Net.Query.SendMsgRelease $ - pure $ Net.Query.SendMsgDone () - } - , Net.Query.recvMsgFailure = \failure -> do - atomically $ putTMVar resultVar' (Left (toAcquiringFailure failure)) - pure $ Net.Query.SendMsgDone () - } + Net.Query.ClientStAcquiring + { Net.Query.recvMsgAcquired = + pure $ + Net.Query.SendMsgQuery query $ + Net.Query.ClientStQuerying + { Net.Query.recvMsgResult = \result -> do + atomically $ putTMVar resultVar' (Right result) + + pure $ + Net.Query.SendMsgRelease $ + pure $ + Net.Query.SendMsgDone () + } + , Net.Query.recvMsgFailure = \failure -> do + atomically $ putTMVar resultVar' (Left (toAcquiringFailure failure)) + pure $ Net.Query.SendMsgDone () + } submitTxToNodeLocal :: MonadIO m @@ -580,84 +622,88 @@ submitTxToNodeLocal -> TxInMode -> m (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) submitTxToNodeLocal connctInfo tx = do - resultVar <- liftIO newEmptyTMVarIO - connectToLocalNode - connctInfo - LocalNodeClientProtocols { - localChainSyncClient = NoLocalChainSyncClient, - localTxSubmissionClient = Just (localTxSubmissionClientSingle resultVar), - localStateQueryClient = Nothing, - localTxMonitoringClient = Nothing + resultVar <- liftIO newEmptyTMVarIO + connectToLocalNode + connctInfo + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localTxSubmissionClient = Just (localTxSubmissionClientSingle resultVar) + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing } - liftIO $ atomically (takeTMVar resultVar) - where - localTxSubmissionClientSingle :: () - => TMVar (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) - -> Net.Tx.LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () - localTxSubmissionClientSingle resultVar = - LocalTxSubmissionClient $ - pure $ Net.Tx.SendMsgSubmitTx tx $ \result -> do - atomically $ putTMVar resultVar result - pure (Net.Tx.SendMsgDone ()) - + liftIO $ atomically (takeTMVar resultVar) + where + localTxSubmissionClientSingle + :: () + => TMVar (Net.Tx.SubmitResult TxValidationErrorInCardanoMode) + -> Net.Tx.LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode IO () + localTxSubmissionClientSingle resultVar = + LocalTxSubmissionClient $ + pure $ + Net.Tx.SendMsgSubmitTx tx $ \result -> do + atomically $ putTMVar resultVar result + pure (Net.Tx.SendMsgDone ()) data LocalTxMonitoringResult - = LocalTxMonitoringTxExists + = -- | Slot number at which the mempool snapshot was taken + LocalTxMonitoringTxExists TxId - SlotNo -- ^ Slot number at which the mempool snapshot was taken - | LocalTxMonitoringTxDoesNotExist + SlotNo + | -- | Slot number at which the mempool snapshot was taken + LocalTxMonitoringTxDoesNotExist TxId - SlotNo -- ^ Slot number at which the mempool snapshot was taken - | LocalTxMonitoringNextTx + SlotNo + | -- | Slot number at which the mempool snapshot was taken + LocalTxMonitoringNextTx (Maybe TxInMode) - SlotNo -- ^ Slot number at which the mempool snapshot was taken - | LocalTxMonitoringMempoolSizeAndCapacity + SlotNo + | -- | Slot number at which the mempool snapshot was taken + LocalTxMonitoringMempoolSizeAndCapacity Consensus.MempoolSizeAndCapacity - SlotNo -- ^ Slot number at which the mempool snapshot was taken + SlotNo instance ToJSON LocalTxMonitoringResult where toJSON result = object $ case result of LocalTxMonitoringTxExists tx slot -> - [ "exists" .= True - , "txId" .= tx - , "slot" .= slot - ] + [ "exists" .= True + , "txId" .= tx + , "slot" .= slot + ] LocalTxMonitoringTxDoesNotExist tx slot -> - [ "exists" .= False - , "txId" .= tx - , "slot" .= slot - ] + [ "exists" .= False + , "txId" .= tx + , "slot" .= slot + ] LocalTxMonitoringNextTx txInMode slot -> - [ "nextTx" .= txId - , "slot" .= slot - ] - where - txId = case txInMode of - Just (TxInMode _ tx) -> Just $ getTxId $ getTxBody tx - -- TODO: support fetching the ID of a Byron Era transaction - _ -> Nothing + [ "nextTx" .= txId + , "slot" .= slot + ] + where + txId = case txInMode of + Just (TxInMode _ tx) -> Just $ getTxId $ getTxBody tx + -- TODO: support fetching the ID of a Byron Era transaction + _ -> Nothing LocalTxMonitoringMempoolSizeAndCapacity mempool slot -> - [ "capacityInBytes" .= Consensus.capacityInBytes mempool - , "sizeInBytes" .= Consensus.sizeInBytes mempool - , "numberOfTxs" .= Consensus.numberOfTxs mempool - , "slot" .= slot - ] + [ "capacityInBytes" .= Consensus.capacityInBytes mempool + , "sizeInBytes" .= Consensus.sizeInBytes mempool + , "numberOfTxs" .= Consensus.numberOfTxs mempool + , "slot" .= slot + ] data LocalTxMonitoringQuery - -- | Query if a particular tx exists in the mempool. Note that, the absence - -- of a transaction does not imply anything about how the transaction was - -- processed: it may have been dropped, or inserted in a block. - = LocalTxMonitoringQueryTx TxIdInMode - -- | The mempool is modeled as an ordered list of transactions and thus, can - -- be traversed linearly. 'LocalTxMonitoringSendNextTx' requests the next transaction from the - -- current list. This must be a transaction that was not previously sent to - -- the client for this particular snapshot. - | LocalTxMonitoringSendNextTx - -- | Ask the server about the current mempool's capacity and sizes. This is - -- fixed in a given snapshot. - | LocalTxMonitoringMempoolInformation - + = -- | Query if a particular tx exists in the mempool. Note that, the absence + -- of a transaction does not imply anything about how the transaction was + -- processed: it may have been dropped, or inserted in a block. + LocalTxMonitoringQueryTx TxIdInMode + | -- | The mempool is modeled as an ordered list of transactions and thus, can + -- be traversed linearly. 'LocalTxMonitoringSendNextTx' requests the next transaction from the + -- current list. This must be a transaction that was not previously sent to + -- the client for this particular snapshot. + LocalTxMonitoringSendNextTx + | -- | Ask the server about the current mempool's capacity and sizes. This is + -- fixed in a given snapshot. + LocalTxMonitoringMempoolInformation queryTxMonitoringLocal :: MonadIO m @@ -668,37 +714,40 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do resultVar <- liftIO newEmptyTMVarIO let client = case localTxMonitoringQuery of - LocalTxMonitoringQueryTx txidInMode -> - localTxMonitorClientTxExists txidInMode resultVar - LocalTxMonitoringSendNextTx -> - localTxMonitorNextTx resultVar - LocalTxMonitoringMempoolInformation -> - localTxMonitorMempoolInfo resultVar + LocalTxMonitoringQueryTx txidInMode -> + localTxMonitorClientTxExists txidInMode resultVar + LocalTxMonitoringSendNextTx -> + localTxMonitorNextTx resultVar + LocalTxMonitoringMempoolInformation -> + localTxMonitorMempoolInfo resultVar connectToLocalNode connectInfo - LocalNodeClientProtocols { - localChainSyncClient = NoLocalChainSyncClient, - localTxSubmissionClient = Nothing, - localStateQueryClient = Nothing, - localTxMonitoringClient = Just client - } + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Just client + } liftIO $ atomically (takeTMVar resultVar) where - localTxMonitorClientTxExists :: () + localTxMonitorClientTxExists + :: () => TxIdInMode -> TMVar LocalTxMonitoringResult -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () localTxMonitorClientTxExists tIdInMode@(TxIdInMode _ txid) resultVar = do - LocalTxMonitorClient $ return $ - CTxMon.SendMsgAcquire $ \slt -> do - return $ CTxMon.SendMsgHasTx tIdInMode $ \txPresentBool -> do - if txPresentBool - then atomically . putTMVar resultVar $ LocalTxMonitoringTxExists txid slt - else atomically . putTMVar resultVar $ LocalTxMonitoringTxDoesNotExist txid slt - return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () - - localTxMonitorNextTx :: () + LocalTxMonitorClient $ + return $ + CTxMon.SendMsgAcquire $ \slt -> do + return $ CTxMon.SendMsgHasTx tIdInMode $ \txPresentBool -> do + if txPresentBool + then atomically . putTMVar resultVar $ LocalTxMonitoringTxExists txid slt + else atomically . putTMVar resultVar $ LocalTxMonitoringTxDoesNotExist txid slt + return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () + + localTxMonitorNextTx + :: () => TMVar LocalTxMonitoringResult -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () localTxMonitorNextTx resultVar = @@ -708,13 +757,14 @@ queryTxMonitoringLocal connectInfo localTxMonitoringQuery = do atomically $ putTMVar resultVar $ LocalTxMonitoringNextTx mTx slt return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () - localTxMonitorMempoolInfo :: () + localTxMonitorMempoolInfo + :: () => TMVar LocalTxMonitoringResult -> LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO () localTxMonitorMempoolInfo resultVar = - LocalTxMonitorClient $ return $ do + LocalTxMonitorClient $ return $ do CTxMon.SendMsgAcquire $ \slt -> do - return$ CTxMon.SendMsgGetSizes $ \mempoolCapacity -> do + return $ CTxMon.SendMsgGetSizes $ \mempoolCapacity -> do atomically $ putTMVar resultVar $ LocalTxMonitoringMempoolSizeAndCapacity mempoolCapacity slt return $ CTxMon.SendMsgRelease $ return $ CTxMon.SendMsgDone () @@ -727,18 +777,19 @@ getLocalChainTip => LocalNodeConnectInfo -> m ChainTip getLocalChainTip localNodeConInfo = do - resultVar <- liftIO newEmptyTMVarIO - connectToLocalNode - localNodeConInfo - LocalNodeClientProtocols - { localChainSyncClient = LocalChainSyncClient $ chainSyncGetCurrentTip resultVar - , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing - , localTxMonitoringClient = Nothing - } - liftIO . atomically $ takeTMVar resultVar + resultVar <- liftIO newEmptyTMVarIO + connectToLocalNode + localNodeConInfo + LocalNodeClientProtocols + { localChainSyncClient = LocalChainSyncClient $ chainSyncGetCurrentTip resultVar + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } + liftIO . atomically $ takeTMVar resultVar -chainSyncGetCurrentTip :: () +chainSyncGetCurrentTip + :: () => TMVar ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip IO () chainSyncGetCurrentTip tipVar = @@ -749,11 +800,12 @@ chainSyncGetCurrentTip tipVar = Net.Sync.SendMsgRequestNext (pure ()) clientStNext clientStNext :: Net.Sync.ClientStNext BlockInMode ChainPoint ChainTip IO () - clientStNext = Net.Sync.ClientStNext - { Net.Sync.recvMsgRollForward = \_block tip -> ChainSyncClient $ do - void $ atomically $ tryPutTMVar tipVar tip - pure $ Net.Sync.SendMsgDone () - , Net.Sync.recvMsgRollBackward = \_point tip -> ChainSyncClient $ do - void $ atomically $ tryPutTMVar tipVar tip - pure $ Net.Sync.SendMsgDone () - } + clientStNext = + Net.Sync.ClientStNext + { Net.Sync.recvMsgRollForward = \_block tip -> ChainSyncClient $ do + void $ atomically $ tryPutTMVar tipVar tip + pure $ Net.Sync.SendMsgDone () + , Net.Sync.recvMsgRollBackward = \_point tip -> ChainSyncClient $ do + void $ atomically $ tryPutTMVar tipVar tip + pure $ Net.Sync.SendMsgDone () + } diff --git a/cardano-api/internal/Cardano/Api/IPC/Monad.hs b/cardano-api/internal/Cardano/Api/IPC/Monad.hs index 9318478bb1..16925360b3 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Monad.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Monad.hs @@ -6,22 +6,21 @@ module Cardano.Api.IPC.Monad ( LocalStateQueryExpr , executeLocalStateQueryExpr , queryExpr - ) where + ) +where -import Cardano.Api.Block -import Cardano.Api.IPC -import Cardano.Api.IPC.Version - -import Cardano.Ledger.Shelley.Scripts () +import Cardano.Api.Block +import Cardano.Api.IPC +import Cardano.Api.IPC.Version +import Cardano.Ledger.Shelley.Scripts () +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Cont import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Cont - {- HLINT ignore "Use const" -} {- HLINT ignore "Use let" -} @@ -37,11 +36,14 @@ import Control.Monad.Trans.Cont -- In order to make pipelining still possible we can explore the use of Selective Functors -- which would allow us to straddle both worlds. newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr - { runLocalStateQueryExpr :: ReaderT NodeToClientVersion (ContT (Net.Query.ClientStAcquired block point query m r) m) a - } deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO) + { runLocalStateQueryExpr + :: ReaderT NodeToClientVersion (ContT (Net.Query.ClientStAcquired block point query m r) m) a + } + deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO) -- | Execute a local state query expression. -executeLocalStateQueryExpr :: () +executeLocalStateQueryExpr + :: () => LocalNodeConnectInfo -> Net.Query.Target ChainPoint -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a @@ -52,23 +54,24 @@ executeLocalStateQueryExpr connectInfo target f = do connectToLocalNodeWithVersion connectInfo - (\ntcVersion -> - LocalNodeClientProtocols - { localChainSyncClient = NoLocalChainSyncClient - , localStateQueryClient = Just $ setupLocalStateQueryExpr waitResult target tmvResultLocalState ntcVersion f - , localTxSubmissionClient = Nothing - , localTxMonitoringClient = Nothing - } + ( \ntcVersion -> + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = + Just $ setupLocalStateQueryExpr waitResult target tmvResultLocalState ntcVersion f + , localTxSubmissionClient = Nothing + , localTxMonitoringClient = Nothing + } ) atomically waitResult -- | Use 'queryExpr' in a do block to construct monadic local state queries. -setupLocalStateQueryExpr :: - STM x - -- ^ An STM expression that only returns when all protocols are complete. - -- Protocols must wait until 'waitDone' returns because premature exit will - -- cause other incomplete protocols to abort which may lead to deadlock. +setupLocalStateQueryExpr + :: STM x + -- ^ An STM expression that only returns when all protocols are complete. + -- Protocols must wait until 'waitDone' returns because premature exit will + -- cause other incomplete protocols to abort which may lead to deadlock. -> Net.Query.Target ChainPoint -> TMVar (Either AcquiringFailure a) -> NodeToClientVersion @@ -77,31 +80,32 @@ setupLocalStateQueryExpr :: setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f = LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $ Net.Query.ClientStAcquiring - { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr f) ntcVersion) $ \result -> do - atomically $ putTMVar resultVar' (Right result) - void $ atomically waitDone -- Wait for all protocols to complete before exiting. - pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone () - - , Net.Query.recvMsgFailure = \failure -> do - atomically $ putTMVar resultVar' (Left (toAcquiringFailure failure)) - void $ atomically waitDone -- Wait for all protocols to complete before exiting. - pure $ Net.Query.SendMsgDone () - } + { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr f) ntcVersion) $ \result -> do + atomically $ putTMVar resultVar' (Right result) + void $ atomically waitDone -- Wait for all protocols to complete before exiting. + pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone () + , Net.Query.recvMsgFailure = \failure -> do + atomically $ putTMVar resultVar' (Left (toAcquiringFailure failure)) + void $ atomically waitDone -- Wait for all protocols to complete before exiting. + pure $ Net.Query.SendMsgDone () + } -- | Get the node server's Node-to-Client version. getNtcVersion :: LocalStateQueryExpr block point QueryInMode r IO NodeToClientVersion getNtcVersion = LocalStateQueryExpr ask -- | Use 'queryExpr' in a do block to construct monadic local state queries. -queryExpr :: QueryInMode a -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError a) +queryExpr + :: QueryInMode a + -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError a) queryExpr q = do let minNtcVersion = nodeToClientVersionOf q ntcVersion <- getNtcVersion if ntcVersion >= minNtcVersion - then - fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $ + then fmap Right . LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> + pure $ Net.Query.SendMsgQuery q $ Net.Query.ClientStQuerying - { Net.Query.recvMsgResult = f - } + { Net.Query.recvMsgResult = f + } else pure (Left (UnsupportedNtcVersionError minNtcVersion ntcVersion)) diff --git a/cardano-api/internal/Cardano/Api/IPC/Version.hs b/cardano-api/internal/Cardano/Api/IPC/Version.hs index e04fc34546..f2adb0a018 100644 --- a/cardano-api/internal/Cardano/Api/IPC/Version.hs +++ b/cardano-api/internal/Cardano/Api/IPC/Version.hs @@ -2,11 +2,12 @@ module Cardano.Api.IPC.Version ( NodeToClientVersionOf (..) , MinNodeToClientVersion - -- *** Error types - , UnsupportedNtcVersionError(..) - ) where + -- *** Error types + , UnsupportedNtcVersionError (..) + ) +where -import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) +import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) -- | The query 'a' is a versioned query, which means it requires the Node to support a minimum -- Node-to-Client version. diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index d5bc0cf28b..cd6c3276b5 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -10,48 +10,45 @@ -- | Transactions in the context of a consensus mode, and other types used in -- the transaction submission protocol. --- -module Cardano.Api.InMode ( - - -- * Transaction in a consensus mode - TxInMode(..), - fromConsensusGenTx, - toConsensusGenTx, +module Cardano.Api.InMode + ( -- * Transaction in a consensus mode + TxInMode (..) + , fromConsensusGenTx + , toConsensusGenTx -- * Transaction id in a consensus mode - TxIdInMode(..), - toConsensusTxId, + , TxIdInMode (..) + , toConsensusTxId -- * Transaction validation errors - TxValidationError(..), - TxValidationErrorInCardanoMode(..), - fromConsensusApplyTxErr, - ) where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Modes -import Cardano.Api.Orphans () -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.Utils (textShow) - + , TxValidationError (..) + , TxValidationErrorInCardanoMode (..) + , fromConsensusApplyTxErr + ) +where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.Modes +import Cardano.Api.Orphans () +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.Utils (textShow) import qualified Cardano.Ledger.Api as L +import Data.Aeson (ToJSON (..), (.=)) +import qualified Data.Aeson as Aeson +import Data.SOP.Strict (NS (S, Z)) +import qualified Data.Text as Text +import GHC.Generics import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus -import Data.Aeson (ToJSON (..), (.=)) -import qualified Data.Aeson as Aeson -import Data.SOP.Strict (NS (S, Z)) -import qualified Data.Text as Text -import GHC.Generics - -- ---------------------------------------------------------------------------- -- Transactions in the context of a consensus mode -- @@ -61,26 +58,23 @@ import GHC.Generics -- For multi-era modes such as the 'CardanoMode' this type is a sum of the -- different transaction types for all the eras. It is used in the -- LocalTxSubmission protocol. --- data TxInMode where -- | Shelley based transactions. - -- TxInMode :: ShelleyBasedEra era -> Tx era -> TxInMode - -- | Legacy Byron transactions and things we can -- post to the chain which are not actually transactions. -- This covers: update proposals, votes and delegation certs. - -- TxInByronSpecial :: Consensus.GenTx Consensus.ByronBlock -> TxInMode deriving instance Show TxInMode -fromConsensusGenTx :: () +fromConsensusGenTx + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => Consensus.GenTx block -> TxInMode @@ -89,61 +83,54 @@ fromConsensusGenTx = \case TxInByronSpecial tx' Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraShelley (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) + in TxInMode ShelleyBasedEraShelley (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx')))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraAllegra (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) + in TxInMode ShelleyBasedEraAllegra (ShelleyTx ShelleyBasedEraAllegra shelleyEraTx) Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx'))))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraMary (ShelleyTx ShelleyBasedEraMary shelleyEraTx) + in TxInMode ShelleyBasedEraMary (ShelleyTx ShelleyBasedEraMary shelleyEraTx) Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx')))))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraAlonzo (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) + in TxInMode ShelleyBasedEraAlonzo (ShelleyTx ShelleyBasedEraAlonzo shelleyEraTx) Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx'))))))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraBabbage (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) + in TxInMode ShelleyBasedEraBabbage (ShelleyTx ShelleyBasedEraBabbage shelleyEraTx) Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' - in TxInMode ShelleyBasedEraConway (ShelleyTx ShelleyBasedEraConway shelleyEraTx) - + in TxInMode ShelleyBasedEraConway (ShelleyTx ShelleyBasedEraConway shelleyEraTx) -toConsensusGenTx :: () +toConsensusGenTx + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => TxInMode -> Consensus.GenTx block toConsensusGenTx (TxInByronSpecial gtx) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) toConsensusGenTx (TxInMode ShelleyBasedEraShelley (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) + where + tx' = Consensus.mkShelleyTx tx toConsensusGenTx (TxInMode ShelleyBasedEraAllegra (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx')))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (Z tx')))) + where + tx' = Consensus.mkShelleyTx tx toConsensusGenTx (TxInMode ShelleyBasedEraMary (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx'))))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (Z tx'))))) + where + tx' = Consensus.mkShelleyTx tx toConsensusGenTx (TxInMode ShelleyBasedEraAlonzo (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx')))))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (Z tx')))))) + where + tx' = Consensus.mkShelleyTx tx toConsensusGenTx (TxInMode ShelleyBasedEraBabbage (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx'))))))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx'))))))) + where + tx' = Consensus.mkShelleyTx tx toConsensusGenTx (TxInMode ShelleyBasedEraConway (ShelleyTx _ tx)) = - Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) - where - tx' = Consensus.mkShelleyTx tx - + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) + where + tx' = Consensus.mkShelleyTx tx -- ---------------------------------------------------------------------------- -- Transaction ids in the context of a consensus mode @@ -162,48 +149,46 @@ data TxIdInMode where -> TxId -> TxIdInMode -toConsensusTxId :: () +toConsensusTxId + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => TxIdInMode - -> Consensus.TxId (Consensus.GenTx block) + -> Consensus.TxId (Consensus.GenTx block) toConsensusTxId (TxIdInMode ByronEra txid) = Consensus.HardForkGenTxId . Consensus.OneEraGenTxId . Z $ Consensus.WrapGenTxId txid' where txid' :: Consensus.TxId (Consensus.GenTx Consensus.ByronBlock) txid' = Consensus.ByronTxId $ toByronTxId txid - toConsensusTxId (TxIdInMode ShelleyEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (Z (Consensus.WrapGenTxId txid')))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardShelleyBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid - toConsensusTxId (TxIdInMode AllegraEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (Z (Consensus.WrapGenTxId txid'))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAllegraBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid - toConsensusTxId (TxIdInMode MaryEra txid) = Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (Z (Consensus.WrapGenTxId txid')))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardMaryBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid - toConsensusTxId (TxIdInMode AlonzoEra txid) = - Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))) + Consensus.HardForkGenTxId + (Consensus.OneEraGenTxId (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAlonzoBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid - toConsensusTxId (TxIdInMode BabbageEra txid) = - Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))) + Consensus.HardForkGenTxId + (Consensus.OneEraGenTxId (S (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardBabbageBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid - toConsensusTxId (TxIdInMode ConwayEra txid) = - Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))))) + Consensus.HardForkGenTxId + (Consensus.OneEraGenTxId (S (S (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))))) where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardConwayBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid @@ -214,12 +199,10 @@ toConsensusTxId (TxIdInMode ConwayEra txid) = -- | The transaction validations errors that can occur from trying to submit a -- transaction to a local node. The errors are specific to an era. --- data TxValidationError era where ByronTxValidationError :: Consensus.ApplyTxErr Consensus.ByronBlock -> TxValidationError era - ShelleyTxValidationError :: ShelleyBasedEra era -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)) @@ -230,27 +213,28 @@ deriving instance Generic (TxValidationError era) instance Show (TxValidationError era) where showsPrec p = \case ByronTxValidationError err -> - showParen (p >= 11) + showParen + (p >= 11) ( showString "ByronTxValidationError " - . showsPrec 11 err + . showsPrec 11 err ) - ShelleyTxValidationError sbe err -> shelleyBasedEraConstraints sbe $ - showParen (p >= 11) + showParen + (p >= 11) ( showString "ShelleyTxValidationError " - . showString (show sbe) - . showString " " - . showsPrec 11 err + . showString (show sbe) + . showString " " + . showsPrec 11 err ) instance ToJSON (TxValidationError era) where toJSON = \case ByronTxValidationError err -> - Aeson.object - [ "kind" .= Aeson.String "ByronTxValidationError" - , "error" .= toJSON err - ] + Aeson.object + [ "kind" .= Aeson.String "ByronTxValidationError" + , "error" .= toJSON err + ] ShelleyTxValidationError sbe err -> shelleyBasedEraConstraints sbe $ Aeson.object @@ -259,7 +243,8 @@ instance ToJSON (TxValidationError era) where , "error" .= appTxErrToJson sbe err ] -appTxErrToJson :: () +appTxErrToJson + :: () => ShelleyBasedEra era -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)) -> Aeson.Value @@ -269,13 +254,13 @@ appTxErrToJson w e = shelleyBasedEraConstraints w $ toJSON e -- mode. -- -- This is used in the LocalStateQuery protocol. --- data TxValidationErrorInCardanoMode where - TxValidationErrorInCardanoMode :: () + TxValidationErrorInCardanoMode + :: () => TxValidationError era -> TxValidationErrorInCardanoMode - - TxValidationEraMismatch :: () + TxValidationEraMismatch + :: () => EraMismatch -> TxValidationErrorInCardanoMode @@ -294,7 +279,8 @@ instance ToJSON TxValidationErrorInCardanoMode where , "contents" .= toJSON (textShow err) ] -fromConsensusApplyTxErr :: () +fromConsensusApplyTxErr + :: () => Consensus.CardanoBlock L.StandardCrypto ~ block => Consensus.ApplyTxErr block -> TxValidationErrorInCardanoMode diff --git a/cardano-api/internal/Cardano/Api/Json.hs b/cardano-api/internal/Cardano/Api/Json.hs index 639026c6c9..dde472de3b 100644 --- a/cardano-api/internal/Cardano/Api/Json.hs +++ b/cardano-api/internal/Cardano/Api/Json.hs @@ -1,9 +1,10 @@ module Cardano.Api.Json ( toRationalJSON - ) where + ) +where -import Data.Aeson -import Data.Scientific +import Data.Aeson +import Data.Scientific -- Rationals and JSON are an awkward mix. We cannot convert rationals -- like @1/3@ to JSON numbers. But _most_ of the numbers we want to use @@ -15,4 +16,4 @@ toRationalJSON :: Rational -> Value toRationalJSON r = case fromRationalRepetendLimited 20 r of Right (s, Nothing) -> toJSON s - _ -> toJSON r + _ -> toJSON r diff --git a/cardano-api/internal/Cardano/Api/Keys/Byron.hs b/cardano-api/internal/Cardano/Api/Keys/Byron.hs index fd3e0a9567..76bc76cc5b 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Byron.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Byron.hs @@ -9,37 +9,34 @@ {-# LANGUAGE TypeFamilies #-} -- | Byron key types and their 'Key' class instances --- -module Cardano.Api.Keys.Byron ( - - -- * Key types - ByronKey, - ByronKeyLegacy, +module Cardano.Api.Keys.Byron + ( -- * Key types + ByronKey + , ByronKeyLegacy -- * Data family instances - AsType(..), - VerificationKey(..), - SigningKey(..), - Hash(..), + , AsType (..) + , VerificationKey (..) + , SigningKey (..) + , Hash (..) -- * Legacy format - IsByronKey(..), - ByronKeyFormat(..), - - SomeByronSigningKey(..), - toByronSigningKey - ) where - -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Class -import Cardano.Api.Keys.Shelley -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing - -import Cardano.Binary (cborError, toStrictByteString) + , IsByronKey (..) + , ByronKeyFormat (..) + , SomeByronSigningKey (..) + , toByronSigningKey + ) +where + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Class +import Cardano.Api.Keys.Shelley +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Binary (cborError, toStrictByteString) import qualified Cardano.Chain.Common as Crypto import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hashing as Crypto @@ -47,18 +44,16 @@ import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Crypto.Signing as Crypto import qualified Cardano.Crypto.Wallet as Crypto.HD import qualified Cardano.Crypto.Wallet as Wallet - import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Read as CBOR -import Control.Monad -import Data.Bifunctor +import Control.Monad +import Data.Bifunctor import qualified Data.ByteString.Lazy as LB -import Data.Either.Combinators -import Data.String (IsString) -import Data.Text (Text) +import Data.Either.Combinators +import Data.String (IsString) +import Data.Text (Text) import qualified Data.Text as Text -import Formatting (build, formatToString) - +import Formatting (build, formatToString) -- | Byron-era payment keys. Used for Byron addresses and witnessing -- transactions that spend from these addresses. @@ -69,12 +64,12 @@ import Formatting (build, formatToString) -- a chaincode. It is safe to use a zero or random chaincode for new Byron keys. -- -- This is a type level tag, used with other interfaces like 'Key'. --- data ByronKey + data ByronKeyLegacy class IsByronKey key where - byronKeyFormat :: ByronKeyFormat key + byronKeyFormat :: ByronKeyFormat key data ByronKeyFormat key where ByronLegacyKeyFormat :: ByronKeyFormat ByronKeyLegacy @@ -95,85 +90,88 @@ toByronSigningKey bWit = -- instance Key ByronKey where - - newtype VerificationKey ByronKey = - ByronVerificationKey Crypto.VerificationKey - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKey = - ByronSigningKey Crypto.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType ByronKey -> Crypto.Seed -> SigningKey ByronKey - deterministicSigningKey AsByronKey seed = - ByronSigningKey (snd (Crypto.runMonadRandomWithSeed seed Crypto.keyGen)) - - deterministicSigningKeySeedSize :: AsType ByronKey -> Word - deterministicSigningKeySeedSize AsByronKey = 32 - - getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey - getVerificationKey (ByronSigningKey sk) = - ByronVerificationKey (Crypto.toVerification sk) - - verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey - verificationKeyHash (ByronVerificationKey vkey) = - ByronKeyHash (Crypto.hashKey vkey) + newtype VerificationKey ByronKey + = ByronVerificationKey Crypto.VerificationKey + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey ByronKey + = ByronSigningKey Crypto.SigningKey + deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType ByronKey -> Crypto.Seed -> SigningKey ByronKey + deterministicSigningKey AsByronKey seed = + ByronSigningKey (snd (Crypto.runMonadRandomWithSeed seed Crypto.keyGen)) + + deterministicSigningKeySeedSize :: AsType ByronKey -> Word + deterministicSigningKeySeedSize AsByronKey = 32 + + getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey + getVerificationKey (ByronSigningKey sk) = + ByronVerificationKey (Crypto.toVerification sk) + + verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey + verificationKeyHash (ByronVerificationKey vkey) = + ByronKeyHash (Crypto.hashKey vkey) instance HasTypeProxy ByronKey where - data AsType ByronKey = AsByronKey - proxyToAsType _ = AsByronKey + data AsType ByronKey = AsByronKey + proxyToAsType _ = AsByronKey instance HasTextEnvelope (VerificationKey ByronKey) where - textEnvelopeType _ = "PaymentVerificationKeyByron_ed25519_bip32" + textEnvelopeType _ = "PaymentVerificationKeyByron_ed25519_bip32" instance HasTextEnvelope (SigningKey ByronKey) where - textEnvelopeType _ = "PaymentSigningKeyByron_ed25519_bip32" + textEnvelopeType _ = "PaymentSigningKeyByron_ed25519_bip32" instance SerialiseAsRawBytes (VerificationKey ByronKey) where - serialiseToRawBytes (ByronVerificationKey (Crypto.VerificationKey xvk)) = - Crypto.HD.unXPub xvk + serialiseToRawBytes (ByronVerificationKey (Crypto.VerificationKey xvk)) = + Crypto.HD.unXPub xvk - deserialiseFromRawBytes (AsVerificationKey AsByronKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey ByronKey" ++ msg)) $ - ByronVerificationKey . Crypto.VerificationKey <$> Crypto.HD.xpub bs + deserialiseFromRawBytes (AsVerificationKey AsByronKey) bs = + first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey ByronKey" ++ msg)) $ + ByronVerificationKey . Crypto.VerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey ByronKey) where - serialiseToRawBytes (ByronSigningKey sk) = toStrictByteString $ toCBOR sk + serialiseToRawBytes (ByronSigningKey sk) = toStrictByteString $ toCBOR sk - deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = - first (\e -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey ByronKey" ++ show e)) $ - ByronSigningKey . snd <$> CBOR.deserialiseFromBytes fromCBOR (LB.fromStrict bs) + deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = + first (\e -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey ByronKey" ++ show e)) $ + ByronSigningKey . snd <$> CBOR.deserialiseFromBytes fromCBOR (LB.fromStrict bs) newtype instance Hash ByronKey = ByronKeyHash Crypto.KeyHash deriving (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash ByronKey) where - serialiseToRawBytes (ByronKeyHash (Crypto.KeyHash vkh)) = - Crypto.abstractHashToBytes vkh + serialiseToRawBytes (ByronKeyHash (Crypto.KeyHash vkh)) = + Crypto.abstractHashToBytes vkh - deserialiseFromRawBytes (AsHash AsByronKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ByronKey") $ - ByronKeyHash . Crypto.KeyHash <$> Crypto.abstractHashFromBytes bs + deserialiseFromRawBytes (AsHash AsByronKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ByronKey") $ + ByronKeyHash . Crypto.KeyHash <$> Crypto.abstractHashFromBytes bs instance CastVerificationKeyRole ByronKey PaymentExtendedKey where - castVerificationKey (ByronVerificationKey vk) = - PaymentExtendedVerificationKey - (Crypto.unVerificationKey vk) + castVerificationKey (ByronVerificationKey vk) = + PaymentExtendedVerificationKey + (Crypto.unVerificationKey vk) instance CastVerificationKeyRole ByronKey PaymentKey where - castVerificationKey = - (castVerificationKey :: VerificationKey PaymentExtendedKey - -> VerificationKey PaymentKey) - . (castVerificationKey :: VerificationKey ByronKey - -> VerificationKey PaymentExtendedKey) + castVerificationKey = + ( castVerificationKey + :: VerificationKey PaymentExtendedKey + -> VerificationKey PaymentKey + ) + . ( castVerificationKey + :: VerificationKey ByronKey + -> VerificationKey PaymentExtendedKey + ) instance IsByronKey ByronKey where byronKeyFormat = ByronModernKeyFormat @@ -183,113 +181,117 @@ instance IsByronKey ByronKey where -- instance Key ByronKeyLegacy where + newtype VerificationKey ByronKeyLegacy + = ByronVerificationKeyLegacy Crypto.VerificationKey + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKeyLegacy) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) - newtype VerificationKey ByronKeyLegacy = - ByronVerificationKeyLegacy Crypto.VerificationKey - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKeyLegacy = - ByronSigningKeyLegacy Crypto.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR + newtype SigningKey ByronKeyLegacy + = ByronSigningKeyLegacy Crypto.SigningKey + deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKeyLegacy) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) - deterministicSigningKey :: AsType ByronKeyLegacy -> Crypto.Seed -> SigningKey ByronKeyLegacy - deterministicSigningKey _ _ = error "Please generate a non legacy Byron key instead" + deterministicSigningKey :: AsType ByronKeyLegacy -> Crypto.Seed -> SigningKey ByronKeyLegacy + deterministicSigningKey _ _ = error "Please generate a non legacy Byron key instead" - deterministicSigningKeySeedSize :: AsType ByronKeyLegacy -> Word - deterministicSigningKeySeedSize AsByronKeyLegacy = 32 + deterministicSigningKeySeedSize :: AsType ByronKeyLegacy -> Word + deterministicSigningKeySeedSize AsByronKeyLegacy = 32 - getVerificationKey :: SigningKey ByronKeyLegacy -> VerificationKey ByronKeyLegacy - getVerificationKey (ByronSigningKeyLegacy sk) = - ByronVerificationKeyLegacy (Crypto.toVerification sk) + getVerificationKey :: SigningKey ByronKeyLegacy -> VerificationKey ByronKeyLegacy + getVerificationKey (ByronSigningKeyLegacy sk) = + ByronVerificationKeyLegacy (Crypto.toVerification sk) - verificationKeyHash :: VerificationKey ByronKeyLegacy -> Hash ByronKeyLegacy - verificationKeyHash (ByronVerificationKeyLegacy vkey) = - ByronKeyHashLegacy (Crypto.hashKey vkey) + verificationKeyHash :: VerificationKey ByronKeyLegacy -> Hash ByronKeyLegacy + verificationKeyHash (ByronVerificationKeyLegacy vkey) = + ByronKeyHashLegacy (Crypto.hashKey vkey) instance HasTypeProxy ByronKeyLegacy where data AsType ByronKeyLegacy = AsByronKeyLegacy proxyToAsType _ = AsByronKeyLegacy instance HasTextEnvelope (VerificationKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentVerificationKeyByronLegacy_ed25519_bip32" + textEnvelopeType _ = "PaymentVerificationKeyByronLegacy_ed25519_bip32" instance HasTextEnvelope (SigningKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentSigningKeyByronLegacy_ed25519_bip32" + textEnvelopeType _ = "PaymentSigningKeyByronLegacy_ed25519_bip32" newtype instance Hash ByronKeyLegacy = ByronKeyHashLegacy Crypto.KeyHash deriving (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKeyLegacy) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKeyLegacy) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash ByronKeyLegacy) where - serialiseToRawBytes (ByronKeyHashLegacy (Crypto.KeyHash vkh)) = - Crypto.abstractHashToBytes vkh + serialiseToRawBytes (ByronKeyHashLegacy (Crypto.KeyHash vkh)) = + Crypto.abstractHashToBytes vkh - deserialiseFromRawBytes (AsHash AsByronKeyLegacy) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ByronKeyLegacy") $ - ByronKeyHashLegacy . Crypto.KeyHash <$> Crypto.abstractHashFromBytes bs + deserialiseFromRawBytes (AsHash AsByronKeyLegacy) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ByronKeyLegacy") $ + ByronKeyHashLegacy . Crypto.KeyHash <$> Crypto.abstractHashFromBytes bs instance SerialiseAsRawBytes (VerificationKey ByronKeyLegacy) where - serialiseToRawBytes (ByronVerificationKeyLegacy (Crypto.VerificationKey xvk)) = - Crypto.HD.unXPub xvk + serialiseToRawBytes (ByronVerificationKeyLegacy (Crypto.VerificationKey xvk)) = + Crypto.HD.unXPub xvk - deserialiseFromRawBytes (AsVerificationKey AsByronKeyLegacy) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey ByronKeyLegacy" ++ msg)) $ - ByronVerificationKeyLegacy . Crypto.VerificationKey <$> Crypto.HD.xpub bs + deserialiseFromRawBytes (AsVerificationKey AsByronKeyLegacy) bs = + first + (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey ByronKeyLegacy" ++ msg)) + $ ByronVerificationKeyLegacy . Crypto.VerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey ByronKeyLegacy) where - serialiseToRawBytes (ByronSigningKeyLegacy (Crypto.SigningKey xsk)) = - Crypto.HD.unXPrv xsk - - deserialiseFromRawBytes (AsSigningKey AsByronKeyLegacy) bs = - first (\e -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey ByronKeyLegacy" ++ show e)) $ - ByronSigningKeyLegacy . snd <$> CBOR.deserialiseFromBytes decodeLegacyDelegateKey (LB.fromStrict bs) - where - -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs - -- | Enforces that the input size is the same as the decoded one, failing in - -- case it's not. - enforceSize :: Text -> Int -> CBOR.Decoder s () - enforceSize lbl requestedSize = CBOR.decodeListLenCanonical >>= matchSize requestedSize lbl - - -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs - -- | Compare two sizes, failing if they are not equal. - matchSize :: Int -> Text -> Int -> CBOR.Decoder s () - matchSize requestedSize lbl actualSize = - when (actualSize /= requestedSize) $ - cborError ( lbl <> " failed the size check. Expected " <> Text.pack (show requestedSize) - <> ", found " <> Text.pack (show actualSize) - ) - - decodeXPrv :: CBOR.Decoder s Wallet.XPrv - decodeXPrv = CBOR.decodeBytesCanonical >>= either (fail . formatToString build) pure . Wallet.xprv - - -- | Decoder for a Byron/Classic signing key. - -- Lifted from cardano-sl legacy codebase. - decodeLegacyDelegateKey :: CBOR.Decoder s Crypto.SigningKey - decodeLegacyDelegateKey = do - enforceSize "UserSecret" 4 - _ <- do - enforceSize "vss" 1 - CBOR.decodeBytes - pkey <- do - enforceSize "pkey" 1 - Crypto.SigningKey <$> decodeXPrv - _ <- do - CBOR.decodeListLenIndef - CBOR.decodeSequenceLenIndef (flip (:)) [] reverse CBOR.decodeNull - _ <- do - enforceSize "wallet" 0 - pure pkey + serialiseToRawBytes (ByronSigningKeyLegacy (Crypto.SigningKey xsk)) = + Crypto.HD.unXPrv xsk + + deserialiseFromRawBytes (AsSigningKey AsByronKeyLegacy) bs = + first (\e -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey ByronKeyLegacy" ++ show e)) $ + ByronSigningKeyLegacy . snd <$> CBOR.deserialiseFromBytes decodeLegacyDelegateKey (LB.fromStrict bs) + where + -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs + -- \| Enforces that the input size is the same as the decoded one, failing in + -- case it's not. + enforceSize :: Text -> Int -> CBOR.Decoder s () + enforceSize lbl requestedSize = CBOR.decodeListLenCanonical >>= matchSize requestedSize lbl + + -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs + -- \| Compare two sizes, failing if they are not equal. + matchSize :: Int -> Text -> Int -> CBOR.Decoder s () + matchSize requestedSize lbl actualSize = + when (actualSize /= requestedSize) $ + cborError + ( lbl + <> " failed the size check. Expected " + <> Text.pack (show requestedSize) + <> ", found " + <> Text.pack (show actualSize) + ) + + decodeXPrv :: CBOR.Decoder s Wallet.XPrv + decodeXPrv = CBOR.decodeBytesCanonical >>= either (fail . formatToString build) pure . Wallet.xprv + + -- \| Decoder for a Byron/Classic signing key. + -- Lifted from cardano-sl legacy codebase. + decodeLegacyDelegateKey :: CBOR.Decoder s Crypto.SigningKey + decodeLegacyDelegateKey = do + enforceSize "UserSecret" 4 + _ <- do + enforceSize "vss" 1 + CBOR.decodeBytes + pkey <- do + enforceSize "pkey" 1 + Crypto.SigningKey <$> decodeXPrv + _ <- do + CBOR.decodeListLenIndef + CBOR.decodeSequenceLenIndef (flip (:)) [] reverse CBOR.decodeNull + _ <- do + enforceSize "wallet" 0 + pure pkey instance CastVerificationKeyRole ByronKeyLegacy ByronKey where - castVerificationKey (ByronVerificationKeyLegacy vk) = - ByronVerificationKey vk + castVerificationKey (ByronVerificationKeyLegacy vk) = + ByronVerificationKey vk instance IsByronKey ByronKeyLegacy where byronKeyFormat = ByronLegacyKeyFormat diff --git a/cardano-api/internal/Cardano/Api/Keys/Class.hs b/cardano-api/internal/Cardano/Api/Keys/Class.hs index 5eb4679084..a142a6cdbd 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Class.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Class.hs @@ -4,26 +4,25 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.Api.Keys.Class - ( Key(..) + ( Key (..) , generateSigningKey , generateInsecureSigningKey - , CastVerificationKeyRole(..) - , CastSigningKeyRole(..) - , AsType(AsVerificationKey, AsSigningKey) - ) where - -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope - + , CastVerificationKeyRole (..) + , CastSigningKeyRole (..) + , AsType (AsVerificationKey, AsSigningKey) + ) +where + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Seed as Crypto - -import Control.Monad.IO.Class -import Data.Kind (Type) +import Control.Monad.IO.Class +import Data.Kind (Type) +import System.Random (StdGen) import qualified System.Random as Random -import System.Random (StdGen) -- | An interface for cryptographic keys used for signatures with a 'SigningKey' -- and a 'VerificationKey' key. @@ -31,55 +30,55 @@ import System.Random (StdGen) -- This interface does not provide actual signing or verifying functions since -- this API is concerned with the management of keys: generating and -- serialising. --- -class (Eq (VerificationKey keyrole), - Show (VerificationKey keyrole), - SerialiseAsRawBytes (Hash keyrole), - HasTextEnvelope (VerificationKey keyrole), - HasTextEnvelope (SigningKey keyrole)) - => Key keyrole where - - -- | The type of cryptographic verification key, for each key role. - data VerificationKey keyrole :: Type +class + ( Eq (VerificationKey keyrole) + , Show (VerificationKey keyrole) + , SerialiseAsRawBytes (Hash keyrole) + , HasTextEnvelope (VerificationKey keyrole) + , HasTextEnvelope (SigningKey keyrole) + ) => + Key keyrole + where + -- | The type of cryptographic verification key, for each key role. + data VerificationKey keyrole :: Type - -- | The type of cryptographic signing key, for each key role. - data SigningKey keyrole :: Type + -- | The type of cryptographic signing key, for each key role. + data SigningKey keyrole :: Type - -- | Get the corresponding verification key from a signing key. - getVerificationKey :: () + -- | Get the corresponding verification key from a signing key. + getVerificationKey + :: () #if MIN_VERSION_base(4,17,0) - -- GHC 8.10 considers this constraint redundant but ghc-9.6 complains if its not present. - -- More annoyingly, absence of this constraint does not manifest in this repo, but in - -- `cardano-cli` :facepalm:. - => HasTypeProxy keyrole + -- GHC 8.10 considers this constraint redundant but ghc-9.6 complains if its not present. + -- More annoyingly, absence of this constraint does not manifest in this repo, but in + -- `cardano-cli` :facepalm:. + => HasTypeProxy keyrole #endif - => SigningKey keyrole - -> VerificationKey keyrole + => SigningKey keyrole + -> VerificationKey keyrole - -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The - -- required size of the seed is given by 'deterministicSigningKeySeedSize'. - -- - deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole - deterministicSigningKeySeedSize :: AsType keyrole -> Word + -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The + -- required size of the seed is given by 'deterministicSigningKeySeedSize'. + deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole - verificationKeyHash :: VerificationKey keyrole -> Hash keyrole + deterministicSigningKeySeedSize :: AsType keyrole -> Word + verificationKeyHash :: VerificationKey keyrole -> Hash keyrole -- TODO: We should move this into the Key type class, with the existing impl as the default impl. -- For KES we can then override it to keep the seed and key in mlocked memory at all times. + -- | Generate a 'SigningKey' using a seed from operating system entropy. --- generateSigningKey :: MonadIO m => Key keyrole => AsType keyrole -> m (SigningKey keyrole) generateSigningKey keytype = do - seed <- liftIO $ Crypto.readSeedFromSystemEntropy seedSize - return $! deterministicSigningKey keytype seed - where - seedSize = deterministicSigningKeySeedSize keytype - + seed <- liftIO $ Crypto.readSeedFromSystemEntropy seedSize + return $! deterministicSigningKey keytype seed + where + seedSize = deterministicSigningKeySeedSize keytype generateInsecureSigningKey :: MonadIO m @@ -95,23 +94,19 @@ generateInsecureSigningKey g keytype = do Left (SerialiseAsRawBytesError msg) -> error $ "generateInsecureSigningKey: Unable to generate insecure key: " <> msg instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where - data AsType (VerificationKey a) = AsVerificationKey (AsType a) - proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) + data AsType (VerificationKey a) = AsVerificationKey (AsType a) + proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) instance HasTypeProxy a => HasTypeProxy (SigningKey a) where - data AsType (SigningKey a) = AsSigningKey (AsType a) - proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a)) - + data AsType (SigningKey a) = AsSigningKey (AsType a) + proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a)) -- | Some key roles share the same representation and it is sometimes -- legitimate to change the role of a key. class CastVerificationKeyRole keyroleA keyroleB where - - -- | Change the role of a 'VerificationKey', if the representation permits. - castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB + -- | Change the role of a 'VerificationKey', if the representation permits. + castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB class CastSigningKeyRole keyroleA keyroleB where - - -- | Change the role of a 'SigningKey', if the representation permits. - castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB - + -- | Change the role of a 'SigningKey', if the representation permits. + castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB diff --git a/cardano-api/internal/Cardano/Api/Keys/Praos.hs b/cardano-api/internal/Cardano/Api/Keys/Praos.hs index bcb83275ef..27f6f60cc6 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Praos.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Praos.hs @@ -9,43 +9,40 @@ {-# LANGUAGE TypeFamilies #-} -- | Praos consensus key types and their 'Key' class instances --- -module Cardano.Api.Keys.Praos ( - - -- * Key types - KesKey, - VrfKey, +module Cardano.Api.Keys.Praos + ( -- * Key types + KesKey + , VrfKey -- * Data family instances - AsType(..), - Hash(..), - VerificationKey(..), - SigningKey(..), + , AsType (..) + , Hash (..) + , VerificationKey (..) + , SigningKey (..) -- * Signing - signArbitraryBytesKes, - ) where - -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Class -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing - + , signArbitraryBytesKes + ) +where + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Class +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.KES.Class as Crypto import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Crypto as Shelley (KES, VRF) import qualified Cardano.Ledger.Keys as Shelley - -import Data.ByteString (ByteString) -import Data.Either.Combinators (maybeToRight) -import Data.String (IsString (..)) +import Data.ByteString (ByteString) +import Data.Either.Combinators (maybeToRight) +import Data.String (IsString (..)) -- -- KES keys @@ -54,104 +51,108 @@ import Data.String (IsString (..)) data KesKey instance HasTypeProxy KesKey where - data AsType KesKey = AsKesKey - proxyToAsType _ = AsKesKey + data AsType KesKey = AsKesKey + proxyToAsType _ = AsKesKey instance Key KesKey where - - newtype VerificationKey KesKey = - KesVerificationKey (Shelley.VerKeyKES StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey KesKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey KesKey = - KesSigningKey (Shelley.SignKeyKES StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey KesKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - --This loses the mlock safety of the seed, since it starts from a normal in-memory seed. - deterministicSigningKey :: AsType KesKey -> Crypto.Seed -> SigningKey KesKey - deterministicSigningKey AsKesKey = - KesSigningKey . Crypto.genKeyKES - - deterministicSigningKeySeedSize :: AsType KesKey -> Word - deterministicSigningKeySeedSize AsKesKey = - Crypto.seedSizeKES proxy - where - proxy :: Proxy (Shelley.KES StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey - getVerificationKey (KesSigningKey sk) = - KesVerificationKey (Crypto.deriveVerKeyKES sk) - - verificationKeyHash :: VerificationKey KesKey -> Hash KesKey - verificationKeyHash (KesVerificationKey vkey) = - KesKeyHash (Crypto.hashVerKeyKES vkey) - + newtype VerificationKey KesKey + = KesVerificationKey (Shelley.VerKeyKES StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey KesKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey KesKey + = KesSigningKey (Shelley.SignKeyKES StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey KesKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + -- This loses the mlock safety of the seed, since it starts from a normal in-memory seed. + deterministicSigningKey :: AsType KesKey -> Crypto.Seed -> SigningKey KesKey + deterministicSigningKey AsKesKey = + KesSigningKey . Crypto.genKeyKES + + deterministicSigningKeySeedSize :: AsType KesKey -> Word + deterministicSigningKeySeedSize AsKesKey = + Crypto.seedSizeKES proxy + where + proxy :: Proxy (Shelley.KES StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey + getVerificationKey (KesSigningKey sk) = + KesVerificationKey (Crypto.deriveVerKeyKES sk) + + verificationKeyHash :: VerificationKey KesKey -> Hash KesKey + verificationKeyHash (KesVerificationKey vkey) = + KesKeyHash (Crypto.hashVerKeyKES vkey) instance SerialiseAsRawBytes (VerificationKey KesKey) where - serialiseToRawBytes (KesVerificationKey vk) = - Crypto.rawSerialiseVerKeyKES vk + serialiseToRawBytes (KesVerificationKey vk) = + Crypto.rawSerialiseVerKeyKES vk - deserialiseFromRawBytes (AsVerificationKey AsKesKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey KesKey") $ - KesVerificationKey <$> Crypto.rawDeserialiseVerKeyKES bs + deserialiseFromRawBytes (AsVerificationKey AsKesKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey KesKey") $ + KesVerificationKey <$> Crypto.rawDeserialiseVerKeyKES bs instance SerialiseAsRawBytes (SigningKey KesKey) where - serialiseToRawBytes (KesSigningKey sk) = - Crypto.rawSerialiseSignKeyKES sk + serialiseToRawBytes (KesSigningKey sk) = + Crypto.rawSerialiseSignKeyKES sk - deserialiseFromRawBytes (AsSigningKey AsKesKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey KesKey") $ - KesSigningKey <$> Crypto.rawDeserialiseSignKeyKES bs + deserialiseFromRawBytes (AsSigningKey AsKesKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey KesKey") $ + KesSigningKey <$> Crypto.rawDeserialiseSignKeyKES bs instance SerialiseAsBech32 (VerificationKey KesKey) where - bech32PrefixFor _ = "kes_vk" - bech32PrefixesPermitted _ = ["kes_vk"] + bech32PrefixFor _ = "kes_vk" + bech32PrefixesPermitted _ = ["kes_vk"] instance SerialiseAsBech32 (SigningKey KesKey) where - bech32PrefixFor _ = "kes_sk" - bech32PrefixesPermitted _ = ["kes_sk"] - - -newtype instance Hash KesKey = - KesKeyHash (Shelley.Hash StandardCrypto - (Shelley.VerKeyKES StandardCrypto)) + bech32PrefixFor _ = "kes_sk" + bech32PrefixesPermitted _ = ["kes_sk"] + +newtype instance Hash KesKey + = KesKeyHash + ( Shelley.Hash + StandardCrypto + (Shelley.VerKeyKES StandardCrypto) + ) deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash KesKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash KesKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash KesKey) where - serialiseToRawBytes (KesKeyHash vkh) = - Crypto.hashToBytes vkh + serialiseToRawBytes (KesKeyHash vkh) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsKesKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash KesKey") $ - KesKeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsKesKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash KesKey") $ + KesKeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey KesKey) where - textEnvelopeType _ = "KesVerificationKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (Shelley.KES StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "KesVerificationKey_" + <> fromString (Crypto.algorithmNameKES proxy) + where + proxy :: Proxy (Shelley.KES StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey KesKey) where - textEnvelopeType _ = "KesSigningKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (Shelley.KES StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "KesSigningKey_" + <> fromString (Crypto.algorithmNameKES proxy) + where + proxy :: Proxy (Shelley.KES StandardCrypto) + proxy = Proxy signArbitraryBytesKes :: SigningKey KesKey - -> Crypto.Period -- ^ Desired Kes period - -> ByteString -- ^ Message to sign + -> Crypto.Period + -- ^ Desired Kes period + -> ByteString + -- ^ Message to sign -> Crypto.SignedKES (Shelley.KES StandardCrypto) ByteString signArbitraryBytesKes (KesSigningKey kesKey) period message = Crypto.signedKES @(Shelley.KES StandardCrypto) () period message kesKey @@ -163,92 +164,93 @@ signArbitraryBytesKes (KesSigningKey kesKey) period message = data VrfKey instance HasTypeProxy VrfKey where - data AsType VrfKey = AsVrfKey - proxyToAsType _ = AsVrfKey + data AsType VrfKey = AsVrfKey + proxyToAsType _ = AsVrfKey instance Key VrfKey where - - newtype VerificationKey VrfKey = - VrfVerificationKey (Shelley.VerKeyVRF StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey VrfKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey VrfKey = - VrfSigningKey (Shelley.SignKeyVRF StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey VrfKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType VrfKey -> Crypto.Seed -> SigningKey VrfKey - deterministicSigningKey AsVrfKey seed = - VrfSigningKey (Crypto.genKeyVRF seed) - - deterministicSigningKeySeedSize :: AsType VrfKey -> Word - deterministicSigningKeySeedSize AsVrfKey = - Crypto.seedSizeVRF proxy - where - proxy :: Proxy (Shelley.VRF StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey - getVerificationKey (VrfSigningKey sk) = - VrfVerificationKey (Crypto.deriveVerKeyVRF sk) - - verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey - verificationKeyHash (VrfVerificationKey vkey) = - VrfKeyHash (Shelley.hashVerKeyVRF vkey) + newtype VerificationKey VrfKey + = VrfVerificationKey (Shelley.VerKeyVRF StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey VrfKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey VrfKey + = VrfSigningKey (Shelley.SignKeyVRF StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey VrfKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType VrfKey -> Crypto.Seed -> SigningKey VrfKey + deterministicSigningKey AsVrfKey seed = + VrfSigningKey (Crypto.genKeyVRF seed) + + deterministicSigningKeySeedSize :: AsType VrfKey -> Word + deterministicSigningKeySeedSize AsVrfKey = + Crypto.seedSizeVRF proxy + where + proxy :: Proxy (Shelley.VRF StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey + getVerificationKey (VrfSigningKey sk) = + VrfVerificationKey (Crypto.deriveVerKeyVRF sk) + + verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey + verificationKeyHash (VrfVerificationKey vkey) = + VrfKeyHash (Shelley.hashVerKeyVRF vkey) instance SerialiseAsRawBytes (VerificationKey VrfKey) where - serialiseToRawBytes (VrfVerificationKey vk) = - Crypto.rawSerialiseVerKeyVRF vk + serialiseToRawBytes (VrfVerificationKey vk) = + Crypto.rawSerialiseVerKeyVRF vk - deserialiseFromRawBytes (AsVerificationKey AsVrfKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey VrfKey") $ - VrfVerificationKey <$> Crypto.rawDeserialiseVerKeyVRF bs + deserialiseFromRawBytes (AsVerificationKey AsVrfKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey VrfKey") $ + VrfVerificationKey <$> Crypto.rawDeserialiseVerKeyVRF bs instance SerialiseAsRawBytes (SigningKey VrfKey) where - serialiseToRawBytes (VrfSigningKey sk) = - Crypto.rawSerialiseSignKeyVRF sk + serialiseToRawBytes (VrfSigningKey sk) = + Crypto.rawSerialiseSignKeyVRF sk - deserialiseFromRawBytes (AsSigningKey AsVrfKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey VrfKey") $ - VrfSigningKey <$> Crypto.rawDeserialiseSignKeyVRF bs + deserialiseFromRawBytes (AsSigningKey AsVrfKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey VrfKey") $ + VrfSigningKey <$> Crypto.rawDeserialiseSignKeyVRF bs instance SerialiseAsBech32 (VerificationKey VrfKey) where - bech32PrefixFor _ = "vrf_vk" - bech32PrefixesPermitted _ = ["vrf_vk"] + bech32PrefixFor _ = "vrf_vk" + bech32PrefixesPermitted _ = ["vrf_vk"] instance SerialiseAsBech32 (SigningKey VrfKey) where - bech32PrefixFor _ = "vrf_sk" - bech32PrefixesPermitted _ = ["vrf_sk"] - -newtype instance Hash VrfKey = - VrfKeyHash (Shelley.Hash StandardCrypto - (Shelley.VerKeyVRF StandardCrypto)) + bech32PrefixFor _ = "vrf_sk" + bech32PrefixesPermitted _ = ["vrf_sk"] + +newtype instance Hash VrfKey + = VrfKeyHash + ( Shelley.Hash + StandardCrypto + (Shelley.VerKeyVRF StandardCrypto) + ) deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash VrfKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash VrfKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash VrfKey) where - serialiseToRawBytes (VrfKeyHash vkh) = - Crypto.hashToBytes vkh + serialiseToRawBytes (VrfKeyHash vkh) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsVrfKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash VrfKey") $ - VrfKeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsVrfKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash VrfKey") $ + VrfKeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey VrfKey) where - textEnvelopeType _ = "VrfVerificationKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (Shelley.VRF StandardCrypto) - proxy = Proxy + textEnvelopeType _ = "VrfVerificationKey_" <> fromString (Crypto.algorithmNameVRF proxy) + where + proxy :: Proxy (Shelley.VRF StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey VrfKey) where - textEnvelopeType _ = "VrfSigningKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (Shelley.VRF StandardCrypto) - proxy = Proxy - + textEnvelopeType _ = "VrfSigningKey_" <> fromString (Crypto.algorithmNameVRF proxy) + where + proxy :: Proxy (Shelley.VRF StandardCrypto) + proxy = Proxy diff --git a/cardano-api/internal/Cardano/Api/Keys/Read.hs b/cardano-api/internal/Cardano/Api/Keys/Read.hs index 8b3728b7e9..7f2348b327 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Read.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Read.hs @@ -8,19 +8,19 @@ module Cardano.Api.Keys.Read ( readKeyFile , readKeyFileTextEnvelope , readKeyFileAnyOf - ) where + ) +where -import Cardano.Api.DeserialiseAnyOf -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.IO -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.Utils - -import Control.Monad.Except (runExceptT) -import Data.Bifunctor -import Data.List.NonEmpty (NonEmpty) +import Cardano.Api.DeserialiseAnyOf +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.IO +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.Utils +import Control.Monad.Except (runExceptT) +import Data.Bifunctor +import Data.List.NonEmpty (NonEmpty) -- | Read a cryptographic key from a file. -- @@ -47,7 +47,7 @@ readKeyFileTextEnvelope -> File content In -> IO (Either (FileError InputDecodeError) a) readKeyFileTextEnvelope asType fp = - first (fmap InputTextEnvelopeError) <$> readFileTextEnvelope asType fp + first (fmap InputTextEnvelopeError) <$> readFileTextEnvelope asType fp -- | Read a cryptographic key from a file given that it is one of the provided -- types. @@ -55,8 +55,8 @@ readKeyFileTextEnvelope asType fp = -- The contents of the file can either be Bech32-encoded or in the text -- envelope format. readKeyFileAnyOf - :: forall content b. - [FromSomeType SerialiseAsBech32 b] + :: forall content b + . [FromSomeType SerialiseAsBech32 b] -> [FromSomeType HasTextEnvelope b] -> File content In -> IO (Either (FileError InputDecodeError) b) diff --git a/cardano-api/internal/Cardano/Api/Keys/Shelley.hs b/cardano-api/internal/Cardano/Api/Keys/Shelley.hs index c83dac5801..5c551bf25a 100644 --- a/cardano-api/internal/Cardano/Api/Keys/Shelley.hs +++ b/cardano-api/internal/Cardano/Api/Keys/Shelley.hs @@ -7,67 +7,63 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - -- The Shelley ledger uses promoted data kinds which we have to use, but we do -- not export any from this API. We also use them unticked as nature intended. {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- | Shelley key types and their 'Key' class instances --- -module Cardano.Api.Keys.Shelley ( - - -- * Key types - CommitteeColdKey, - CommitteeColdExtendedKey, - CommitteeHotKey, - CommitteeHotExtendedKey, - DRepKey, - DRepExtendedKey, - PaymentKey, - PaymentExtendedKey, - StakeKey, - StakeExtendedKey, - StakePoolKey, - GenesisKey, - GenesisExtendedKey, - GenesisDelegateKey, - GenesisDelegateExtendedKey, - GenesisUTxOKey, +module Cardano.Api.Keys.Shelley + ( -- * Key types + CommitteeColdKey + , CommitteeColdExtendedKey + , CommitteeHotKey + , CommitteeHotExtendedKey + , DRepKey + , DRepExtendedKey + , PaymentKey + , PaymentExtendedKey + , StakeKey + , StakeExtendedKey + , StakePoolKey + , GenesisKey + , GenesisExtendedKey + , GenesisDelegateKey + , GenesisDelegateExtendedKey + , GenesisUTxOKey -- * Data family instances - AsType(..), - VerificationKey(..), - SigningKey(..), - Hash(..), - ) where - -import Cardano.Api.Error -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Class -import Cardano.Api.Pretty -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing - + , AsType (..) + , VerificationKey (..) + , SigningKey (..) + , Hash (..) + ) +where + +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Class +import Cardano.Api.Pretty +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Crypto as Shelley (DSIGN) import qualified Cardano.Ledger.Keys as Shelley - -import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText, withText) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) +import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText, withText) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Either.Combinators (maybeToRight) -import Data.Maybe -import Data.String (IsString (..)) +import Data.Either.Combinators (maybeToRight) +import Data.Maybe +import Data.String (IsString (..)) -- -- Shelley payment keys @@ -77,106 +73,105 @@ import Data.String (IsString (..)) -- transactions that spend from these addresses. -- -- This is a type level tag, used with other interfaces like 'Key'. --- data PaymentKey instance HasTypeProxy PaymentKey where - data AsType PaymentKey = AsPaymentKey - proxyToAsType _ = AsPaymentKey + data AsType PaymentKey = AsPaymentKey + proxyToAsType _ = AsPaymentKey instance Key PaymentKey where - - newtype VerificationKey PaymentKey = - PaymentVerificationKey (Shelley.VKey Shelley.Payment StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey PaymentKey = - PaymentSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType PaymentKey -> Crypto.Seed -> SigningKey PaymentKey - deterministicSigningKey AsPaymentKey seed = - PaymentSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType PaymentKey -> Word - deterministicSigningKeySeedSize AsPaymentKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey PaymentKey -> VerificationKey PaymentKey - getVerificationKey (PaymentSigningKey sk) = - PaymentVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey PaymentKey -> Hash PaymentKey - verificationKeyHash (PaymentVerificationKey vkey) = - PaymentKeyHash (Shelley.hashKey vkey) + newtype VerificationKey PaymentKey + = PaymentVerificationKey (Shelley.VKey Shelley.Payment StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey PaymentKey + = PaymentSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType PaymentKey -> Crypto.Seed -> SigningKey PaymentKey + deterministicSigningKey AsPaymentKey seed = + PaymentSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType PaymentKey -> Word + deterministicSigningKeySeedSize AsPaymentKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey PaymentKey -> VerificationKey PaymentKey + getVerificationKey (PaymentSigningKey sk) = + PaymentVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey PaymentKey -> Hash PaymentKey + verificationKeyHash (PaymentVerificationKey vkey) = + PaymentKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey PaymentKey) where - serialiseToRawBytes (PaymentVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (PaymentVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsPaymentKey) bs = - maybe - (Left (SerialiseAsRawBytesError "Unable to deserialise VerificationKey PaymentKey")) - (Right . PaymentVerificationKey . Shelley.VKey) - (Crypto.rawDeserialiseVerKeyDSIGN bs) + deserialiseFromRawBytes (AsVerificationKey AsPaymentKey) bs = + maybe + (Left (SerialiseAsRawBytesError "Unable to deserialise VerificationKey PaymentKey")) + (Right . PaymentVerificationKey . Shelley.VKey) + (Crypto.rawDeserialiseVerKeyDSIGN bs) instance SerialiseAsRawBytes (SigningKey PaymentKey) where - serialiseToRawBytes (PaymentSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk + serialiseToRawBytes (PaymentSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk - deserialiseFromRawBytes (AsSigningKey AsPaymentKey) bs = - maybe - (Left (SerialiseAsRawBytesError "Unable to serialise AsSigningKey AsPaymentKey")) - (Right . PaymentSigningKey) - (Crypto.rawDeserialiseSignKeyDSIGN bs) + deserialiseFromRawBytes (AsSigningKey AsPaymentKey) bs = + maybe + (Left (SerialiseAsRawBytesError "Unable to serialise AsSigningKey AsPaymentKey")) + (Right . PaymentSigningKey) + (Crypto.rawDeserialiseSignKeyDSIGN bs) instance SerialiseAsBech32 (VerificationKey PaymentKey) where - bech32PrefixFor _ = "addr_vk" - bech32PrefixesPermitted _ = ["addr_vk"] + bech32PrefixFor _ = "addr_vk" + bech32PrefixesPermitted _ = ["addr_vk"] instance SerialiseAsBech32 (SigningKey PaymentKey) where - bech32PrefixFor _ = "addr_sk" - bech32PrefixesPermitted _ = ["addr_sk"] + bech32PrefixFor _ = "addr_sk" + bech32PrefixesPermitted _ = ["addr_sk"] -newtype instance Hash PaymentKey = - PaymentKeyHash { unPaymentKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto } +newtype instance Hash PaymentKey + = PaymentKeyHash {unPaymentKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentKey) deriving (ToJSONKey, ToJSON, FromJSON) via UsingRawBytesHex (Hash PaymentKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash PaymentKey) where - serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsPaymentKey) bs = - maybeToRight - (SerialiseAsRawBytesError "Unable to deserialise Hash PaymentKey") - (PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) + deserialiseFromRawBytes (AsHash AsPaymentKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash PaymentKey") + (PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) instance HasTextEnvelope (VerificationKey PaymentKey) where - textEnvelopeType _ = "PaymentVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "PaymentVerificationKeyShelley_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey PaymentKey) where - textEnvelopeType _ = "PaymentSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - + textEnvelopeType _ = + "PaymentSigningKeyShelley_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy -- -- Shelley payment extended ed25519 keys @@ -197,135 +192,137 @@ instance HasTextEnvelope (SigningKey PaymentKey) where -- key ('VerificationKey' 'PaymentKey'). -- -- This is a type level tag, used with other interfaces like 'Key'. --- data PaymentExtendedKey instance HasTypeProxy PaymentExtendedKey where - data AsType PaymentExtendedKey = AsPaymentExtendedKey - proxyToAsType _ = AsPaymentExtendedKey + data AsType PaymentExtendedKey = AsPaymentExtendedKey + proxyToAsType _ = AsPaymentExtendedKey instance Key PaymentExtendedKey where - - newtype VerificationKey PaymentExtendedKey = - PaymentExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey PaymentExtendedKey = - PaymentExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: AsType PaymentExtendedKey - -> Crypto.Seed - -> SigningKey PaymentExtendedKey - deterministicSigningKey AsPaymentExtendedKey seed = - PaymentExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType PaymentExtendedKey -> Word - deterministicSigningKeySeedSize AsPaymentExtendedKey = 32 - - getVerificationKey :: SigningKey PaymentExtendedKey - -> VerificationKey PaymentExtendedKey - getVerificationKey (PaymentExtendedSigningKey sk) = - PaymentExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey PaymentExtendedKey - -> Hash PaymentExtendedKey - verificationKeyHash (PaymentExtendedVerificationKey vk) = - PaymentExtendedKeyHash + newtype VerificationKey PaymentExtendedKey + = PaymentExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) + + newtype SigningKey PaymentExtendedKey + = PaymentExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) + + deterministicSigningKey + :: AsType PaymentExtendedKey + -> Crypto.Seed + -> SigningKey PaymentExtendedKey + deterministicSigningKey AsPaymentExtendedKey seed = + PaymentExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType PaymentExtendedKey -> Word + deterministicSigningKeySeedSize AsPaymentExtendedKey = 32 + + getVerificationKey + :: SigningKey PaymentExtendedKey + -> VerificationKey PaymentExtendedKey + getVerificationKey (PaymentExtendedSigningKey sk) = + PaymentExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey PaymentExtendedKey + -> Hash PaymentExtendedKey + verificationKeyHash (PaymentExtendedVerificationKey vk) = + PaymentExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - instance ToCBOR (VerificationKey PaymentExtendedKey) where - toCBOR (PaymentExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (PaymentExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . PaymentExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . PaymentExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey PaymentExtendedKey) where - toCBOR (PaymentExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (PaymentExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . PaymentExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . PaymentExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (PaymentExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsPaymentExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey PaymentExtendedKey")) - (PaymentExtendedVerificationKey <$> Crypto.HD.xpub bs) + deserialiseFromRawBytes (AsVerificationKey AsPaymentExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey PaymentExtendedKey")) + (PaymentExtendedVerificationKey <$> Crypto.HD.xpub bs) instance SerialiseAsRawBytes (SigningKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (PaymentExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsPaymentExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey PaymentExtendedKey")) - (PaymentExtendedSigningKey <$> Crypto.HD.xprv bs) + deserialiseFromRawBytes (AsSigningKey AsPaymentExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey PaymentExtendedKey")) + (PaymentExtendedSigningKey <$> Crypto.HD.xprv bs) instance SerialiseAsBech32 (VerificationKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xvk" - bech32PrefixesPermitted _ = ["addr_xvk"] + bech32PrefixFor _ = "addr_xvk" + bech32PrefixesPermitted _ = ["addr_xvk"] instance SerialiseAsBech32 (SigningKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xsk" - bech32PrefixesPermitted _ = ["addr_xsk"] - + bech32PrefixFor _ = "addr_xsk" + bech32PrefixesPermitted _ = ["addr_xsk"] -newtype instance Hash PaymentExtendedKey = - PaymentExtendedKeyHash { unPaymentExtendedKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto } +newtype instance Hash PaymentExtendedKey + = PaymentExtendedKeyHash + {unPaymentExtendedKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentExtendedKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentExtendedKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (PaymentExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsPaymentExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash PaymentExtendedKey") $ - PaymentExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsPaymentExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash PaymentExtendedKey") $ + PaymentExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedVerificationKeyShelley_ed25519_bip32" + textEnvelopeType _ = "PaymentExtendedVerificationKeyShelley_ed25519_bip32" instance HasTextEnvelope (SigningKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedSigningKeyShelley_ed25519_bip32" + textEnvelopeType _ = "PaymentExtendedSigningKeyShelley_ed25519_bip32" instance CastVerificationKeyRole PaymentExtendedKey PaymentKey where - castVerificationKey (PaymentExtendedVerificationKey vk) = - PaymentVerificationKey + castVerificationKey (PaymentExtendedVerificationKey vk) = + PaymentVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - + where + impossible = + error "castVerificationKey: byron and shelley key sizes do not match!" -- -- Stake keys @@ -334,100 +331,98 @@ instance CastVerificationKeyRole PaymentExtendedKey PaymentKey where data StakeKey instance HasTypeProxy StakeKey where - data AsType StakeKey = AsStakeKey - proxyToAsType _ = AsStakeKey + data AsType StakeKey = AsStakeKey + proxyToAsType _ = AsStakeKey instance Key StakeKey where - - newtype VerificationKey StakeKey = StakeVerificationKey - { unStakeVerificationKey :: Shelley.VKey Shelley.Staking StandardCrypto - } - deriving stock (Eq) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeKey) - - newtype SigningKey StakeKey = - StakeSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeKey) - - deterministicSigningKey :: AsType StakeKey -> Crypto.Seed -> SigningKey StakeKey - deterministicSigningKey AsStakeKey seed = - StakeSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakeKey -> Word - deterministicSigningKeySeedSize AsStakeKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey StakeKey -> VerificationKey StakeKey - getVerificationKey (StakeSigningKey sk) = - StakeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakeKey -> Hash StakeKey - verificationKeyHash (StakeVerificationKey vkey) = - StakeKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey StakeKey = StakeVerificationKey + { unStakeVerificationKey :: Shelley.VKey Shelley.Staking StandardCrypto + } + deriving stock (Eq) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeKey) + + newtype SigningKey StakeKey + = StakeSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeKey) + + deterministicSigningKey :: AsType StakeKey -> Crypto.Seed -> SigningKey StakeKey + deterministicSigningKey AsStakeKey seed = + StakeSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType StakeKey -> Word + deterministicSigningKeySeedSize AsStakeKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey StakeKey -> VerificationKey StakeKey + getVerificationKey (StakeSigningKey sk) = + StakeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey StakeKey -> Hash StakeKey + verificationKeyHash (StakeVerificationKey vkey) = + StakeKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey StakeKey) where - serialiseToRawBytes (StakeVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (StakeVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsStakeKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey StakeKey") $ - StakeVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsStakeKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey StakeKey") $ + StakeVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey StakeKey) where - serialiseToRawBytes (StakeSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk + serialiseToRawBytes (StakeSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk - deserialiseFromRawBytes (AsSigningKey AsStakeKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey StakeKey") $ - StakeSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + deserialiseFromRawBytes (AsSigningKey AsStakeKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey StakeKey") $ + StakeSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs instance SerialiseAsBech32 (VerificationKey StakeKey) where - bech32PrefixFor _ = "stake_vk" - bech32PrefixesPermitted _ = ["stake_vk"] + bech32PrefixFor _ = "stake_vk" + bech32PrefixesPermitted _ = ["stake_vk"] instance SerialiseAsBech32 (SigningKey StakeKey) where - bech32PrefixFor _ = "stake_sk" - bech32PrefixesPermitted _ = ["stake_sk"] - + bech32PrefixFor _ = "stake_sk" + bech32PrefixesPermitted _ = ["stake_sk"] -newtype instance Hash StakeKey = - StakeKeyHash { unStakeKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto } +newtype instance Hash StakeKey + = StakeKeyHash {unStakeKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash StakeKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash StakeKey) where - serialiseToRawBytes (StakeKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (StakeKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsStakeKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakeKey") $ - StakeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsStakeKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakeKey") $ + StakeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey StakeKey) where - textEnvelopeType _ = "StakeVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "StakeVerificationKeyShelley_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey StakeKey) where - textEnvelopeType _ = "StakeSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - + textEnvelopeType _ = + "StakeSigningKeyShelley_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy -- -- Shelley stake extended ed25519 keys @@ -448,133 +443,136 @@ instance HasTextEnvelope (SigningKey StakeKey) where -- key ('VerificationKey' 'StakeKey'). -- -- This is a type level tag, used with other interfaces like 'Key'. --- data StakeExtendedKey instance HasTypeProxy StakeExtendedKey where - data AsType StakeExtendedKey = AsStakeExtendedKey - proxyToAsType _ = AsStakeExtendedKey + data AsType StakeExtendedKey = AsStakeExtendedKey + proxyToAsType _ = AsStakeExtendedKey instance Key StakeExtendedKey where - - newtype VerificationKey StakeExtendedKey = - StakeExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeExtendedKey) - - newtype SigningKey StakeExtendedKey = - StakeExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeExtendedKey) - - deterministicSigningKey :: AsType StakeExtendedKey - -> Crypto.Seed - -> SigningKey StakeExtendedKey - deterministicSigningKey AsStakeExtendedKey seed = - StakeExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType StakeExtendedKey -> Word - deterministicSigningKeySeedSize AsStakeExtendedKey = 32 - - getVerificationKey :: SigningKey StakeExtendedKey - -> VerificationKey StakeExtendedKey - getVerificationKey (StakeExtendedSigningKey sk) = - StakeExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey StakeExtendedKey - -> Hash StakeExtendedKey - verificationKeyHash (StakeExtendedVerificationKey vk) = - StakeExtendedKeyHash + newtype VerificationKey StakeExtendedKey + = StakeExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeExtendedKey) + + newtype SigningKey StakeExtendedKey + = StakeExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeExtendedKey) + + deterministicSigningKey + :: AsType StakeExtendedKey + -> Crypto.Seed + -> SigningKey StakeExtendedKey + deterministicSigningKey AsStakeExtendedKey seed = + StakeExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType StakeExtendedKey -> Word + deterministicSigningKeySeedSize AsStakeExtendedKey = 32 + + getVerificationKey + :: SigningKey StakeExtendedKey + -> VerificationKey StakeExtendedKey + getVerificationKey (StakeExtendedSigningKey sk) = + StakeExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey StakeExtendedKey + -> Hash StakeExtendedKey + verificationKeyHash (StakeExtendedVerificationKey vk) = + StakeExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - instance ToCBOR (VerificationKey StakeExtendedKey) where - toCBOR (StakeExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (StakeExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . StakeExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . StakeExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey StakeExtendedKey) where - toCBOR (StakeExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (StakeExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . StakeExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . StakeExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (StakeExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsStakeExtendedKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey StakeExtendedKey: " ++ msg)) $ - StakeExtendedVerificationKey <$> Crypto.HD.xpub bs + deserialiseFromRawBytes (AsVerificationKey AsStakeExtendedKey) bs = + first + (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey StakeExtendedKey: " ++ msg)) + $ StakeExtendedVerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (StakeExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsStakeExtendedKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey StakeExtendedKey: " ++ msg)) $ - StakeExtendedSigningKey <$> Crypto.HD.xprv bs + deserialiseFromRawBytes (AsSigningKey AsStakeExtendedKey) bs = + first + (\msg -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey StakeExtendedKey: " ++ msg)) + $ StakeExtendedSigningKey <$> Crypto.HD.xprv bs instance SerialiseAsBech32 (VerificationKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xvk" - bech32PrefixesPermitted _ = ["stake_xvk"] + bech32PrefixFor _ = "stake_xvk" + bech32PrefixesPermitted _ = ["stake_xvk"] instance SerialiseAsBech32 (SigningKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xsk" - bech32PrefixesPermitted _ = ["stake_xsk"] - + bech32PrefixFor _ = "stake_xsk" + bech32PrefixesPermitted _ = ["stake_xsk"] -newtype instance Hash StakeExtendedKey = - StakeExtendedKeyHash { unStakeExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto } +newtype instance Hash StakeExtendedKey + = StakeExtendedKeyHash {unStakeExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash StakeExtendedKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeExtendedKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (StakeExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsStakeExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakeExtendedKey") $ - StakeExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsStakeExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakeExtendedKey") $ + StakeExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedVerificationKeyShelley_ed25519_bip32" + textEnvelopeType _ = "StakeExtendedVerificationKeyShelley_ed25519_bip32" instance HasTextEnvelope (SigningKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedSigningKeyShelley_ed25519_bip32" + textEnvelopeType _ = "StakeExtendedSigningKeyShelley_ed25519_bip32" instance CastVerificationKeyRole StakeExtendedKey StakeKey where - castVerificationKey (StakeExtendedVerificationKey vk) = - StakeVerificationKey + castVerificationKey (StakeExtendedVerificationKey vk) = + StakeVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - + where + impossible = + error "castVerificationKey: byron and shelley key sizes do not match!" -- -- Genesis keys @@ -583,96 +581,94 @@ instance CastVerificationKeyRole StakeExtendedKey StakeKey where data GenesisKey instance HasTypeProxy GenesisKey where - data AsType GenesisKey = AsGenesisKey - proxyToAsType _ = AsGenesisKey + data AsType GenesisKey = AsGenesisKey + proxyToAsType _ = AsGenesisKey instance Key GenesisKey where - - newtype VerificationKey GenesisKey = - GenesisVerificationKey (Shelley.VKey Shelley.Genesis StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisKey = - GenesisSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisKey -> Crypto.Seed -> SigningKey GenesisKey - deterministicSigningKey AsGenesisKey seed = - GenesisSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisKey -> Word - deterministicSigningKeySeedSize AsGenesisKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey GenesisKey -> VerificationKey GenesisKey - getVerificationKey (GenesisSigningKey sk) = - GenesisVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisKey -> Hash GenesisKey - verificationKeyHash (GenesisVerificationKey vkey) = - GenesisKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey GenesisKey + = GenesisVerificationKey (Shelley.VKey Shelley.Genesis StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey GenesisKey + = GenesisSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType GenesisKey -> Crypto.Seed -> SigningKey GenesisKey + deterministicSigningKey AsGenesisKey seed = + GenesisSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType GenesisKey -> Word + deterministicSigningKeySeedSize AsGenesisKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey GenesisKey -> VerificationKey GenesisKey + getVerificationKey (GenesisSigningKey sk) = + GenesisVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey GenesisKey -> Hash GenesisKey + verificationKeyHash (GenesisVerificationKey vkey) = + GenesisKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey GenesisKey) where - serialiseToRawBytes (GenesisVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (GenesisVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsGenesisKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisKey") $ - GenesisVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsGenesisKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisKey") $ + GenesisVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey GenesisKey) where - serialiseToRawBytes (GenesisSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisKey") $ - GenesisSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + serialiseToRawBytes (GenesisSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + deserialiseFromRawBytes (AsSigningKey AsGenesisKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisKey") $ + GenesisSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs -newtype instance Hash GenesisKey = - GenesisKeyHash { unGenesisKeyHash :: Shelley.KeyHash Shelley.Genesis StandardCrypto } +newtype instance Hash GenesisKey + = GenesisKeyHash {unGenesisKeyHash :: Shelley.KeyHash Shelley.Genesis StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisKey) deriving (ToJSONKey, ToJSON, FromJSON) via UsingRawBytesHex (Hash GenesisKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash GenesisKey) where - serialiseToRawBytes (GenesisKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (GenesisKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsGenesisKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisKey") $ - GenesisKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGenesisKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisKey") $ + GenesisKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey GenesisKey) where - textEnvelopeType _ = "GenesisVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "GenesisVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey GenesisKey) where - textEnvelopeType _ = "GenesisSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "GenesisSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance CastVerificationKeyRole GenesisKey PaymentKey where - castVerificationKey (GenesisVerificationKey (Shelley.VKey vk)) = - PaymentVerificationKey (Shelley.VKey vk) - + castVerificationKey (GenesisVerificationKey (Shelley.VKey vk)) = + PaymentVerificationKey (Shelley.VKey vk) -- -- Constitutional Committee Hot Keys @@ -681,106 +677,109 @@ instance CastVerificationKeyRole GenesisKey PaymentKey where data CommitteeHotKey instance HasTypeProxy CommitteeHotKey where - data AsType CommitteeHotKey = AsCommitteeHotKey - proxyToAsType _ = AsCommitteeHotKey + data AsType CommitteeHotKey = AsCommitteeHotKey + proxyToAsType _ = AsCommitteeHotKey instance Key CommitteeHotKey where - - newtype VerificationKey CommitteeHotKey = - CommitteeHotVerificationKey (Shelley.VKey Shelley.HotCommitteeRole StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey CommitteeHotKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey CommitteeHotKey = - CommitteeHotSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey CommitteeHotKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType CommitteeHotKey -> Crypto.Seed -> SigningKey CommitteeHotKey - deterministicSigningKey AsCommitteeHotKey seed = - CommitteeHotSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType CommitteeHotKey -> Word - deterministicSigningKeySeedSize AsCommitteeHotKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey CommitteeHotKey -> VerificationKey CommitteeHotKey - getVerificationKey (CommitteeHotSigningKey sk) = - CommitteeHotVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey CommitteeHotKey -> Hash CommitteeHotKey - verificationKeyHash (CommitteeHotVerificationKey vkey) = - CommitteeHotKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey CommitteeHotKey + = CommitteeHotVerificationKey (Shelley.VKey Shelley.HotCommitteeRole StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey CommitteeHotKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey CommitteeHotKey + = CommitteeHotSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey CommitteeHotKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType CommitteeHotKey -> Crypto.Seed -> SigningKey CommitteeHotKey + deterministicSigningKey AsCommitteeHotKey seed = + CommitteeHotSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType CommitteeHotKey -> Word + deterministicSigningKeySeedSize AsCommitteeHotKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey CommitteeHotKey -> VerificationKey CommitteeHotKey + getVerificationKey (CommitteeHotSigningKey sk) = + CommitteeHotVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey CommitteeHotKey -> Hash CommitteeHotKey + verificationKeyHash (CommitteeHotVerificationKey vkey) = + CommitteeHotKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey CommitteeHotKey) where - serialiseToRawBytes (CommitteeHotVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (CommitteeHotVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsCommitteeHotKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey Constitutional Committee Hot Key") $ - CommitteeHotVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsCommitteeHotKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise VerificationKey Constitutional Committee Hot Key") + $ CommitteeHotVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey CommitteeHotKey) where - serialiseToRawBytes (CommitteeHotSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsCommitteeHotKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey Constitutional Committee Hot Key") $ - CommitteeHotSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + serialiseToRawBytes (CommitteeHotSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + deserialiseFromRawBytes (AsSigningKey AsCommitteeHotKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise SigningKey Constitutional Committee Hot Key") + $ CommitteeHotSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs -newtype instance Hash CommitteeHotKey = - CommitteeHotKeyHash { unCommitteeHotKeyHash :: Shelley.KeyHash Shelley.HotCommitteeRole StandardCrypto } +newtype instance Hash CommitteeHotKey + = CommitteeHotKeyHash + {unCommitteeHotKeyHash :: Shelley.KeyHash Shelley.HotCommitteeRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash CommitteeHotKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash CommitteeHotKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash CommitteeHotKey) where - serialiseToRawBytes (CommitteeHotKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (CommitteeHotKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsCommitteeHotKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash Constitutional Committee Hot Key") $ - CommitteeHotKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsCommitteeHotKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash Constitutional Committee Hot Key") + $ CommitteeHotKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey CommitteeHotKey) where - textEnvelopeType _ = "ConstitutionalCommitteeHotVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "ConstitutionalCommitteeHotVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey CommitteeHotKey) where - textEnvelopeType _ = "ConstitutionalCommitteeHotSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "ConstitutionalCommitteeHotSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance CastVerificationKeyRole CommitteeHotKey PaymentKey where - castVerificationKey (CommitteeHotVerificationKey (Shelley.VKey vk)) = - PaymentVerificationKey (Shelley.VKey vk) + castVerificationKey (CommitteeHotVerificationKey (Shelley.VKey vk)) = + PaymentVerificationKey (Shelley.VKey vk) instance SerialiseAsBech32 (Hash CommitteeHotKey) where - bech32PrefixFor _ = "cc_hot" - bech32PrefixesPermitted _ = ["cc_hot"] + bech32PrefixFor _ = "cc_hot" + bech32PrefixesPermitted _ = ["cc_hot"] instance SerialiseAsBech32 (VerificationKey CommitteeHotKey) where - bech32PrefixFor _ = "cc_hot_vk" - bech32PrefixesPermitted _ = ["cc_hot_vk"] + bech32PrefixFor _ = "cc_hot_vk" + bech32PrefixesPermitted _ = ["cc_hot_vk"] instance SerialiseAsBech32 (SigningKey CommitteeHotKey) where - bech32PrefixFor _ = "cc_hot_sk" - bech32PrefixesPermitted _ = ["cc_hot_sk"] + bech32PrefixFor _ = "cc_hot_sk" + bech32PrefixesPermitted _ = ["cc_hot_sk"] -- -- Constitutional Committee Cold Keys @@ -789,106 +788,109 @@ instance SerialiseAsBech32 (SigningKey CommitteeHotKey) where data CommitteeColdKey instance HasTypeProxy CommitteeColdKey where - data AsType CommitteeColdKey = AsCommitteeColdKey - proxyToAsType _ = AsCommitteeColdKey + data AsType CommitteeColdKey = AsCommitteeColdKey + proxyToAsType _ = AsCommitteeColdKey instance Key CommitteeColdKey where - - newtype VerificationKey CommitteeColdKey = - CommitteeColdVerificationKey (Shelley.VKey Shelley.ColdCommitteeRole StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey CommitteeColdKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey CommitteeColdKey = - CommitteeColdSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey CommitteeColdKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType CommitteeColdKey -> Crypto.Seed -> SigningKey CommitteeColdKey - deterministicSigningKey AsCommitteeColdKey seed = - CommitteeColdSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType CommitteeColdKey -> Word - deterministicSigningKeySeedSize AsCommitteeColdKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey CommitteeColdKey -> VerificationKey CommitteeColdKey - getVerificationKey (CommitteeColdSigningKey sk) = - CommitteeColdVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey CommitteeColdKey -> Hash CommitteeColdKey - verificationKeyHash (CommitteeColdVerificationKey vkey) = - CommitteeColdKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey CommitteeColdKey + = CommitteeColdVerificationKey (Shelley.VKey Shelley.ColdCommitteeRole StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey CommitteeColdKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey CommitteeColdKey + = CommitteeColdSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey CommitteeColdKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType CommitteeColdKey -> Crypto.Seed -> SigningKey CommitteeColdKey + deterministicSigningKey AsCommitteeColdKey seed = + CommitteeColdSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType CommitteeColdKey -> Word + deterministicSigningKeySeedSize AsCommitteeColdKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey CommitteeColdKey -> VerificationKey CommitteeColdKey + getVerificationKey (CommitteeColdSigningKey sk) = + CommitteeColdVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey CommitteeColdKey -> Hash CommitteeColdKey + verificationKeyHash (CommitteeColdVerificationKey vkey) = + CommitteeColdKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey CommitteeColdKey) where - serialiseToRawBytes (CommitteeColdVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (CommitteeColdVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsCommitteeColdKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey Constitutional Committee Cold Key") $ - CommitteeColdVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsCommitteeColdKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise VerificationKey Constitutional Committee Cold Key") + $ CommitteeColdVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey CommitteeColdKey) where - serialiseToRawBytes (CommitteeColdSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsCommitteeColdKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey Constitutional Committee Cold Key") $ - CommitteeColdSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + serialiseToRawBytes (CommitteeColdSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + deserialiseFromRawBytes (AsSigningKey AsCommitteeColdKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise SigningKey Constitutional Committee Cold Key") + $ CommitteeColdSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs -newtype instance Hash CommitteeColdKey = - CommitteeColdKeyHash { unCommitteeColdKeyHash :: Shelley.KeyHash Shelley.ColdCommitteeRole StandardCrypto } +newtype instance Hash CommitteeColdKey + = CommitteeColdKeyHash + {unCommitteeColdKeyHash :: Shelley.KeyHash Shelley.ColdCommitteeRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash CommitteeColdKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash CommitteeColdKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash CommitteeColdKey) where - serialiseToRawBytes (CommitteeColdKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (CommitteeColdKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsCommitteeColdKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash Constitutional Committee Cold Key") $ - CommitteeColdKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsCommitteeColdKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash Constitutional Committee Cold Key") + $ CommitteeColdKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey CommitteeColdKey) where - textEnvelopeType _ = "ConstitutionalCommitteeColdVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "ConstitutionalCommitteeColdVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey CommitteeColdKey) where - textEnvelopeType _ = "ConstitutionalCommitteeColdSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "ConstitutionalCommitteeColdSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance CastVerificationKeyRole CommitteeColdKey PaymentKey where - castVerificationKey (CommitteeColdVerificationKey (Shelley.VKey vk)) = - PaymentVerificationKey (Shelley.VKey vk) + castVerificationKey (CommitteeColdVerificationKey (Shelley.VKey vk)) = + PaymentVerificationKey (Shelley.VKey vk) instance SerialiseAsBech32 (Hash CommitteeColdKey) where - bech32PrefixFor _ = "cc_cold" - bech32PrefixesPermitted _ = ["cc_cold"] + bech32PrefixFor _ = "cc_cold" + bech32PrefixesPermitted _ = ["cc_cold"] instance SerialiseAsBech32 (VerificationKey CommitteeColdKey) where - bech32PrefixFor _ = "cc_cold_vk" - bech32PrefixesPermitted _ = ["cc_cold_vk"] + bech32PrefixFor _ = "cc_cold_vk" + bech32PrefixesPermitted _ = ["cc_cold_vk"] instance SerialiseAsBech32 (SigningKey CommitteeColdKey) where - bech32PrefixFor _ = "cc_cold_sk" - bech32PrefixesPermitted _ = ["cc_cold_sk"] + bech32PrefixFor _ = "cc_cold_sk" + bech32PrefixesPermitted _ = ["cc_cold_sk"] --- --- Committee cold extended keys @@ -896,128 +898,134 @@ instance SerialiseAsBech32 (SigningKey CommitteeColdKey) where data CommitteeColdExtendedKey instance HasTypeProxy CommitteeColdExtendedKey where - data AsType CommitteeColdExtendedKey = AsCommitteeColdExtendedKey - proxyToAsType _ = AsCommitteeColdExtendedKey + data AsType CommitteeColdExtendedKey = AsCommitteeColdExtendedKey + proxyToAsType _ = AsCommitteeColdExtendedKey instance Key CommitteeColdExtendedKey where - - newtype VerificationKey CommitteeColdExtendedKey = - CommitteeColdExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey CommitteeColdExtendedKey = - CommitteeColdExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: AsType CommitteeColdExtendedKey - -> Crypto.Seed - -> SigningKey CommitteeColdExtendedKey - deterministicSigningKey AsCommitteeColdExtendedKey seed = - CommitteeColdExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType CommitteeColdExtendedKey -> Word - deterministicSigningKeySeedSize AsCommitteeColdExtendedKey = 32 - - getVerificationKey :: SigningKey CommitteeColdExtendedKey - -> VerificationKey CommitteeColdExtendedKey - getVerificationKey (CommitteeColdExtendedSigningKey sk) = - CommitteeColdExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey CommitteeColdExtendedKey - -> Hash CommitteeColdExtendedKey - verificationKeyHash (CommitteeColdExtendedVerificationKey vk) = - CommitteeColdExtendedKeyHash + newtype VerificationKey CommitteeColdExtendedKey + = CommitteeColdExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) + + newtype SigningKey CommitteeColdExtendedKey + = CommitteeColdExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) + + deterministicSigningKey + :: AsType CommitteeColdExtendedKey + -> Crypto.Seed + -> SigningKey CommitteeColdExtendedKey + deterministicSigningKey AsCommitteeColdExtendedKey seed = + CommitteeColdExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType CommitteeColdExtendedKey -> Word + deterministicSigningKeySeedSize AsCommitteeColdExtendedKey = 32 + + getVerificationKey + :: SigningKey CommitteeColdExtendedKey + -> VerificationKey CommitteeColdExtendedKey + getVerificationKey (CommitteeColdExtendedSigningKey sk) = + CommitteeColdExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey CommitteeColdExtendedKey + -> Hash CommitteeColdExtendedKey + verificationKeyHash (CommitteeColdExtendedVerificationKey vk) = + CommitteeColdExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk -newtype instance Hash CommitteeColdExtendedKey = - CommitteeColdExtendedKeyHash { unCommitteeColdExtendedKeyHash :: Shelley.KeyHash Shelley.ColdCommitteeRole StandardCrypto } +newtype instance Hash CommitteeColdExtendedKey + = CommitteeColdExtendedKeyHash + {unCommitteeColdExtendedKeyHash :: Shelley.KeyHash Shelley.ColdCommitteeRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash CommitteeColdKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash CommitteeColdKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance ToCBOR (VerificationKey CommitteeColdExtendedKey) where - toCBOR (CommitteeColdExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (CommitteeColdExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey CommitteeColdExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . CommitteeColdExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . CommitteeColdExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey CommitteeColdExtendedKey) where - toCBOR (CommitteeColdExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (CommitteeColdExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey CommitteeColdExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . CommitteeColdExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . CommitteeColdExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey CommitteeColdExtendedKey) where - serialiseToRawBytes (CommitteeColdExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (CommitteeColdExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsCommitteeColdExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey CommitteeColdExtendedKey")) - (CommitteeColdExtendedVerificationKey <$> Crypto.HD.xpub bs) + deserialiseFromRawBytes (AsVerificationKey AsCommitteeColdExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey CommitteeColdExtendedKey")) + (CommitteeColdExtendedVerificationKey <$> Crypto.HD.xpub bs) instance SerialiseAsRawBytes (SigningKey CommitteeColdExtendedKey) where - serialiseToRawBytes (CommitteeColdExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (CommitteeColdExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsCommitteeColdExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey CommitteeColdExtendedKey")) - (CommitteeColdExtendedSigningKey <$> Crypto.HD.xprv bs) + deserialiseFromRawBytes (AsSigningKey AsCommitteeColdExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey CommitteeColdExtendedKey")) + (CommitteeColdExtendedSigningKey <$> Crypto.HD.xprv bs) instance SerialiseAsRawBytes (Hash CommitteeColdExtendedKey) where - serialiseToRawBytes (CommitteeColdExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (CommitteeColdExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsCommitteeColdExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash CommitteeColdExtendedKey") $ - CommitteeColdExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsCommitteeColdExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash CommitteeColdExtendedKey") $ + CommitteeColdExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey CommitteeColdExtendedKey) where - textEnvelopeType _ = "ConstitutionalCommitteeColdExtendedVerificationKey_ed25519_bip32" + textEnvelopeType _ = "ConstitutionalCommitteeColdExtendedVerificationKey_ed25519_bip32" instance HasTextEnvelope (SigningKey CommitteeColdExtendedKey) where - textEnvelopeType _ = "ConstitutionalCommitteeColdExtendedSigningKey_ed25519_bip32" + textEnvelopeType _ = "ConstitutionalCommitteeColdExtendedSigningKey_ed25519_bip32" instance SerialiseAsBech32 (VerificationKey CommitteeColdExtendedKey) where - bech32PrefixFor _ = "cc_cold_xvk" - bech32PrefixesPermitted _ = ["cc_cold_xvk"] + bech32PrefixFor _ = "cc_cold_xvk" + bech32PrefixesPermitted _ = ["cc_cold_xvk"] instance SerialiseAsBech32 (SigningKey CommitteeColdExtendedKey) where - bech32PrefixFor _ = "cc_cold_xsk" - bech32PrefixesPermitted _ = ["cc_cold_xsk"] + bech32PrefixFor _ = "cc_cold_xsk" + bech32PrefixesPermitted _ = ["cc_cold_xsk"] instance CastVerificationKeyRole CommitteeColdExtendedKey CommitteeColdKey where - castVerificationKey (CommitteeColdExtendedVerificationKey vk) = - CommitteeColdVerificationKey + castVerificationKey (CommitteeColdExtendedVerificationKey vk) = + CommitteeColdVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey (CommitteeCold): byron and shelley key sizes do not match!" + where + impossible = + error "castVerificationKey (CommitteeCold): byron and shelley key sizes do not match!" --- --- Committee hot extended keys @@ -1025,128 +1033,134 @@ instance CastVerificationKeyRole CommitteeColdExtendedKey CommitteeColdKey where data CommitteeHotExtendedKey instance HasTypeProxy CommitteeHotExtendedKey where - data AsType CommitteeHotExtendedKey = AsCommitteeHotExtendedKey - proxyToAsType _ = AsCommitteeHotExtendedKey + data AsType CommitteeHotExtendedKey = AsCommitteeHotExtendedKey + proxyToAsType _ = AsCommitteeHotExtendedKey instance Key CommitteeHotExtendedKey where - - newtype VerificationKey CommitteeHotExtendedKey = - CommitteeHotExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey CommitteeHotExtendedKey = - CommitteeHotExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: AsType CommitteeHotExtendedKey - -> Crypto.Seed - -> SigningKey CommitteeHotExtendedKey - deterministicSigningKey AsCommitteeHotExtendedKey seed = - CommitteeHotExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType CommitteeHotExtendedKey -> Word - deterministicSigningKeySeedSize AsCommitteeHotExtendedKey = 32 - - getVerificationKey :: SigningKey CommitteeHotExtendedKey - -> VerificationKey CommitteeHotExtendedKey - getVerificationKey (CommitteeHotExtendedSigningKey sk) = - CommitteeHotExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey CommitteeHotExtendedKey - -> Hash CommitteeHotExtendedKey - verificationKeyHash (CommitteeHotExtendedVerificationKey vk) = - CommitteeHotExtendedKeyHash + newtype VerificationKey CommitteeHotExtendedKey + = CommitteeHotExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) + + newtype SigningKey CommitteeHotExtendedKey + = CommitteeHotExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) + + deterministicSigningKey + :: AsType CommitteeHotExtendedKey + -> Crypto.Seed + -> SigningKey CommitteeHotExtendedKey + deterministicSigningKey AsCommitteeHotExtendedKey seed = + CommitteeHotExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType CommitteeHotExtendedKey -> Word + deterministicSigningKeySeedSize AsCommitteeHotExtendedKey = 32 + + getVerificationKey + :: SigningKey CommitteeHotExtendedKey + -> VerificationKey CommitteeHotExtendedKey + getVerificationKey (CommitteeHotExtendedSigningKey sk) = + CommitteeHotExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey CommitteeHotExtendedKey + -> Hash CommitteeHotExtendedKey + verificationKeyHash (CommitteeHotExtendedVerificationKey vk) = + CommitteeHotExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk -newtype instance Hash CommitteeHotExtendedKey = - CommitteeHotExtendedKeyHash { unCommitteeHotExtendedKeyHash :: Shelley.KeyHash Shelley.HotCommitteeRole StandardCrypto } +newtype instance Hash CommitteeHotExtendedKey + = CommitteeHotExtendedKeyHash + {unCommitteeHotExtendedKeyHash :: Shelley.KeyHash Shelley.HotCommitteeRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash CommitteeHotKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash CommitteeHotKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance ToCBOR (VerificationKey CommitteeHotExtendedKey) where - toCBOR (CommitteeHotExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (CommitteeHotExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey CommitteeHotExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . CommitteeHotExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . CommitteeHotExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey CommitteeHotExtendedKey) where - toCBOR (CommitteeHotExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (CommitteeHotExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey CommitteeHotExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . CommitteeHotExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . CommitteeHotExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey CommitteeHotExtendedKey) where - serialiseToRawBytes (CommitteeHotExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (CommitteeHotExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsCommitteeHotExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey CommitteeHotExtendedKey")) - (CommitteeHotExtendedVerificationKey <$> Crypto.HD.xpub bs) + deserialiseFromRawBytes (AsVerificationKey AsCommitteeHotExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey CommitteeHotExtendedKey")) + (CommitteeHotExtendedVerificationKey <$> Crypto.HD.xpub bs) instance SerialiseAsRawBytes (SigningKey CommitteeHotExtendedKey) where - serialiseToRawBytes (CommitteeHotExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (CommitteeHotExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsCommitteeHotExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey CommitteeHotExtendedKey")) - (CommitteeHotExtendedSigningKey <$> Crypto.HD.xprv bs) + deserialiseFromRawBytes (AsSigningKey AsCommitteeHotExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey CommitteeHotExtendedKey")) + (CommitteeHotExtendedSigningKey <$> Crypto.HD.xprv bs) instance SerialiseAsRawBytes (Hash CommitteeHotExtendedKey) where - serialiseToRawBytes (CommitteeHotExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (CommitteeHotExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsCommitteeHotExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash CommitteeHotExtendedKey") $ - CommitteeHotExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsCommitteeHotExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash CommitteeHotExtendedKey") $ + CommitteeHotExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey CommitteeHotExtendedKey) where - textEnvelopeType _ = "ConstitutionalCommitteeHotExtendedVerificationKey_ed25519_bip32" + textEnvelopeType _ = "ConstitutionalCommitteeHotExtendedVerificationKey_ed25519_bip32" instance HasTextEnvelope (SigningKey CommitteeHotExtendedKey) where - textEnvelopeType _ = "ConstitutionalCommitteeHotExtendedSigningKey_ed25519_bip32" + textEnvelopeType _ = "ConstitutionalCommitteeHotExtendedSigningKey_ed25519_bip32" instance SerialiseAsBech32 (VerificationKey CommitteeHotExtendedKey) where - bech32PrefixFor _ = "cc_hot_xvk" - bech32PrefixesPermitted _ = ["cc_hot_xvk"] + bech32PrefixFor _ = "cc_hot_xvk" + bech32PrefixesPermitted _ = ["cc_hot_xvk"] instance SerialiseAsBech32 (SigningKey CommitteeHotExtendedKey) where - bech32PrefixFor _ = "cc_hot_xsk" - bech32PrefixesPermitted _ = ["cc_hot_xsk"] + bech32PrefixFor _ = "cc_hot_xsk" + bech32PrefixesPermitted _ = ["cc_hot_xsk"] instance CastVerificationKeyRole CommitteeHotExtendedKey CommitteeHotKey where - castVerificationKey (CommitteeHotExtendedVerificationKey vk) = - CommitteeHotVerificationKey + castVerificationKey (CommitteeHotExtendedVerificationKey vk) = + CommitteeHotVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey (CommitteeHot): byron and shelley key sizes do not match!" + where + impossible = + error "castVerificationKey (CommitteeHot): byron and shelley key sizes do not match!" -- -- Shelley genesis extended ed25519 keys @@ -1164,125 +1178,128 @@ instance CastVerificationKeyRole CommitteeHotExtendedKey CommitteeHotKey where -- key ('VerificationKey' 'GenesisKey'). -- -- This is a type level tag, used with other interfaces like 'Key'. --- data GenesisExtendedKey instance HasTypeProxy GenesisExtendedKey where - data AsType GenesisExtendedKey = AsGenesisExtendedKey - proxyToAsType _ = AsGenesisExtendedKey + data AsType GenesisExtendedKey = AsGenesisExtendedKey + proxyToAsType _ = AsGenesisExtendedKey instance Key GenesisExtendedKey where - - newtype VerificationKey GenesisExtendedKey = - GenesisExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisExtendedKey) - - newtype SigningKey GenesisExtendedKey = - GenesisExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisExtendedKey) - - deterministicSigningKey :: AsType GenesisExtendedKey - -> Crypto.Seed - -> SigningKey GenesisExtendedKey - deterministicSigningKey AsGenesisExtendedKey seed = - GenesisExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisExtendedKey = 32 - - getVerificationKey :: SigningKey GenesisExtendedKey - -> VerificationKey GenesisExtendedKey - getVerificationKey (GenesisExtendedSigningKey sk) = - GenesisExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey GenesisExtendedKey - -> Hash GenesisExtendedKey - verificationKeyHash (GenesisExtendedVerificationKey vk) = - GenesisExtendedKeyHash + newtype VerificationKey GenesisExtendedKey + = GenesisExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisExtendedKey) + + newtype SigningKey GenesisExtendedKey + = GenesisExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisExtendedKey) + + deterministicSigningKey + :: AsType GenesisExtendedKey + -> Crypto.Seed + -> SigningKey GenesisExtendedKey + deterministicSigningKey AsGenesisExtendedKey seed = + GenesisExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType GenesisExtendedKey -> Word + deterministicSigningKeySeedSize AsGenesisExtendedKey = 32 + + getVerificationKey + :: SigningKey GenesisExtendedKey + -> VerificationKey GenesisExtendedKey + getVerificationKey (GenesisExtendedSigningKey sk) = + GenesisExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey GenesisExtendedKey + -> Hash GenesisExtendedKey + verificationKeyHash (GenesisExtendedVerificationKey vk) = + GenesisExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - instance ToCBOR (VerificationKey GenesisExtendedKey) where - toCBOR (GenesisExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (GenesisExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . GenesisExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . GenesisExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey GenesisExtendedKey) where - toCBOR (GenesisExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (GenesisExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . GenesisExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . GenesisExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (GenesisExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsGenesisExtendedKey) bs = - first (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisExtendedKey")) $ - GenesisExtendedVerificationKey<$> Crypto.HD.xpub bs + deserialiseFromRawBytes (AsVerificationKey AsGenesisExtendedKey) bs = + first (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisExtendedKey")) $ + GenesisExtendedVerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (GenesisExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsGenesisExtendedKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey GenesisExtendedKey" ++ msg)) $ - GenesisExtendedSigningKey <$> Crypto.HD.xprv bs + deserialiseFromRawBytes (AsSigningKey AsGenesisExtendedKey) bs = + first + (\msg -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey GenesisExtendedKey" ++ msg)) + $ GenesisExtendedSigningKey <$> Crypto.HD.xprv bs - -newtype instance Hash GenesisExtendedKey = - GenesisExtendedKeyHash { unGenesisExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto } +newtype instance Hash GenesisExtendedKey + = GenesisExtendedKeyHash + {unGenesisExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisExtendedKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisExtendedKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (GenesisExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsGenesisExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisExtendedKey") $ - GenesisExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGenesisExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisExtendedKey") $ + GenesisExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedVerificationKey_ed25519_bip32" + textEnvelopeType _ = "GenesisExtendedVerificationKey_ed25519_bip32" instance HasTextEnvelope (SigningKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedSigningKey_ed25519_bip32" + textEnvelopeType _ = "GenesisExtendedSigningKey_ed25519_bip32" instance CastVerificationKeyRole GenesisExtendedKey GenesisKey where - castVerificationKey (GenesisExtendedVerificationKey vk) = - GenesisVerificationKey + castVerificationKey (GenesisExtendedVerificationKey vk) = + GenesisVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - + where + impossible = + error "castVerificationKey: byron and shelley key sizes do not match!" -- -- Genesis delegate keys @@ -1291,103 +1308,102 @@ instance CastVerificationKeyRole GenesisExtendedKey GenesisKey where data GenesisDelegateKey instance HasTypeProxy GenesisDelegateKey where - data AsType GenesisDelegateKey = AsGenesisDelegateKey - proxyToAsType _ = AsGenesisDelegateKey - + data AsType GenesisDelegateKey = AsGenesisDelegateKey + proxyToAsType _ = AsGenesisDelegateKey instance Key GenesisDelegateKey where - - newtype VerificationKey GenesisDelegateKey = - GenesisDelegateVerificationKey (Shelley.VKey Shelley.GenesisDelegate StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisDelegateKey = - GenesisDelegateSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisDelegateKey -> Crypto.Seed -> SigningKey GenesisDelegateKey - deterministicSigningKey AsGenesisDelegateKey seed = - GenesisDelegateSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisDelegateKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey GenesisDelegateKey -> VerificationKey GenesisDelegateKey - getVerificationKey (GenesisDelegateSigningKey sk) = - GenesisDelegateVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisDelegateKey -> Hash GenesisDelegateKey - verificationKeyHash (GenesisDelegateVerificationKey vkey) = - GenesisDelegateKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey GenesisDelegateKey + = GenesisDelegateVerificationKey (Shelley.VKey Shelley.GenesisDelegate StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey GenesisDelegateKey + = GenesisDelegateSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType GenesisDelegateKey -> Crypto.Seed -> SigningKey GenesisDelegateKey + deterministicSigningKey AsGenesisDelegateKey seed = + GenesisDelegateSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType GenesisDelegateKey -> Word + deterministicSigningKeySeedSize AsGenesisDelegateKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey GenesisDelegateKey -> VerificationKey GenesisDelegateKey + getVerificationKey (GenesisDelegateSigningKey sk) = + GenesisDelegateVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey GenesisDelegateKey -> Hash GenesisDelegateKey + verificationKeyHash (GenesisDelegateVerificationKey vkey) = + GenesisDelegateKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (GenesisDelegateVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisDelegateKey") $ - GenesisDelegateVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisDelegateKey") $ + GenesisDelegateVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisDelegateKey") $ - GenesisDelegateSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + serialiseToRawBytes (GenesisDelegateSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisDelegateKey") $ + GenesisDelegateSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs -newtype instance Hash GenesisDelegateKey = - GenesisDelegateKeyHash { unGenesisDelegateKeyHash :: Shelley.KeyHash Shelley.GenesisDelegate StandardCrypto } +newtype instance Hash GenesisDelegateKey + = GenesisDelegateKeyHash + {unGenesisDelegateKeyHash :: Shelley.KeyHash Shelley.GenesisDelegate StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (GenesisDelegateKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsGenesisDelegateKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisDelegateKey") $ - GenesisDelegateKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGenesisDelegateKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisDelegateKey") $ + GenesisDelegateKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey GenesisDelegateKey) where - textEnvelopeType _ = "GenesisDelegateVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "GenesisDelegateVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey GenesisDelegateKey) where - textEnvelopeType _ = "GenesisDelegateSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "GenesisDelegateSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance CastVerificationKeyRole GenesisDelegateKey StakePoolKey where - castVerificationKey (GenesisDelegateVerificationKey (Shelley.VKey vkey)) = - StakePoolVerificationKey (Shelley.VKey vkey) + castVerificationKey (GenesisDelegateVerificationKey (Shelley.VKey vkey)) = + StakePoolVerificationKey (Shelley.VKey vkey) instance CastSigningKeyRole GenesisDelegateKey StakePoolKey where - castSigningKey (GenesisDelegateSigningKey skey) = - StakePoolSigningKey skey + castSigningKey (GenesisDelegateSigningKey skey) = + StakePoolSigningKey skey instance CastVerificationKeyRole StakePoolKey StakeKey where - castVerificationKey (StakePoolVerificationKey (Shelley.VKey vkey)) = - StakeVerificationKey (Shelley.VKey vkey) + castVerificationKey (StakePoolVerificationKey (Shelley.VKey vkey)) = + StakeVerificationKey (Shelley.VKey vkey) -- -- Shelley genesis delegate extended ed25519 keys @@ -1405,125 +1421,134 @@ instance CastVerificationKeyRole StakePoolKey StakeKey where -- key ('VerificationKey' 'GenesisKey'). -- -- This is a type level tag, used with other interfaces like 'Key'. --- data GenesisDelegateExtendedKey instance HasTypeProxy GenesisDelegateExtendedKey where - data AsType GenesisDelegateExtendedKey = AsGenesisDelegateExtendedKey - proxyToAsType _ = AsGenesisDelegateExtendedKey + data AsType GenesisDelegateExtendedKey = AsGenesisDelegateExtendedKey + proxyToAsType _ = AsGenesisDelegateExtendedKey instance Key GenesisDelegateExtendedKey where - - newtype VerificationKey GenesisDelegateExtendedKey = - GenesisDelegateExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateExtendedKey) - - newtype SigningKey GenesisDelegateExtendedKey = - GenesisDelegateExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateExtendedKey) - - deterministicSigningKey :: AsType GenesisDelegateExtendedKey - -> Crypto.Seed - -> SigningKey GenesisDelegateExtendedKey - deterministicSigningKey AsGenesisDelegateExtendedKey seed = - GenesisDelegateExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisDelegateExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateExtendedKey = 32 - - getVerificationKey :: SigningKey GenesisDelegateExtendedKey - -> VerificationKey GenesisDelegateExtendedKey - getVerificationKey (GenesisDelegateExtendedSigningKey sk) = - GenesisDelegateExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey GenesisDelegateExtendedKey - -> Hash GenesisDelegateExtendedKey - verificationKeyHash (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateExtendedKeyHash + newtype VerificationKey GenesisDelegateExtendedKey + = GenesisDelegateExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateExtendedKey) + + newtype SigningKey GenesisDelegateExtendedKey + = GenesisDelegateExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateExtendedKey) + + deterministicSigningKey + :: AsType GenesisDelegateExtendedKey + -> Crypto.Seed + -> SigningKey GenesisDelegateExtendedKey + deterministicSigningKey AsGenesisDelegateExtendedKey seed = + GenesisDelegateExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType GenesisDelegateExtendedKey -> Word + deterministicSigningKeySeedSize AsGenesisDelegateExtendedKey = 32 + + getVerificationKey + :: SigningKey GenesisDelegateExtendedKey + -> VerificationKey GenesisDelegateExtendedKey + getVerificationKey (GenesisDelegateExtendedSigningKey sk) = + GenesisDelegateExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey GenesisDelegateExtendedKey + -> Hash GenesisDelegateExtendedKey + verificationKeyHash (GenesisDelegateExtendedVerificationKey vk) = + GenesisDelegateExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - instance ToCBOR (VerificationKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (GenesisDelegateExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . GenesisDelegateExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . GenesisDelegateExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (GenesisDelegateExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . GenesisDelegateExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . GenesisDelegateExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (GenesisDelegateExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateExtendedKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise VerificationKey GenesisDelegateExtendedKey: " ++ msg)) $ - GenesisDelegateExtendedVerificationKey <$> Crypto.HD.xpub bs + deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateExtendedKey) bs = + first + ( \msg -> + SerialiseAsRawBytesError + ("Unable to deserialise VerificationKey GenesisDelegateExtendedKey: " ++ msg) + ) + $ GenesisDelegateExtendedVerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateExtendedKey) bs = - first (\msg -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey GenesisDelegateExtendedKey: " ++ msg)) $ - GenesisDelegateExtendedSigningKey <$> Crypto.HD.xprv bs - - -newtype instance Hash GenesisDelegateExtendedKey = - GenesisDelegateExtendedKeyHash { unGenesisDelegateExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto } + serialiseToRawBytes (GenesisDelegateExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv + + deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateExtendedKey) bs = + first + ( \msg -> + SerialiseAsRawBytesError ("Unable to deserialise SigningKey GenesisDelegateExtendedKey: " ++ msg) + ) + $ GenesisDelegateExtendedSigningKey <$> Crypto.HD.xprv bs + +newtype instance Hash GenesisDelegateExtendedKey + = GenesisDelegateExtendedKeyHash + {unGenesisDelegateExtendedKeyHash :: Shelley.KeyHash Shelley.Staking StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateExtendedKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateExtendedKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (GenesisDelegateExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsGenesisDelegateExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisDelegateExtendedKey: ") $ - GenesisDelegateExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGenesisDelegateExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisDelegateExtendedKey: ") $ + GenesisDelegateExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedVerificationKey_ed25519_bip32" + textEnvelopeType _ = "GenesisDelegateExtendedVerificationKey_ed25519_bip32" instance HasTextEnvelope (SigningKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedSigningKey_ed25519_bip32" + textEnvelopeType _ = "GenesisDelegateExtendedSigningKey_ed25519_bip32" instance CastVerificationKeyRole GenesisDelegateExtendedKey GenesisDelegateKey where - castVerificationKey (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateVerificationKey + castVerificationKey (GenesisDelegateExtendedVerificationKey vk) = + GenesisDelegateVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - + where + impossible = + error "castVerificationKey: byron and shelley key sizes do not match!" -- -- Genesis UTxO keys @@ -1532,101 +1557,99 @@ instance CastVerificationKeyRole GenesisDelegateExtendedKey GenesisDelegateKey w data GenesisUTxOKey instance HasTypeProxy GenesisUTxOKey where - data AsType GenesisUTxOKey = AsGenesisUTxOKey - proxyToAsType _ = AsGenesisUTxOKey - + data AsType GenesisUTxOKey = AsGenesisUTxOKey + proxyToAsType _ = AsGenesisUTxOKey instance Key GenesisUTxOKey where - - newtype VerificationKey GenesisUTxOKey = - GenesisUTxOVerificationKey (Shelley.VKey Shelley.Payment StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisUTxOKey = - GenesisUTxOSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisUTxOKey -> Crypto.Seed -> SigningKey GenesisUTxOKey - deterministicSigningKey AsGenesisUTxOKey seed = - GenesisUTxOSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisUTxOKey -> Word - deterministicSigningKeySeedSize AsGenesisUTxOKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey GenesisUTxOKey -> VerificationKey GenesisUTxOKey - getVerificationKey (GenesisUTxOSigningKey sk) = - GenesisUTxOVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisUTxOKey -> Hash GenesisUTxOKey - verificationKeyHash (GenesisUTxOVerificationKey vkey) = - GenesisUTxOKeyHash (Shelley.hashKey vkey) - + newtype VerificationKey GenesisUTxOKey + = GenesisUTxOVerificationKey (Shelley.VKey Shelley.Payment StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisUTxOKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey GenesisUTxOKey + = GenesisUTxOSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisUTxOKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType GenesisUTxOKey -> Crypto.Seed -> SigningKey GenesisUTxOKey + deterministicSigningKey AsGenesisUTxOKey seed = + GenesisUTxOSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType GenesisUTxOKey -> Word + deterministicSigningKeySeedSize AsGenesisUTxOKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey GenesisUTxOKey -> VerificationKey GenesisUTxOKey + getVerificationKey (GenesisUTxOSigningKey sk) = + GenesisUTxOVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey GenesisUTxOKey -> Hash GenesisUTxOKey + verificationKeyHash (GenesisUTxOVerificationKey vkey) = + GenesisUTxOKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (GenesisUTxOVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsGenesisUTxOKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisUTxOKey") $ - GenesisUTxOVerificationKey . Shelley.VKey <$> Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsGenesisUTxOKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey GenesisUTxOKey") $ + GenesisUTxOVerificationKey . Shelley.VKey <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisUTxOKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisUTxOKey") $ - GenesisUTxOSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs + serialiseToRawBytes (GenesisUTxOSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk + deserialiseFromRawBytes (AsSigningKey AsGenesisUTxOKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise SigningKey GenesisUTxOKey") $ + GenesisUTxOSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs -newtype instance Hash GenesisUTxOKey = - GenesisUTxOKeyHash { unGenesisUTxOKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto } +newtype instance Hash GenesisUTxOKey + = GenesisUTxOKeyHash {unGenesisUTxOKeyHash :: Shelley.KeyHash Shelley.Payment StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisUTxOKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisUTxOKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (GenesisUTxOKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsGenesisUTxOKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisUTxOKey") $ - GenesisUTxOKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsGenesisUTxOKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash GenesisUTxOKey") $ + GenesisUTxOKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey GenesisUTxOKey) where - textEnvelopeType _ = "GenesisUTxOVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "GenesisUTxOVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey GenesisUTxOKey) where - textEnvelopeType _ = "GenesisUTxOSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - -- TODO: use a different type from the stake pool key, since some operations - -- need a genesis key specifically + textEnvelopeType _ = + "GenesisUTxOSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + +-- TODO: use a different type from the stake pool key, since some operations +-- need a genesis key specifically instance CastVerificationKeyRole GenesisUTxOKey PaymentKey where - castVerificationKey (GenesisUTxOVerificationKey (Shelley.VKey vkey)) = - PaymentVerificationKey (Shelley.VKey vkey) + castVerificationKey (GenesisUTxOVerificationKey (Shelley.VKey vkey)) = + PaymentVerificationKey (Shelley.VKey vkey) instance CastSigningKeyRole GenesisUTxOKey PaymentKey where - castSigningKey (GenesisUTxOSigningKey skey) = - PaymentSigningKey skey - + castSigningKey (GenesisUTxOSigningKey skey) = + PaymentSigningKey skey -- -- stake pool keys @@ -1635,92 +1658,91 @@ instance CastSigningKeyRole GenesisUTxOKey PaymentKey where data StakePoolKey instance HasTypeProxy StakePoolKey where - data AsType StakePoolKey = AsStakePoolKey - proxyToAsType _ = AsStakePoolKey + data AsType StakePoolKey = AsStakePoolKey + proxyToAsType _ = AsStakePoolKey instance Key StakePoolKey where - - newtype VerificationKey StakePoolKey = - StakePoolVerificationKey (Shelley.VKey Shelley.StakePool StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakePoolKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey StakePoolKey = - StakePoolSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakePoolKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType StakePoolKey -> Crypto.Seed -> SigningKey StakePoolKey - deterministicSigningKey AsStakePoolKey seed = - StakePoolSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakePoolKey -> Word - deterministicSigningKeySeedSize AsStakePoolKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey - getVerificationKey (StakePoolSigningKey sk) = - StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey - verificationKeyHash (StakePoolVerificationKey vkey) = - StakePoolKeyHash (Shelley.hashKey vkey) + newtype VerificationKey StakePoolKey + = StakePoolVerificationKey (Shelley.VKey Shelley.StakePool StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakePoolKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey StakePoolKey + = StakePoolSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakePoolKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType StakePoolKey -> Crypto.Seed -> SigningKey StakePoolKey + deterministicSigningKey AsStakePoolKey seed = + StakePoolSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType StakePoolKey -> Word + deterministicSigningKeySeedSize AsStakePoolKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey + getVerificationKey (StakePoolSigningKey sk) = + StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey + verificationKeyHash (StakePoolVerificationKey vkey) = + StakePoolKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey StakePoolKey) where - serialiseToRawBytes (StakePoolVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (StakePoolVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsStakePoolKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey StakePoolKey") $ - StakePoolVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsStakePoolKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey StakePoolKey") $ + StakePoolVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey StakePoolKey) where - serialiseToRawBytes (StakePoolSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk + serialiseToRawBytes (StakePoolSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk - deserialiseFromRawBytes (AsSigningKey AsStakePoolKey) bs = - maybe - (Left (SerialiseAsRawBytesError "Unable to deserialise SigningKey StakePoolKey")) - (Right . StakePoolSigningKey) - (Crypto.rawDeserialiseSignKeyDSIGN bs) + deserialiseFromRawBytes (AsSigningKey AsStakePoolKey) bs = + maybe + (Left (SerialiseAsRawBytesError "Unable to deserialise SigningKey StakePoolKey")) + (Right . StakePoolSigningKey) + (Crypto.rawDeserialiseSignKeyDSIGN bs) instance SerialiseAsBech32 (VerificationKey StakePoolKey) where - bech32PrefixFor _ = "pool_vk" - bech32PrefixesPermitted _ = ["pool_vk"] + bech32PrefixFor _ = "pool_vk" + bech32PrefixesPermitted _ = ["pool_vk"] instance SerialiseAsBech32 (SigningKey StakePoolKey) where - bech32PrefixFor _ = "pool_sk" - bech32PrefixesPermitted _ = ["pool_sk"] + bech32PrefixFor _ = "pool_sk" + bech32PrefixesPermitted _ = ["pool_sk"] -newtype instance Hash StakePoolKey = - StakePoolKeyHash { unStakePoolKeyHash :: Shelley.KeyHash Shelley.StakePool StandardCrypto } +newtype instance Hash StakePoolKey + = StakePoolKeyHash {unStakePoolKeyHash :: Shelley.KeyHash Shelley.StakePool StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash StakePoolKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakePoolKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash StakePoolKey) where - serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsStakePoolKey) bs = - maybeToRight - (SerialiseAsRawBytesError "Unable to deserialise Hash StakePoolKey") - (StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) + deserialiseFromRawBytes (AsHash AsStakePoolKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash StakePoolKey") + (StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) instance SerialiseAsBech32 (Hash StakePoolKey) where - bech32PrefixFor _ = "pool" - bech32PrefixesPermitted _ = ["pool"] + bech32PrefixFor _ = "pool" + bech32PrefixesPermitted _ = ["pool"] instance ToJSON (Hash StakePoolKey) where - toJSON = toJSON . serialiseToBech32 + toJSON = toJSON . serialiseToBech32 instance ToJSONKey (Hash StakePoolKey) where toJSONKey = toJSONKeyText serialiseToBech32 @@ -1729,25 +1751,29 @@ instance FromJSON (Hash StakePoolKey) where parseJSON = withText "PoolId" $ \str -> case deserialiseFromBech32 (AsHash AsStakePoolKey) str of Left err -> - fail $ docToString $ mconcat - [ "Error deserialising Hash StakePoolKey: " <> pretty str - , " Error: " <> prettyError err - ] + fail $ + docToString $ + mconcat + [ "Error deserialising Hash StakePoolKey: " <> pretty str + , " Error: " <> prettyError err + ] Right h -> pure h instance HasTextEnvelope (VerificationKey StakePoolKey) where - textEnvelopeType _ = "StakePoolVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "StakePoolVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey StakePoolKey) where - textEnvelopeType _ = "StakePoolSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "StakePoolSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy -- -- DRep keys @@ -1756,92 +1782,91 @@ instance HasTextEnvelope (SigningKey StakePoolKey) where data DRepKey instance HasTypeProxy DRepKey where - data AsType DRepKey = AsDRepKey - proxyToAsType _ = AsDRepKey + data AsType DRepKey = AsDRepKey + proxyToAsType _ = AsDRepKey instance Key DRepKey where - - newtype VerificationKey DRepKey = - DRepVerificationKey (Shelley.VKey Shelley.DRepRole StandardCrypto) - deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey DRepKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey DRepKey = - DRepSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey DRepKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType DRepKey -> Crypto.Seed -> SigningKey DRepKey - deterministicSigningKey AsDRepKey seed = - DRepSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType DRepKey -> Word - deterministicSigningKeySeedSize AsDRepKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey DRepKey -> VerificationKey DRepKey - getVerificationKey (DRepSigningKey sk) = - DRepVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey DRepKey -> Hash DRepKey - verificationKeyHash (DRepVerificationKey vkey) = - DRepKeyHash (Shelley.hashKey vkey) + newtype VerificationKey DRepKey + = DRepVerificationKey (Shelley.VKey Shelley.DRepRole StandardCrypto) + deriving stock (Eq) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey DRepKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + newtype SigningKey DRepKey + = DRepSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey DRepKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (SerialiseAsCBOR) + + deterministicSigningKey :: AsType DRepKey -> Crypto.Seed -> SigningKey DRepKey + deterministicSigningKey AsDRepKey seed = + DRepSigningKey (Crypto.genKeyDSIGN seed) + + deterministicSigningKeySeedSize :: AsType DRepKey -> Word + deterministicSigningKeySeedSize AsDRepKey = + Crypto.seedSizeDSIGN proxy + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy + + getVerificationKey :: SigningKey DRepKey -> VerificationKey DRepKey + getVerificationKey (DRepSigningKey sk) = + DRepVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) + + verificationKeyHash :: VerificationKey DRepKey -> Hash DRepKey + verificationKeyHash (DRepVerificationKey vkey) = + DRepKeyHash (Shelley.hashKey vkey) instance SerialiseAsRawBytes (VerificationKey DRepKey) where - serialiseToRawBytes (DRepVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk + serialiseToRawBytes (DRepVerificationKey (Shelley.VKey vk)) = + Crypto.rawSerialiseVerKeyDSIGN vk - deserialiseFromRawBytes (AsVerificationKey AsDRepKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey DRepKey") $ - DRepVerificationKey . Shelley.VKey <$> - Crypto.rawDeserialiseVerKeyDSIGN bs + deserialiseFromRawBytes (AsVerificationKey AsDRepKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise VerificationKey DRepKey") $ + DRepVerificationKey . Shelley.VKey + <$> Crypto.rawDeserialiseVerKeyDSIGN bs instance SerialiseAsRawBytes (SigningKey DRepKey) where - serialiseToRawBytes (DRepSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk + serialiseToRawBytes (DRepSigningKey sk) = + Crypto.rawSerialiseSignKeyDSIGN sk - deserialiseFromRawBytes (AsSigningKey AsDRepKey) bs = - maybe - (Left (SerialiseAsRawBytesError "Unable to deserialise SigningKey DRepKey")) - (Right . DRepSigningKey) - (Crypto.rawDeserialiseSignKeyDSIGN bs) + deserialiseFromRawBytes (AsSigningKey AsDRepKey) bs = + maybe + (Left (SerialiseAsRawBytesError "Unable to deserialise SigningKey DRepKey")) + (Right . DRepSigningKey) + (Crypto.rawDeserialiseSignKeyDSIGN bs) instance SerialiseAsBech32 (VerificationKey DRepKey) where - bech32PrefixFor _ = "drep_vk" - bech32PrefixesPermitted _ = ["drep_vk"] + bech32PrefixFor _ = "drep_vk" + bech32PrefixesPermitted _ = ["drep_vk"] instance SerialiseAsBech32 (SigningKey DRepKey) where - bech32PrefixFor _ = "drep_sk" - bech32PrefixesPermitted _ = ["drep_sk"] + bech32PrefixFor _ = "drep_sk" + bech32PrefixesPermitted _ = ["drep_sk"] -newtype instance Hash DRepKey = - DRepKeyHash { unDRepKeyHash :: Shelley.KeyHash Shelley.DRepRole StandardCrypto } +newtype instance Hash DRepKey + = DRepKeyHash {unDRepKeyHash :: Shelley.KeyHash Shelley.DRepRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash DRepKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash DRepKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance SerialiseAsRawBytes (Hash DRepKey) where - serialiseToRawBytes (DRepKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (DRepKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsDRepKey) bs = - maybeToRight - (SerialiseAsRawBytesError "Unable to deserialise Hash DRepKey") - (DRepKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) + deserialiseFromRawBytes (AsHash AsDRepKey) bs = + maybeToRight + (SerialiseAsRawBytesError "Unable to deserialise Hash DRepKey") + (DRepKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs) instance SerialiseAsBech32 (Hash DRepKey) where - bech32PrefixFor _ = "drep" - bech32PrefixesPermitted _ = ["drep"] + bech32PrefixFor _ = "drep" + bech32PrefixesPermitted _ = ["drep"] instance ToJSON (Hash DRepKey) where - toJSON = toJSON . serialiseToBech32 + toJSON = toJSON . serialiseToBech32 instance ToJSONKey (Hash DRepKey) where toJSONKey = toJSONKeyText serialiseToBech32 @@ -1850,25 +1875,29 @@ instance FromJSON (Hash DRepKey) where parseJSON = withText "DRepId" $ \str -> case deserialiseFromBech32 (AsHash AsDRepKey) str of Left err -> - fail $ docToString $ mconcat - [ "Error deserialising Hash DRepKey: " <> pretty str - , " Error: " <> prettyError err - ] + fail $ + docToString $ + mconcat + [ "Error deserialising Hash DRepKey: " <> pretty str + , " Error: " <> prettyError err + ] Right h -> pure h instance HasTextEnvelope (VerificationKey DRepKey) where - textEnvelopeType _ = "DRepVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "DRepVerificationKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy instance HasTextEnvelope (SigningKey DRepKey) where - textEnvelopeType _ = "DRepSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy (Shelley.DSIGN StandardCrypto) - proxy = Proxy + textEnvelopeType _ = + "DRepSigningKey_" + <> fromString (Crypto.algorithmNameDSIGN proxy) + where + proxy :: Proxy (Shelley.DSIGN StandardCrypto) + proxy = Proxy --- --- Drep extended keys @@ -1876,126 +1905,130 @@ instance HasTextEnvelope (SigningKey DRepKey) where data DRepExtendedKey instance HasTypeProxy DRepExtendedKey where - data AsType DRepExtendedKey = AsDRepExtendedKey - proxyToAsType _ = AsDRepExtendedKey + data AsType DRepExtendedKey = AsDRepExtendedKey + proxyToAsType _ = AsDRepExtendedKey instance Key DRepExtendedKey where - - newtype VerificationKey DRepExtendedKey = - DRepExtendedVerificationKey Crypto.HD.XPub - deriving stock (Eq) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey DRepExtendedKey = - DRepExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: AsType DRepExtendedKey - -> Crypto.Seed - -> SigningKey DRepExtendedKey - deterministicSigningKey AsDRepExtendedKey seed = - DRepExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType DRepExtendedKey -> Word - deterministicSigningKeySeedSize AsDRepExtendedKey = 32 - - getVerificationKey :: SigningKey DRepExtendedKey - -> VerificationKey DRepExtendedKey - getVerificationKey (DRepExtendedSigningKey sk) = - DRepExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- | We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - -- - verificationKeyHash :: VerificationKey DRepExtendedKey - -> Hash DRepExtendedKey - verificationKeyHash (DRepExtendedVerificationKey vk) = - DRepExtendedKeyHash + newtype VerificationKey DRepExtendedKey + = DRepExtendedVerificationKey Crypto.HD.XPub + deriving stock (Eq) + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) + + newtype SigningKey DRepExtendedKey + = DRepExtendedSigningKey Crypto.HD.XPrv + deriving anyclass (SerialiseAsCBOR) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) + + deterministicSigningKey + :: AsType DRepExtendedKey + -> Crypto.Seed + -> SigningKey DRepExtendedKey + deterministicSigningKey AsDRepExtendedKey seed = + DRepExtendedSigningKey + (Crypto.HD.generate seedbs BS.empty) + where + (seedbs, _) = Crypto.getBytesFromSeedT 32 seed + + deterministicSigningKeySeedSize :: AsType DRepExtendedKey -> Word + deterministicSigningKeySeedSize AsDRepExtendedKey = 32 + + getVerificationKey + :: SigningKey DRepExtendedKey + -> VerificationKey DRepExtendedKey + getVerificationKey (DRepExtendedSigningKey sk) = + DRepExtendedVerificationKey (Crypto.HD.toXPub sk) + + -- \| We use the hash of the normal non-extended pub key so that it is + -- consistent with the one used in addresses and signatures. + verificationKeyHash + :: VerificationKey DRepExtendedKey + -> Hash DRepExtendedKey + verificationKeyHash (DRepExtendedVerificationKey vk) = + DRepExtendedKeyHash . Shelley.KeyHash . Crypto.castHash $ Crypto.hashWith Crypto.HD.xpubPublicKey vk -newtype instance Hash DRepExtendedKey = - DRepExtendedKeyHash { unDRepExtendedKeyHash :: Shelley.KeyHash Shelley.DRepRole StandardCrypto } +newtype instance Hash DRepExtendedKey + = DRepExtendedKeyHash {unDRepExtendedKeyHash :: Shelley.KeyHash Shelley.DRepRole StandardCrypto} deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash DRepKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash DRepKey) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance ToCBOR (VerificationKey DRepExtendedKey) where - toCBOR (DRepExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) + toCBOR (DRepExtendedVerificationKey xpub) = + toCBOR (Crypto.HD.unXPub xpub) instance FromCBOR (VerificationKey DRepExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . DRepExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . DRepExtendedVerificationKey) + (Crypto.HD.xpub (bs :: ByteString)) instance ToCBOR (SigningKey DRepExtendedKey) where - toCBOR (DRepExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) + toCBOR (DRepExtendedSigningKey xprv) = + toCBOR (Crypto.HD.unXPrv xprv) instance FromCBOR (SigningKey DRepExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either fail (return . DRepExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) + fromCBOR = do + bs <- fromCBOR + either + fail + (return . DRepExtendedSigningKey) + (Crypto.HD.xprv (bs :: ByteString)) instance SerialiseAsRawBytes (VerificationKey DRepExtendedKey) where - serialiseToRawBytes (DRepExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub + serialiseToRawBytes (DRepExtendedVerificationKey xpub) = + Crypto.HD.unXPub xpub - deserialiseFromRawBytes (AsVerificationKey AsDRepExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey DRepExtendedKey")) - (DRepExtendedVerificationKey <$> Crypto.HD.xpub bs) + deserialiseFromRawBytes (AsVerificationKey AsDRepExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise VerificationKey DRepExtendedKey")) + (DRepExtendedVerificationKey <$> Crypto.HD.xpub bs) instance SerialiseAsRawBytes (SigningKey DRepExtendedKey) where - serialiseToRawBytes (DRepExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv + serialiseToRawBytes (DRepExtendedSigningKey xprv) = + Crypto.HD.unXPrv xprv - deserialiseFromRawBytes (AsSigningKey AsDRepExtendedKey) bs = - first - (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey DRepExtendedKey")) - (DRepExtendedSigningKey <$> Crypto.HD.xprv bs) + deserialiseFromRawBytes (AsSigningKey AsDRepExtendedKey) bs = + first + (const (SerialiseAsRawBytesError "Unable to deserialise SigningKey DRepExtendedKey")) + (DRepExtendedSigningKey <$> Crypto.HD.xprv bs) instance SerialiseAsRawBytes (Hash DRepExtendedKey) where - serialiseToRawBytes (DRepExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh + serialiseToRawBytes (DRepExtendedKeyHash (Shelley.KeyHash vkh)) = + Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsDRepExtendedKey) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash DRepExtendedKey") $ - DRepExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsDRepExtendedKey) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash DRepExtendedKey") $ + DRepExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs instance HasTextEnvelope (VerificationKey DRepExtendedKey) where - textEnvelopeType _ = "DRepExtendedVerificationKey_ed25519_bip32" + textEnvelopeType _ = "DRepExtendedVerificationKey_ed25519_bip32" instance HasTextEnvelope (SigningKey DRepExtendedKey) where - textEnvelopeType _ = "DRepExtendedSigningKey_ed25519_bip32" + textEnvelopeType _ = "DRepExtendedSigningKey_ed25519_bip32" instance SerialiseAsBech32 (VerificationKey DRepExtendedKey) where - bech32PrefixFor _ = "drep_xvk" - bech32PrefixesPermitted _ = ["drep_xvk"] + bech32PrefixFor _ = "drep_xvk" + bech32PrefixesPermitted _ = ["drep_xvk"] instance SerialiseAsBech32 (SigningKey DRepExtendedKey) where - bech32PrefixFor _ = "drep_xsk" - bech32PrefixesPermitted _ = ["drep_xsk"] + bech32PrefixFor _ = "drep_xsk" + bech32PrefixesPermitted _ = ["drep_xsk"] instance CastVerificationKeyRole DRepExtendedKey DRepKey where - castVerificationKey (DRepExtendedVerificationKey vk) = - DRepVerificationKey + castVerificationKey (DRepExtendedVerificationKey vk) = + DRepVerificationKey . Shelley.VKey . fromMaybe impossible . Crypto.rawDeserialiseVerKeyDSIGN . Crypto.HD.xpubPublicKey $ vk - where - impossible = - error "castVerificationKey (DRep): byron and shelley key sizes do not match!" - + where + impossible = + error "castVerificationKey (DRep): byron and shelley key sizes do not match!" diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 12dd53e60b..dc20111407 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -4,8 +4,8 @@ {- HLINT ignore "Eta reduce" -} module Cardano.Api.Ledger.Lens - ( -- *Types - TxBody(..) + ( -- * Types + TxBody (..) -- * Constructors , mkAdaOnlyTxOut @@ -21,7 +21,6 @@ module Cardano.Api.Ledger.Lens , invalidHereAfterTxBodyL , ttlAsInvalidHereAfterTxBodyL , updateTxBodyL - , txBodyL , mintTxBodyL , scriptIntegrityHashTxBodyL @@ -39,35 +38,34 @@ module Cardano.Api.Ledger.Lens , multiAssetL , valueTxOutL , valueTxOutAdaAssetL - ) where - -import Cardano.Api.Eon.AllegraEraOnwards -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyEraOnly -import Cardano.Api.Eon.ShelleyToAllegraEra -import Cardano.Api.Eon.ShelleyToBabbageEra -import Cardano.Api.Eras.Case -import Cardano.Api.Orphans () - + ) +where + +import Cardano.Api.Eon.AllegraEraOnwards +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyEraOnly +import Cardano.Api.Eon.ShelleyToAllegraEra +import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eras.Case +import Cardano.Api.Orphans () import qualified Cardano.Ledger.Allegra.Core as L import qualified Cardano.Ledger.Alonzo.Core as L import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) +import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.Core as L import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.Shelley.PParams as L import qualified Cardano.Ledger.TxIn as L - import qualified Data.OSet.Strict as L import qualified Data.Sequence.Strict as L -import Data.Set (Set) -import Lens.Micro +import Data.Set (Set) +import Lens.Micro newtype TxBody era = TxBody { unTxBody :: L.TxBody (ShelleyLedgerEra era) @@ -75,13 +73,13 @@ newtype TxBody era = TxBody strictMaybeL :: Lens' (StrictMaybe a) (Maybe a) strictMaybeL = lens g s - where - g :: StrictMaybe a -> Maybe a - g SNothing = Nothing - g (SJust x) = Just x + where + g :: StrictMaybe a -> Maybe a + g SNothing = Nothing + g (SJust x) = Just x - s :: StrictMaybe a -> Maybe a -> StrictMaybe a - s _ = maybe SNothing SJust + s :: StrictMaybe a -> Maybe a -> StrictMaybe a + s _ = maybe SNothing SJust txBodyL :: Lens' (TxBody era) (L.TxBody (ShelleyLedgerEra era)) txBodyL = lens unTxBody (\_ x -> TxBody x) @@ -113,72 +111,81 @@ invalidHereAfterTxBodyL = -- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'. ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (TxBody era) (Maybe SlotNo) ttlAsInvalidHereAfterTxBodyL w = lens (g w) (s w) - where - g :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo - g w' txBody = - shelleyEraOnlyConstraints w' $ - let ttl = txBody ^. txBodyL . L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl - - s :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo -> TxBody era - s w' txBody mSlotNo = - shelleyEraOnlyConstraints w' $ - case mSlotNo of - Nothing -> txBody & txBodyL . L.ttlTxBodyL .~ maxBound - Just ttl -> txBody & txBodyL . L.ttlTxBodyL .~ ttl + where + g :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo + g w' txBody = + shelleyEraOnlyConstraints w' $ + let ttl = txBody ^. txBodyL . L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl + + s :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo -> TxBody era + s w' txBody mSlotNo = + shelleyEraOnlyConstraints w' $ + case mSlotNo of + Nothing -> txBody & txBodyL . L.ttlTxBodyL .~ maxBound + Just ttl -> txBody & txBodyL . L.ttlTxBodyL .~ ttl -- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. -- Ideally this should be defined in cardano-ledger invalidBeforeStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo) invalidBeforeStrictL = lens g s - where - g :: L.ValidityInterval -> StrictMaybe SlotNo - g (L.ValidityInterval a _) = a + where + g :: L.ValidityInterval -> StrictMaybe SlotNo + g (L.ValidityInterval a _) = a - s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval - s (L.ValidityInterval _ b) a = L.ValidityInterval a b + s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval + s (L.ValidityInterval _ b) a = L.ValidityInterval a b -- | Lens to access the 'invalidHereAfter' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. -- Ideally this should be defined in cardano-ledger invalidHereAfterStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo) invalidHereAfterStrictL = lens g s - where - g :: L.ValidityInterval -> StrictMaybe SlotNo - g (L.ValidityInterval _ b) = b + where + g :: L.ValidityInterval -> StrictMaybe SlotNo + g (L.ValidityInterval _ b) = b - s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval - s (L.ValidityInterval a _) b = L.ValidityInterval a b + s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval + s (L.ValidityInterval a _) b = L.ValidityInterval a b -updateTxBodyL :: ShelleyToBabbageEra era -> Lens' (TxBody era) (StrictMaybe (L.Update (ShelleyLedgerEra era))) +updateTxBodyL + :: ShelleyToBabbageEra era -> Lens' (TxBody era) (StrictMaybe (L.Update (ShelleyLedgerEra era))) updateTxBodyL w = shelleyToBabbageEraConstraints w $ txBodyL . L.updateTxBodyL mintTxBodyL :: MaryEraOnwards era -> Lens' (TxBody era) (L.MultiAsset L.StandardCrypto) mintTxBodyL w = maryEraOnwardsConstraints w $ txBodyL . L.mintTxBodyL -scriptIntegrityHashTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.ScriptIntegrityHash L.StandardCrypto)) +scriptIntegrityHashTxBodyL + :: AlonzoEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.ScriptIntegrityHash L.StandardCrypto)) scriptIntegrityHashTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.scriptIntegrityHashTxBodyL -collateralInputsTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) +collateralInputsTxBodyL + :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) collateralInputsTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.collateralInputsTxBodyL -reqSignerHashesTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.KeyHash L.Witness L.StandardCrypto)) +reqSignerHashesTxBodyL + :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.KeyHash L.Witness L.StandardCrypto)) reqSignerHashesTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.reqSignerHashesTxBodyL -referenceInputsTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) +referenceInputsTxBodyL + :: BabbageEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) referenceInputsTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.referenceInputsTxBodyL -collateralReturnTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.TxOut (ShelleyLedgerEra era))) +collateralReturnTxBodyL + :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.TxOut (ShelleyLedgerEra era))) collateralReturnTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.collateralReturnTxBodyL totalCollateralTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe L.Coin) totalCollateralTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.totalCollateralTxBodyL -certsTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (L.StrictSeq (L.TxCert (ShelleyLedgerEra era))) +certsTxBodyL + :: ShelleyBasedEra era -> Lens' (TxBody era) (L.StrictSeq (L.TxCert (ShelleyLedgerEra era))) certsTxBodyL w = shelleyBasedEraConstraints w $ txBodyL . L.certsTxBodyL -votingProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.VotingProcedures (ShelleyLedgerEra era)) +votingProceduresTxBodyL + :: ConwayEraOnwards era -> Lens' (TxBody era) (L.VotingProcedures (ShelleyLedgerEra era)) votingProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.votingProceduresTxBodyL -proposalProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era))) +proposalProceduresTxBodyL + :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era))) proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.proposalProceduresTxBodyL currentTreasuryValueTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (StrictMaybe L.Coin) @@ -187,11 +194,19 @@ currentTreasuryValueTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.curr treasuryDonationTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) L.Coin treasuryDonationTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.treasuryDonationTxBodyL -mkAdaOnlyTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Coin -> L.TxOut (ShelleyLedgerEra era) +mkAdaOnlyTxOut + :: ShelleyBasedEra era + -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) + -> L.Coin + -> L.TxOut (ShelleyLedgerEra era) mkAdaOnlyTxOut sbe addr coin = mkBasicTxOut sbe addr (mkAdaValue sbe coin) -mkBasicTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Value (ShelleyLedgerEra era) -> L.TxOut (ShelleyLedgerEra era) +mkBasicTxOut + :: ShelleyBasedEra era + -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) + -> L.Value (ShelleyLedgerEra era) + -> L.TxOut (ShelleyLedgerEra era) mkBasicTxOut sbe addr value = shelleyBasedEraConstraints sbe $ L.mkBasicTxOut addr value @@ -209,23 +224,28 @@ adaAssetL sbe = adaAssetMaryEraOnwardsL sbe -adaAssetShelleyToAllegraEraL :: ShelleyToAllegraEra era -> Lens' (L.Value (ShelleyLedgerEra era)) L.Coin +adaAssetShelleyToAllegraEraL + :: ShelleyToAllegraEra era -> Lens' (L.Value (ShelleyLedgerEra era)) L.Coin adaAssetShelleyToAllegraEraL w = shelleyToAllegraEraConstraints w $ lens id const adaAssetMaryEraOnwardsL :: MaryEraOnwards era -> Lens' (L.MaryValue L.StandardCrypto) L.Coin adaAssetMaryEraOnwardsL w = - maryEraOnwardsConstraints w $ lens - (\(L.MaryValue c _) -> c) - (\(L.MaryValue _ ma) c -> L.MaryValue c ma) + maryEraOnwardsConstraints w $ + lens + (\(L.MaryValue c _) -> c) + (\(L.MaryValue _ ma) c -> L.MaryValue c ma) -multiAssetL :: MaryEraOnwards era -> Lens' (L.MaryValue L.StandardCrypto) (L.MultiAsset L.StandardCrypto) +multiAssetL + :: MaryEraOnwards era -> Lens' (L.MaryValue L.StandardCrypto) (L.MultiAsset L.StandardCrypto) multiAssetL w = - maryEraOnwardsConstraints w $ lens - (\(L.MaryValue _ ma) -> ma) - (\(L.MaryValue c _) ma -> L.MaryValue c ma) + maryEraOnwardsConstraints w $ + lens + (\(L.MaryValue _ ma) -> ma) + (\(L.MaryValue c _) ma -> L.MaryValue c ma) -valueTxOutL :: ShelleyBasedEra era -> Lens' (L.TxOut (ShelleyLedgerEra era)) (L.Value (ShelleyLedgerEra era)) +valueTxOutL + :: ShelleyBasedEra era -> Lens' (L.TxOut (ShelleyLedgerEra era)) (L.Value (ShelleyLedgerEra era)) valueTxOutL sbe = shelleyBasedEraConstraints sbe L.valueTxOutL valueTxOutAdaAssetL :: ShelleyBasedEra era -> Lens' (L.TxOut (ShelleyLedgerEra era)) L.Coin diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs index 2b48cf7ec8..8e91891441 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs @@ -5,45 +5,55 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Cardano.Api.LedgerEvents.ConvertLedgerEvent - ( LedgerEvent (..), - toLedgerEvent, - ) where - -import Cardano.Api.LedgerEvents.LedgerEvent -import Cardano.Api.LedgerEvents.Rule.BBODY.DELEGS -import Cardano.Api.LedgerEvents.Rule.BBODY.LEDGER -import Cardano.Api.LedgerEvents.Rule.BBODY.UTXOW -import Cardano.Api.LedgerEvents.Rule.TICK.NEWEPOCH -import Cardano.Api.LedgerEvents.Rule.TICK.RUPD - + ( LedgerEvent (..) + , toLedgerEvent + ) +where + +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.BBODY.DELEGS +import Cardano.Api.LedgerEvents.Rule.BBODY.LEDGER +import Cardano.Api.LedgerEvents.Rule.BBODY.UTXOW +import Cardano.Api.LedgerEvents.Rule.TICK.NEWEPOCH +import Cardano.Api.LedgerEvents.Rule.TICK.RUPD import qualified Cardano.Ledger.Allegra.Rules as Allegra -import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..)) -import Cardano.Ledger.Api.Era (AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra, - ShelleyEra) +import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..)) +import Cardano.Ledger.Api.Era + ( AllegraEra + , AlonzoEra + , BabbageEra + , ConwayEra + , MaryEra + , ShelleyEra + ) import qualified Cardano.Ledger.Conway.Rules as Conway -import Cardano.Ledger.Core +import Cardano.Ledger.Core import qualified Cardano.Ledger.Core as Ledger.Core -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Shelley.Rules (RupdEvent (..), ShelleyBbodyEvent (LedgersEvent), - ShelleyNewEpochEvent (..), ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent), - ShelleyUtxowEvent (..)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.Rules + ( RupdEvent (..) + , ShelleyBbodyEvent (LedgersEvent) + , ShelleyNewEpochEvent (..) + , ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent) + , ShelleyUtxowEvent (..) + ) import qualified Cardano.Ledger.Shelley.Rules as Shelley -import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) -import Ouroboros.Consensus.Cardano.Block (HardForkBlock) +import Control.State.Transition (Event) +import Data.SOP.Strict +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Cardano.Block (HardForkBlock) import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, - ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK)) -import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (unwrapLedgerEvent)) - -import Control.State.Transition (Event) -import Data.SOP.Strict +import Ouroboros.Consensus.Shelley.Ledger + ( ShelleyBlock + , ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK) + ) +import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (unwrapLedgerEvent)) class ConvertLedgerEvent blk where toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent @@ -86,7 +96,6 @@ handleShelleyLedgerBBODYEvents (LedgersEvent (Shelley.LedgerEvent e)) = Shelley.UtxowEvent ev -> handlePreAlonzoUTxOWEvent ev Shelley.DelegsEvent ev -> handleShelleyDELEGSEvent ev - instance ConvertLedgerEvent (ShelleyBlock protocol (MaryEra StandardCrypto)) where toLedgerEvent = toLedgerEventAllegraMary @@ -107,8 +116,8 @@ toLedgerEventAllegraMary => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Allegra.AllegraUtxoEvent ledgerera => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera => Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera - => WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> - Maybe LedgerEvent + => WrapLedgerEvent (ShelleyBlock protocol ledgerera) + -> Maybe LedgerEvent toLedgerEventAllegraMary evt = case unwrapLedgerEvent evt of ShelleyLedgerEventTICK e -> handleLedgerTICKEvents e ShelleyLedgerEventBBODY e -> handleAllegraMaryLedgerBBODYEvents e @@ -149,10 +158,10 @@ handleAlonzoToBabbageLedgerBBODYEvents handleAlonzoToBabbageLedgerBBODYEvents (ShelleyInAlonzoEvent (LedgersEvent (Shelley.LedgerEvent ledgerEvent))) = handleShelleyLEDGEREvents ledgerEvent - instance ConvertLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) where toLedgerEvent = toLedgerEventConway - -- LEDGER rule is defined anew in Conway + +-- LEDGER rule is defined anew in Conway toLedgerEventConway :: WrapLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) @@ -161,14 +170,15 @@ toLedgerEventConway evt = case unwrapLedgerEvent evt of ShelleyLedgerEventTICK (TickNewEpochEvent newEpochEvent) -> handleConwayNEWEPOCHEvents newEpochEvent ShelleyLedgerEventTICK (TickRupdEvent rewardUpdate) -> handleLedgerRUPDEvents rewardUpdate - ShelleyLedgerEventBBODY (ShelleyInAlonzoEvent (LedgersEvent (Shelley.LedgerEvent conwayLedgerEvent))) -> - case conwayLedgerEvent of - Conway.UtxowEvent{} -> Nothing - Conway.CertsEvent{} -> Nothing - Conway.GovEvent govEvent -> - case govEvent of - Conway.GovNewProposals txid props -> - Just $ NewGovernanceProposals txid (AnyProposals props) + ShelleyLedgerEventBBODY + (ShelleyInAlonzoEvent (LedgersEvent (Shelley.LedgerEvent conwayLedgerEvent))) -> + case conwayLedgerEvent of + Conway.UtxowEvent {} -> Nothing + Conway.CertsEvent {} -> Nothing + Conway.GovEvent govEvent -> + case govEvent of + Conway.GovNewProposals txid props -> + Just $ NewGovernanceProposals txid (AnyProposals props) instance ConvertLedgerEvent (HardForkBlock (Consensus.CardanoEras StandardCrypto)) where toLedgerEvent wrappedLedgerEvent = @@ -180,40 +190,41 @@ instance ConvertLedgerEvent (HardForkBlock (Consensus.CardanoEras StandardCrypto BabbageLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent ConwayLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent -{-# COMPLETE ShelleyLedgerEvent, - AllegraLedgerEvent, - MaryLedgerEvent, - AlonzoLedgerEvent, - BabbageLedgerEvent, - ConwayLedgerEvent #-} - +{-# COMPLETE + ShelleyLedgerEvent + , AllegraLedgerEvent + , MaryLedgerEvent + , AlonzoLedgerEvent + , BabbageLedgerEvent + , ConwayLedgerEvent + #-} pattern ShelleyLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern ShelleyLedgerEvent x = S (Z x) +pattern ShelleyLedgerEvent x = S (Z x) pattern AllegraLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AllegraEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern AllegraLedgerEvent x = S (S (Z x)) +pattern AllegraLedgerEvent x = S (S (Z x)) pattern MaryLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (MaryEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern MaryLedgerEvent x = S (S (S (Z x))) +pattern MaryLedgerEvent x = S (S (S (Z x))) pattern AlonzoLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AlonzoEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern AlonzoLedgerEvent x = S (S (S (S (Z x)))) +pattern AlonzoLedgerEvent x = S (S (S (S (Z x)))) pattern BabbageLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (BabbageEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern BabbageLedgerEvent x = S (S (S (S (S (Z x))))) +pattern BabbageLedgerEvent x = S (S (S (S (S (Z x))))) pattern ConwayLedgerEvent :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (ConwayEra StandardCrypto)) -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern ConwayLedgerEvent x = S (S (S (S (S (S (Z x)))))) +pattern ConwayLedgerEvent x = S (S (S (S (S (S (Z x)))))) diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs index 2234c6b2bb..eebc98a18c 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs @@ -5,34 +5,32 @@ {-# LANGUAGE StandaloneDeriving #-} module Cardano.Api.LedgerEvents.LedgerEvent - ( LedgerEvent(..) - , AnyProposals(..) - , AnyRatificationState(..) - , MIRDistributionDetails(..) - , PoolReapDetails(..) + ( LedgerEvent (..) + , AnyProposals (..) + , AnyRatificationState (..) + , MIRDistributionDetails (..) + , PoolReapDetails (..) , convertRetiredPoolsMap - ) where - -import Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential) -import Cardano.Api.Block (EpochNo) -import Cardano.Api.Keys.Shelley (Hash (..), StakePoolKey) + ) +where +import Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential) +import Cardano.Api.Block (EpochNo) +import Cardano.Api.Keys.Shelley (Hash (..), StakePoolKey) import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Conway.Governance as Ledger import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Ledger -import Cardano.Ledger.Plutus.Evaluate (PlutusWithContext) -import Cardano.Ledger.Shelley.Rewards (Reward) +import Cardano.Ledger.Plutus.Evaluate (PlutusWithContext) +import Cardano.Ledger.Shelley.Rewards (Reward) import qualified Cardano.Ledger.TxIn as Ledger - -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Set (Set) - +import Data.Set (Set) data AnyProposals = forall era. Ledger.Core.EraPParams era => AnyProposals (Ledger.Proposals era) @@ -40,7 +38,7 @@ data AnyProposals deriving instance Show AnyProposals data AnyRatificationState - = forall era. Ledger.Core.EraPParams era => AnyRatificationState (Ledger.RatifyState era) + = forall era. Ledger.Core.EraPParams era => AnyRatificationState (Ledger.RatifyState era) deriving instance Show AnyRatificationState @@ -57,22 +55,20 @@ data LedgerEvent MIRDistribution MIRDistributionDetails | -- | Pools have been reaped and deposits refunded. PoolReap PoolReapDetails - -- | A number of succeeded Plutus script evaluations. - | SuccessfulPlutusScript (NonEmpty (PlutusWithContext StandardCrypto)) - -- | A number of failed Plutus script evaluations. - | FailedPlutusScript (NonEmpty (PlutusWithContext StandardCrypto)) + | -- | A number of succeeded Plutus script evaluations. + SuccessfulPlutusScript (NonEmpty (PlutusWithContext StandardCrypto)) + | -- | A number of failed Plutus script evaluations. + FailedPlutusScript (NonEmpty (PlutusWithContext StandardCrypto)) + | -- Only events available on the Conway Era. + -- TODO: Update the above constructors to work in the conway era. + -- See toLedgerEventConway - - -- Only events available on the Conway Era. - -- TODO: Update the above constructors to work in the conway era. - -- See toLedgerEventConway -- | Newly submittted governance proposals in a single transaction. - | NewGovernanceProposals (Ledger.TxId StandardCrypto) AnyProposals - -- | The current state of governance matters at the epoch boundary. + NewGovernanceProposals (Ledger.TxId StandardCrypto) AnyProposals + | -- | The current state of governance matters at the epoch boundary. -- I.E the current constitution, committee, protocol parameters, etc. - | EpochBoundaryRatificationState AnyRatificationState - deriving Show - + EpochBoundaryRatificationState AnyRatificationState + deriving (Show) -------------------------------------------------------------------------------- -- Event details @@ -84,25 +80,29 @@ data LedgerEvent -- are inverse; a transfer of 100 ADA in either direction will result in a net -- movement of 0, but we include both directions for assistance in debugging. data MIRDistributionDetails = MIRDistributionDetails - { mirddReservePayouts :: Map StakeCredential L.Coin, - mirddTreasuryPayouts :: Map StakeCredential L.Coin, - mirddReservesToTreasury :: L.Coin, - mirddTreasuryToReserves :: L.Coin - } deriving Show + { mirddReservePayouts :: Map StakeCredential L.Coin + , mirddTreasuryPayouts :: Map StakeCredential L.Coin + , mirddReservesToTreasury :: L.Coin + , mirddTreasuryToReserves :: L.Coin + } + deriving (Show) data PoolReapDetails = PoolReapDetails - { prdEpochNo :: EpochNo, - -- | Refunded deposits. The pools referenced are now retired, and the - -- 'StakeCredential' accounts are credited with the deposits. - prdRefunded :: Map StakeCredential (Map (Hash StakePoolKey) L.Coin), - -- | Unclaimed deposits. The 'StakeCredential' referenced in this map is not - -- actively registered at the time of the pool reaping, and as such the - -- funds are returned to the treasury. - prdUnclaimed :: Map StakeCredential (Map (Hash StakePoolKey) L.Coin) - } deriving Show + { prdEpochNo :: EpochNo + , prdRefunded :: Map StakeCredential (Map (Hash StakePoolKey) L.Coin) + -- ^ Refunded deposits. The pools referenced are now retired, and the + -- 'StakeCredential' accounts are credited with the deposits. + , prdUnclaimed :: Map StakeCredential (Map (Hash StakePoolKey) L.Coin) + -- ^ Unclaimed deposits. The 'StakeCredential' referenced in this map is not + -- actively registered at the time of the pool reaping, and as such the + -- funds are returned to the treasury. + } + deriving (Show) convertRetiredPoolsMap - :: Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin) + :: Map + (Ledger.StakeCredential StandardCrypto) + (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin) -> Map StakeCredential (Map (Hash StakePoolKey) L.Coin) convertRetiredPoolsMap = Map.mapKeys fromShelleyStakeCredential diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/DELEGS.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/DELEGS.hs index 4ac9be4392..1e01806da4 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/DELEGS.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/DELEGS.hs @@ -3,10 +3,10 @@ module Cardano.Api.LedgerEvents.Rule.BBODY.DELEGS ( handleShelleyDELEGSEvent - ) where - -import Cardano.Api.LedgerEvents.LedgerEvent + ) +where +import Cardano.Api.LedgerEvents.LedgerEvent import qualified Cardano.Ledger.Shelley.Rules as Shelley handleShelleyDELEGSEvent :: Shelley.ShelleyDelegsEvent ledgerera -> Maybe LedgerEvent diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/LEDGER.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/LEDGER.hs index ac812c20aa..75d0bdd53c 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/LEDGER.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/LEDGER.hs @@ -6,30 +6,32 @@ module Cardano.Api.LedgerEvents.Rule.BBODY.LEDGER ( LatestBBodyEventConstraints , handleShelleyLEDGEREvents - ) where + ) +where -import Cardano.Api.LedgerEvents.LedgerEvent -import Cardano.Api.LedgerEvents.Rule.BBODY.DELEGS -import Cardano.Api.LedgerEvents.Rule.BBODY.UTXOW - -import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoEvent (..), AlonzoUtxosEvent (..), - AlonzoUtxowEvent (..)) +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.BBODY.DELEGS +import Cardano.Api.LedgerEvents.Rule.BBODY.UTXOW +import Cardano.Ledger.Alonzo.Rules + ( AlonzoUtxoEvent (..) + , AlonzoUtxosEvent (..) + , AlonzoUtxowEvent (..) + ) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.Shelley.Rules as Shelley - -import Control.State.Transition.Extended +import Control.State.Transition.Extended type LatestBBodyEventConstraints ledgerera = - ( Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ Alonzo.AlonzoBbodyEvent ledgerera - , Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera - , Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera - , Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera - , Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera - , Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera - , Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera - ) + ( Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ Alonzo.AlonzoBbodyEvent ledgerera + , Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + , Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + , Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + , Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera + , Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera + , Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + ) handleShelleyLEDGEREvents :: Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera @@ -40,5 +42,5 @@ handleShelleyLEDGEREvents => Shelley.ShelleyLedgerEvent ledgerera -> Maybe LedgerEvent handleShelleyLEDGEREvents ledgerEvent = case ledgerEvent of - Shelley.UtxowEvent e -> handleAlonzoOnwardsUTxOWEvent e - Shelley.DelegsEvent e -> handleShelleyDELEGSEvent e + Shelley.UtxowEvent e -> handleAlonzoOnwardsUTxOWEvent e + Shelley.DelegsEvent e -> handleShelleyDELEGSEvent e diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs index ef32c9ad8e..6e69ab70da 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs @@ -6,21 +6,21 @@ module Cardano.Api.LedgerEvents.Rule.BBODY.UTXOW ( handleAlonzoOnwardsUTxOWEvent , handleAllegraMaryUTxOWEvent , handlePreAlonzoUTxOWEvent - ) where - -import Cardano.Api.LedgerEvents.LedgerEvent + ) +where +import Cardano.Api.LedgerEvents.LedgerEvent import qualified Cardano.Ledger.Allegra.Rules as Allegra -import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoEvent (..), AlonzoUtxosEvent (..), - AlonzoUtxowEvent (..)) +import Cardano.Ledger.Alonzo.Rules + ( AlonzoUtxoEvent (..) + , AlonzoUtxosEvent (..) + , AlonzoUtxowEvent (..) + ) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.Shelley.Rules as Shelley - -import Control.State.Transition.Extended - - +import Control.State.Transition.Extended handleAlonzoOnwardsUTxOWEvent :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera @@ -29,11 +29,11 @@ handleAlonzoOnwardsUTxOWEvent => AlonzoUtxowEvent ledgerera -> Maybe LedgerEvent handleAlonzoOnwardsUTxOWEvent (WrappedShelleyEraEvent (Shelley.UtxoEvent (UtxosEvent utxoEvent))) = case utxoEvent of - Alonzo.AlonzoPpupToUtxosEvent{} -> Nothing - Alonzo.TotalDeposits{} -> Nothing - Alonzo.SuccessfulPlutusScriptsEvent e -> Just $ SuccessfulPlutusScript e - Alonzo.FailedPlutusScriptsEvent e -> Just $ FailedPlutusScript e - Alonzo.TxUTxODiff _ _ -> Nothing + Alonzo.AlonzoPpupToUtxosEvent {} -> Nothing + Alonzo.TotalDeposits {} -> Nothing + Alonzo.SuccessfulPlutusScriptsEvent e -> Just $ SuccessfulPlutusScript e + Alonzo.FailedPlutusScriptsEvent e -> Just $ FailedPlutusScript e + Alonzo.TxUTxODiff _ _ -> Nothing handlePreAlonzoUTxOWEvent :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Shelley.UtxoEvent ledgerera @@ -41,17 +41,16 @@ handlePreAlonzoUTxOWEvent => Shelley.ShelleyUtxowEvent ledgerera -> Maybe LedgerEvent handlePreAlonzoUTxOWEvent (Shelley.UtxoEvent e) = case e of - Shelley.TotalDeposits{} -> Nothing + Shelley.TotalDeposits {} -> Nothing Shelley.UpdateEvent (Shelley.PpupNewEpoch _) -> Nothing Shelley.TxUTxODiff _ _ -> Nothing - handleAllegraMaryUTxOWEvent :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Allegra.AllegraUtxoEvent ledgerera => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera => Shelley.ShelleyUtxowEvent ledgerera -> Maybe LedgerEvent handleAllegraMaryUTxOWEvent (Shelley.UtxoEvent e) = case e of - Allegra.TotalDeposits{} -> Nothing + Allegra.TotalDeposits {} -> Nothing Allegra.UpdateEvent (Shelley.PpupNewEpoch _) -> Nothing Allegra.TxUTxODiff _ _ -> Nothing diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/NEWEPOCH.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/NEWEPOCH.hs index b8c8fcf085..1eaa12096e 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/NEWEPOCH.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/NEWEPOCH.hs @@ -9,19 +9,18 @@ module Cardano.Api.LedgerEvents.Rule.TICK.NEWEPOCH , handleShelleyNEWEPOCHEvents , handleLedgerTICKEvents , handleConwayNEWEPOCHEvents - ) where - -import Cardano.Api.Address (fromShelleyStakeCredential) -import Cardano.Api.LedgerEvents.LedgerEvent -import Cardano.Api.LedgerEvents.Rule.TICK.RUPD -import Cardano.Api.ReexposeLedger + ) +where -import Cardano.Ledger.Conway.Rules (ConwayNewEpochEvent) +import Cardano.Api.Address (fromShelleyStakeCredential) +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.TICK.RUPD +import Cardano.Api.ReexposeLedger +import Cardano.Ledger.Conway.Rules (ConwayNewEpochEvent) import qualified Cardano.Ledger.Conway.Rules as Conway import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Shelley.Rules +import Cardano.Ledger.Shelley.Rules import qualified Cardano.Ledger.Shelley.Rules as Shelley - import qualified Data.Map.Strict as Map type LatestTickEventConstraints ledgerera = @@ -46,13 +45,13 @@ handleShelleyNEWEPOCHEvents => ShelleyNewEpochEvent ledgerera -> Maybe LedgerEvent handleShelleyNEWEPOCHEvents shelleyNewEpochEvent = case shelleyNewEpochEvent of - Shelley.DeltaRewardEvent{} -> Nothing - Shelley.RestrainedRewards{} -> Nothing + Shelley.DeltaRewardEvent {} -> Nothing + Shelley.RestrainedRewards {} -> Nothing Shelley.TotalRewardEvent epochNo rewardsMap -> Just $ RewardsDistribution epochNo (Map.mapKeys fromShelleyStakeCredential rewardsMap) Shelley.EpochEvent e -> handleEpochEvents e - Shelley.MirEvent{} -> Nothing -- We no longer care about MIR events - Shelley.TotalAdaPotsEvent{} -> Nothing + Shelley.MirEvent {} -> Nothing -- We no longer care about MIR events + Shelley.TotalAdaPotsEvent {} -> Nothing handleEpochEvents :: EraCrypto ledgerera ~ StandardCrypto @@ -61,13 +60,13 @@ handleEpochEvents handleEpochEvents (PoolReapEvent e) = case e of RetiredPools {refundPools, unclaimedPools, epochNo} -> - Just . PoolReap - $ PoolReapDetails epochNo - (convertRetiredPoolsMap refundPools) - (convertRetiredPoolsMap unclaimedPools) -handleEpochEvents (SnapEvent{}) = Nothing -handleEpochEvents (UpecEvent{}) = Nothing - + Just . PoolReap $ + PoolReapDetails + epochNo + (convertRetiredPoolsMap refundPools) + (convertRetiredPoolsMap unclaimedPools) +handleEpochEvents (SnapEvent {}) = Nothing +handleEpochEvents (UpecEvent {}) = Nothing handleConwayNEWEPOCHEvents :: EraCrypto ledgerera ~ StandardCrypto @@ -82,7 +81,7 @@ handleConwayNEWEPOCHEvents conwayNewEpochEvent = case rewardUpdate of RupdEvent epochNum rewards -> Just $ IncrementalRewardsDistribution epochNum (Map.mapKeys fromShelleyStakeCredential rewards) - Conway.RestrainedRewards{} -> Nothing + Conway.RestrainedRewards {} -> Nothing Conway.TotalRewardEvent epochNo rewardsMap -> Just $ RewardsDistribution epochNo (Map.mapKeys fromShelleyStakeCredential rewardsMap) Conway.EpochEvent epochEvent -> @@ -92,10 +91,11 @@ handleConwayNEWEPOCHEvents conwayNewEpochEvent = Conway.PoolReapEvent poolReap -> case poolReap of RetiredPools {refundPools, unclaimedPools, epochNo} -> - Just . PoolReap $ PoolReapDetails epochNo - (convertRetiredPoolsMap refundPools) - (convertRetiredPoolsMap unclaimedPools) + Just . PoolReap $ + PoolReapDetails + epochNo + (convertRetiredPoolsMap refundPools) + (convertRetiredPoolsMap unclaimedPools) Conway.SnapEvent _ -> Nothing Conway.GovInfoEvent {} -> Nothing - Conway.TotalAdaPotsEvent _ -> Nothing diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/RUPD.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/RUPD.hs index e621bc4c04..23b2ac02f6 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/RUPD.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/TICK/RUPD.hs @@ -1,17 +1,14 @@ module Cardano.Api.LedgerEvents.Rule.TICK.RUPD ( handleLedgerRUPDEvents - ) where - -import Cardano.Api.Address (fromShelleyStakeCredential) -import Cardano.Api.LedgerEvents.LedgerEvent (LedgerEvent (IncrementalRewardsDistribution)) - -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Shelley.Rules + ) +where +import Cardano.Api.Address (fromShelleyStakeCredential) +import Cardano.Api.LedgerEvents.LedgerEvent (LedgerEvent (IncrementalRewardsDistribution)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.Rules import qualified Data.Map.Strict as Map - handleLedgerRUPDEvents :: RupdEvent StandardCrypto -> Maybe LedgerEvent handleLedgerRUPDEvents (RupdEvent epochNum rewards) = Just $ IncrementalRewardsDistribution epochNum (Map.mapKeys fromShelleyStakeCredential rewards) - diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 4ea2f5d5bd..fcfff007aa 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -17,136 +17,198 @@ module Cardano.Api.LedgerState ( -- * Initialization / Accumulation envSecurityParam , LedgerState - ( .. - , LedgerStateByron - , LedgerStateShelley - , LedgerStateAllegra - , LedgerStateMary - , LedgerStateAlonzo - , LedgerStateBabbage - , LedgerStateConway - ) - + ( .. + , LedgerStateByron + , LedgerStateShelley + , LedgerStateAllegra + , LedgerStateMary + , LedgerStateAlonzo + , LedgerStateBabbage + , LedgerStateConway + ) , encodeLedgerState , decodeLedgerState , initialLedgerState , applyBlock - , ValidationMode(..) + , ValidationMode (..) , applyBlockWithEvents - , AnyNewEpochState(..) + , AnyNewEpochState (..) , getAnyNewEpochState -- * Traversing the block chain , foldBlocks - , FoldStatus(..) + , FoldStatus (..) , chainSyncClientWithLedgerState , chainSyncClientPipelinedWithLedgerState - -- * Ledger state conditions - , ConditionResult(..) + -- * Ledger state conditions + , ConditionResult (..) , fromConditionResult , toConditionResult , foldEpochState - -- * Errors - , LedgerStateError(..) - , FoldBlocksError(..) - , GenesisConfigError(..) - , InitialLedgerStateError(..) + -- * Errors + , LedgerStateError (..) + , FoldBlocksError (..) + , GenesisConfigError (..) + , InitialLedgerStateError (..) - -- * Leadership schedule - , LeadershipError(..) + -- * Leadership schedule + , LeadershipError (..) , constructGlobals , currentEpochEligibleLeadershipSlots , nextEpochEligibleLeadershipSlots - -- * Node Config - , NodeConfig(..) - -- ** Network Config + + -- * Node Config + , NodeConfig (..) + + -- ** Network Config , NodeConfigFile , readNodeConfig - -- ** Genesis Config + + -- ** Genesis Config , GenesisConfig (..) , readCardanoGenesisConfig , mkProtocolInfoCardano - -- *** Byron Genesis Config + + -- *** Byron Genesis Config , readByronGenesisConfig - -- *** Shelley Genesis Config + + -- *** Shelley Genesis Config , ShelleyConfig (..) , GenesisHashShelley (..) , readShelleyGenesisConfig , shelleyPraosNonce - -- *** Alonzo Genesis Config + + -- *** Alonzo Genesis Config , GenesisHashAlonzo (..) , readAlonzoGenesisConfig - -- *** Conway Genesis Config + + -- *** Conway Genesis Config , GenesisHashConway (..) , readConwayGenesisConfig - -- ** Environment - , Env(..) - , genesisConfigToEnv + -- ** Environment + , Env (..) + , genesisConfigToEnv ) - where -import Cardano.Api.Block -import Cardano.Api.Certificate -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core (forEraMaybeEon) -import Cardano.Api.Error as Api -import Cardano.Api.Genesis -import Cardano.Api.IO -import Cardano.Api.IPC (ConsensusModeParams (..), - LocalChainSyncClient (LocalChainSyncClientPipelined), - LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode, - LocalNodeConnectInfo (..), connectToLocalNode) -import Cardano.Api.Keys.Praos -import Cardano.Api.LedgerEvents.ConvertLedgerEvent -import Cardano.Api.LedgerEvents.LedgerEvent -import Cardano.Api.Modes (EpochSlots (..)) +where + +import Cardano.Api.Block +import Cardano.Api.Certificate +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core (forEraMaybeEon) +import Cardano.Api.Error as Api +import Cardano.Api.Genesis +import Cardano.Api.IO +import Cardano.Api.IPC + ( ConsensusModeParams (..) + , LocalChainSyncClient (LocalChainSyncClientPipelined) + , LocalNodeClientProtocols (..) + , LocalNodeClientProtocolsInMode + , LocalNodeConnectInfo (..) + , connectToLocalNode + ) +import Cardano.Api.Keys.Praos +import Cardano.Api.LedgerEvents.ConvertLedgerEvent +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.Modes (EpochSlots (..)) import qualified Cardano.Api.Modes as Api -import Cardano.Api.Monad.Error -import Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic)) -import Cardano.Api.Pretty -import Cardano.Api.Query (CurrentEpochState (..), PoolDistribution (unPoolDistr), - ProtocolState, SerialisedCurrentEpochState (..), SerialisedPoolDistribution, - decodeCurrentEpochState, decodePoolDistribution, decodeProtocolState) +import Cardano.Api.Monad.Error +import Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic)) +import Cardano.Api.Pretty +import Cardano.Api.Query + ( CurrentEpochState (..) + , PoolDistribution (unPoolDistr) + , ProtocolState + , SerialisedCurrentEpochState (..) + , SerialisedPoolDistribution + , decodeCurrentEpochState + , decodePoolDistribution + , decodeProtocolState + ) import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.SpecialByron as Byron -import Cardano.Api.Utils (textShow) - +import Cardano.Api.SpecialByron as Byron +import Cardano.Api.Utils (textShow) import qualified Cardano.Binary as CBOR import qualified Cardano.Chain.Genesis import qualified Cardano.Chain.Update -import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..)) +import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..)) import qualified Cardano.Crypto.Hash.Blake2b import qualified Cardano.Crypto.Hash.Class import qualified Cardano.Crypto.Hashing import qualified Cardano.Crypto.ProtocolMagic import qualified Cardano.Crypto.VRF as Crypto import qualified Cardano.Crypto.VRF.Class as VRF -import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) +import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) import qualified Cardano.Ledger.Api.Era as Ledger import qualified Cardano.Ledger.Api.Transition as Ledger -import Cardano.Ledger.BaseTypes (Globals (..), Nonce, ProtVer (..), natVersion, (⭒)) -import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.Binary (DecoderError) +import Cardano.Ledger.BaseTypes (Globals (..), Nonce, ProtVer (..), natVersion, (⭒)) +import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Binary (DecoderError) import qualified Cardano.Ledger.Coin as SL -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL import qualified Cardano.Ledger.Shelley.API as ShelleyAPI import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.Genesis as Ledger import qualified Cardano.Protocol.TPraos.API as TPraos -import Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue) +import Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue) import qualified Cardano.Protocol.TPraos.BHeader as TPraos -import Cardano.Slotting.EpochInfo (EpochInfo) +import Cardano.Slotting.EpochInfo (EpochInfo) import qualified Cardano.Slotting.EpochInfo.API as Slot -import Cardano.Slotting.Slot (WithOrigin (At, Origin)) +import Cardano.Slotting.Slot (WithOrigin (At, Origin)) import qualified Cardano.Slotting.Slot as Slot +import Control.Concurrent +import Control.DeepSeq +import Control.Error.Util (note) +import Control.Exception.Safe +import Control.Monad +import Control.Monad.State.Strict +import Data.Aeson as Aeson + ( FromJSON (parseJSON) + , Object + , eitherDecodeStrict' + , withObject + , (.:) + , (.:?) + ) +import Data.Aeson.Types (Parser) +import Data.Bifunctor +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Lazy as LB +import Data.ByteString.Short as BSS +import Data.Foldable +import Data.IORef +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Proxy (Proxy (Proxy)) +import Data.SOP.Strict.NP +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (toLazyText) +import Data.Word +import qualified Data.Yaml as Yaml +import Formatting.Buildable (build) +import Lens.Micro +import Network.TypedProtocol.Pipelined (Nat (..)) import qualified Ouroboros.Consensus.Block.Abstract as Consensus -import Ouroboros.Consensus.Block.Forging (BlockForging) +import Ouroboros.Consensus.Block.Forging (BlockForging) import qualified Ouroboros.Consensus.Byron.Ledger as Byron import qualified Ouroboros.Consensus.Cardano as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus @@ -160,70 +222,30 @@ import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger import qualified Ouroboros.Consensus.Ledger.Extended as Ledger import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus -import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus -import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) +import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) import qualified Ouroboros.Consensus.Shelley.HFEras as Shelley import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley import qualified Ouroboros.Consensus.Shelley.Ledger.Query.Types as Consensus -import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent)) -import Ouroboros.Network.Block (blockNo) +import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent)) +import Ouroboros.Network.Block (blockNo) import qualified Ouroboros.Network.Block -import Ouroboros.Network.Mux (MuxError) +import Ouroboros.Network.Mux (MuxError) import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP -import Ouroboros.Network.Protocol.ChainSync.PipelineDecision - -import Control.Concurrent -import Control.DeepSeq -import Control.Error.Util (note) -import Control.Exception.Safe -import Control.Monad -import Control.Monad.State.Strict -import Data.Aeson as Aeson (FromJSON (parseJSON), Object, eitherDecodeStrict', withObject, - (.:), (.:?)) -import Data.Aeson.Types (Parser) -import Data.Bifunctor -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteArray -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Lazy as LB -import Data.ByteString.Short as BSS -import Data.Foldable -import Data.IORef -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Proxy (Proxy (Proxy)) -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import Data.Set (Set) -import qualified Data.Set as Set -import Data.SOP.Strict.NP -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (toLazyText) -import Data.Word -import qualified Data.Yaml as Yaml -import Formatting.Buildable (build) -import Lens.Micro -import Network.TypedProtocol.Pipelined (Nat (..)) -import System.FilePath +import Ouroboros.Network.Protocol.ChainSync.PipelineDecision +import System.FilePath data InitialLedgerStateError - = ILSEConfigFile Text - -- ^ Failed to read or parse the network config file. - | ILSEGenesisFile GenesisConfigError - -- ^ Failed to read or parse a genesis file linked from the network config file. - | ILSELedgerConsensusConfig GenesisConfigError - -- ^ Failed to derive the Ledger or Consensus config. - deriving Show + = -- | Failed to read or parse the network config file. + ILSEConfigFile Text + | -- | Failed to read or parse a genesis file linked from the network config file. + ILSEGenesisFile GenesisConfigError + | -- | Failed to derive the Ledger or Consensus config. + ILSELedgerConsensusConfig GenesisConfigError + deriving (Show) instance Exception InitialLedgerStateError @@ -237,19 +259,21 @@ instance Error InitialLedgerStateError where "Failed to derive the Ledger or Consensus config:" <+> prettyError err data LedgerStateError - = ApplyBlockHashMismatch Text - -- ^ When using QuickValidation, the block hash did not match the expected - -- block hash after applying a new block to the current ledger state. - | ApplyBlockError (Consensus.CardanoLedgerError Consensus.StandardCrypto) - -- ^ When using FullValidation, an error occurred when applying a new block - -- to the current ledger state. - | InvalidRollback - -- ^ Encountered a rollback larger than the security parameter. - SlotNo -- ^ Oldest known slot number that we can roll back to. - ChainPoint -- ^ Rollback was attempted to this point. - | TerminationEpochReached EpochNo - -- ^ The ledger state condition you were interested in was not met - -- prior to the termination epoch. + = -- | When using QuickValidation, the block hash did not match the expected + -- block hash after applying a new block to the current ledger state. + ApplyBlockHashMismatch Text + | -- | When using FullValidation, an error occurred when applying a new block + -- to the current ledger state. + ApplyBlockError (Consensus.CardanoLedgerError Consensus.StandardCrypto) + | -- | Encountered a rollback larger than the security parameter. + InvalidRollback + SlotNo + -- ^ Oldest known slot number that we can roll back to. + ChainPoint + -- ^ Rollback was attempted to this point. + | -- | The ledger state condition you were interested in was not met + -- prior to the termination epoch. + TerminationEpochReached EpochNo | UnexpectedLedgerState AnyShelleyBasedEra -- ^ Expected era @@ -267,20 +291,22 @@ instance Error LedgerStateError where ApplyBlockHashMismatch err -> "Applying a block did not result in the expected block hash:" <+> pretty err ApplyBlockError hardForkLedgerError -> "Applying a block resulted in an error:" <+> pshow hardForkLedgerError InvalidRollback oldestSupported rollbackPoint -> - "Encountered a rollback larger than the security parameter. Attempted to roll back to" + "Encountered a rollback larger than the security parameter. Attempted to roll back to" <+> pshow rollbackPoint <> ", but oldest supported slot is" - <+> pshow oldestSupported - TerminationEpochReached epochNo -> mconcat - [ "The ledger state condition you were interested in was not met " - , "prior to the termination epoch:" <+> pshow epochNo - ] + <+> pshow oldestSupported + TerminationEpochReached epochNo -> + mconcat + [ "The ledger state condition you were interested in was not met " + , "prior to the termination epoch:" <+> pshow epochNo + ] UnexpectedLedgerState expectedEra unexpectedLS -> - mconcat [ "Expected ledger state from the " - , pshow expectedEra - , " era, but got " - , pshow unexpectedLS - ] + mconcat + [ "Expected ledger state from the " + , pshow expectedEra + , " era, but got " + , pshow unexpectedLS + ] ByronEraUnsupported -> "Byron era is not supported" -- | Get the environment and initial ledger state. @@ -311,8 +337,8 @@ applyBlock -- ^ Some block to apply -> Either LedgerStateError (LedgerState, [LedgerEvent]) -- ^ The new ledger state (or an error). -applyBlock env oldState validationMode - = applyBlock' env oldState validationMode . toConsensusBlock +applyBlock env oldState validationMode = + applyBlock' env oldState validationMode . toConsensusBlock pattern LedgerStateByron :: Ledger.LedgerState Byron.ByronBlock @@ -349,20 +375,22 @@ pattern LedgerStateConway -> LedgerState pattern LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st) -{-# COMPLETE LedgerStateByron - , LedgerStateShelley - , LedgerStateAllegra - , LedgerStateMary - , LedgerStateAlonzo - , LedgerStateBabbage - , LedgerStateConway #-} +{-# COMPLETE + LedgerStateByron + , LedgerStateShelley + , LedgerStateAllegra + , LedgerStateMary + , LedgerStateAlonzo + , LedgerStateBabbage + , LedgerStateConway + #-} data FoldBlocksError = FoldBlocksInitialLedgerStateError !InitialLedgerStateError | FoldBlocksApplyBlockError !LedgerStateError | FoldBlocksIOException !IOException | FoldBlocksMuxError !MuxError - deriving Show + deriving (Show) instance Error FoldBlocksError where prettyError = \case @@ -382,7 +410,8 @@ data FoldStatus -- | Monadic fold over all blocks and ledger states. Stopping @k@ blocks before -- the node's tip where @k@ is the security parameter. foldBlocks - :: forall a t m. () + :: forall a t m + . () => Show a => MonadIOTransError FoldBlocksError t m => NodeConfigFile 'In @@ -419,7 +448,8 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = hand -- * Non-pipelined: 1h 0m 19s -- * Pipelined: 46m 23s - (env, ledgerState) <- modifyError FoldBlocksInitialLedgerStateError $ initialLedgerState nodeConfigFilePath + (env, ledgerState) <- + modifyError FoldBlocksInitialLedgerStateError $ initialLedgerState nodeConfigFilePath -- Place to store the accumulated state -- This is a bit ugly, but easy. @@ -428,17 +458,17 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = hand -- Derive the NetworkId as described in network-magic.md from the -- cardano-ledger-specs repo. - let byronConfig - = (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* _) -> bc) - . HFC.getPerEraLedgerConfig - . HFC.hardForkLedgerConfigPerEra - $ envLedgerConfig env - - networkMagic - = NetworkMagic - $ unProtocolMagicId - $ Cardano.Chain.Genesis.gdProtocolMagicId - $ Cardano.Chain.Genesis.configGenesisData byronConfig + let byronConfig = + (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* _) -> bc) + . HFC.getPerEraLedgerConfig + . HFC.hardForkLedgerConfigPerEra + $ envLedgerConfig env + + networkMagic = + NetworkMagic $ + unProtocolMagicId $ + Cardano.Chain.Genesis.gdProtocolMagicId $ + Cardano.Chain.Genesis.configGenesisData byronConfig networkId' = case Cardano.Chain.Genesis.configReqNetMagic byronConfig of RequiresNoMagic -> Mainnet @@ -447,369 +477,485 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = hand cardanoModeParams = CardanoModeParams . EpochSlots $ 10 * envSecurityParam env -- Connect to the node. - let connectInfo = LocalNodeConnectInfo - { localConsensusModeParams = cardanoModeParams - , localNodeNetworkId = networkId' - , localNodeSocketPath = socketPath - } - - liftIO $ connectToLocalNode - connectInfo - (protocols stateIORef errorIORef env ledgerState) + let connectInfo = + LocalNodeConnectInfo + { localConsensusModeParams = cardanoModeParams + , localNodeNetworkId = networkId' + , localNodeSocketPath = socketPath + } + + liftIO $ + connectToLocalNode + connectInfo + (protocols stateIORef errorIORef env ledgerState) liftIO (readIORef errorIORef) >>= \case Just err -> throwError (FoldBlocksApplyBlockError err) Nothing -> liftIO $ readIORef stateIORef - where - protocols :: () - => IORef a - -> IORef (Maybe LedgerStateError) - -> Env - -> LedgerState - -> LocalNodeClientProtocolsInMode - protocols stateIORef errorIORef env ledgerState = - LocalNodeClientProtocols { - localChainSyncClient = LocalChainSyncClientPipelined (chainSyncClient 50 stateIORef errorIORef env ledgerState), - localTxSubmissionClient = Nothing, - localStateQueryClient = Nothing, - localTxMonitoringClient = Nothing + where + protocols + :: () + => IORef a + -> IORef (Maybe LedgerStateError) + -> Env + -> LedgerState + -> LocalNodeClientProtocolsInMode + protocols stateIORef errorIORef env ledgerState = + LocalNodeClientProtocols + { localChainSyncClient = + LocalChainSyncClientPipelined (chainSyncClient 50 stateIORef errorIORef env ledgerState) + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } + + -- \| Defines the client side of the chain sync protocol. + chainSyncClient + :: Word16 + -- \^ The maximum number of concurrent requests. + -> IORef a + -- \^ State accumulator. Written to on every block. + -> IORef (Maybe LedgerStateError) + -- \^ Resulting error if any. Written to once on protocol + -- completion. + -> Env + -> LedgerState + -> CSP.ChainSyncClientPipelined + BlockInMode + ChainPoint + ChainTip + IO + () + -- \^ Client returns maybe an error. + chainSyncClient pipelineSize stateIORef errorIORef env ledgerState0 = + CSP.ChainSyncClientPipelined $ + pure $ + clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory + where + initialLedgerStateHistory = Seq.singleton (0, (ledgerState0, []), Origin) + + clientIdle_RequestMoreN + :: WithOrigin BlockNo + -> WithOrigin BlockNo + -> Nat n -- Number of requests inflight. + -> LedgerStateHistory + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () + clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates = + case pipelineDecisionMax pipelineSize n clientTip serverTip of + Collect -> case n of + Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) + _ -> + CSP.SendMsgRequestNextPipelined + (pure ()) + (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) + + clientNextN + :: Nat n -- Number of requests inflight. + -> LedgerStateHistory + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () + clientNextN n knownLedgerStates = + CSP.ClientStNext + { CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do + let newLedgerStateE = + applyBlock + env + ( maybe + (error "Impossible! Missing Ledger state") + (\(_, (ledgerState, _), _) -> ledgerState) + (Seq.lookup 0 knownLedgerStates) + ) + validationMode + blockInMode + case newLedgerStateE of + Left err -> clientIdle_DoneNwithMaybeError n (Just err) + Right newLedgerState -> do + let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode + newClientTip = At currBlockNo + newServerTip = fromChainTip serverChainTip + + ledgerStateSingleFold + :: (SlotNo, (LedgerState, [LedgerEvent]), WithOrigin BlockInMode) -- Ledger events for a single block + -> IO FoldStatus + ledgerStateSingleFold (_, _, Origin) = return ContinueFold + ledgerStateSingleFold (_, (ledgerState, ledgerEvents), At currBlock) = do + accumulatorState <- readIORef stateIORef + (newState, foldStatus) <- + accumulate + env + ledgerState + ledgerEvents + currBlock + accumulatorState + atomicWriteIORef stateIORef newState + return foldStatus + + ledgerStateRecurser + :: Seq (SlotNo, LedgerStateEvents, WithOrigin BlockInMode) -- Ledger events for multiple blocks + -> IO FoldStatus + ledgerStateRecurser states = go (toList states) ContinueFold + where + go [] foldStatus = return foldStatus + go (s : rest) ContinueFold = do + newFoldStatus <- ledgerStateSingleFold s + go rest newFoldStatus + go _ StopFold = go [] StopFold + go _ DebugFold = go [] DebugFold + + -- NB: knownLedgerStates' is the new ledger state history i.e k blocks from the tip + -- or also known as the mutable blocks. We default to using the mutable blocks. + finalFoldStatus <- ledgerStateRecurser knownLedgerStates' + + case finalFoldStatus of + StopFold -> + -- We return StopFold in our accumulate function if we want to terminate the fold. + -- This allow us to check for a specific condition in our accumulate function + -- and then terminate e.g a specific stake pool was registered + let noError = Nothing + in clientIdle_DoneNwithMaybeError n noError + DebugFold -> do + currentIORefState <- readIORef stateIORef + + -- Useful for debugging: + let !ioRefErr = + DebugError . force $ + unlines + [ "newClientTip: " <> show newClientTip + , "newServerTip: " <> show newServerTip + , "newLedgerState: " <> show (snd newLedgerState) + , "knownLedgerStates: " <> show (extractHistory knownLedgerStates) + , "committedStates: " <> show (extractHistory committedStates) + , "numberOfRequestsInFlight: " <> show n + , "k: " <> show (envSecurityParam env) + , "Current IORef State: " <> show currentIORefState + ] + clientIdle_DoneNwithMaybeError n $ Just ioRefErr + ContinueFold -> return $ clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates' + , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do + let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. + newServerTip = fromChainTip serverChainTip + truncatedKnownLedgerStates = case chainPoint of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo + return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates) } - -- | Defines the client side of the chain sync protocol. - chainSyncClient :: Word16 - -- ^ The maximum number of concurrent requests. - -> IORef a - -- ^ State accumulator. Written to on every block. - -> IORef (Maybe LedgerStateError) - -- ^ Resulting error if any. Written to once on protocol - -- completion. - -> Env - -> LedgerState - -> CSP.ChainSyncClientPipelined - BlockInMode - ChainPoint - ChainTip - IO () - -- ^ Client returns maybe an error. - chainSyncClient pipelineSize stateIORef errorIORef env ledgerState0 - = CSP.ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory - where - initialLedgerStateHistory = Seq.singleton (0, (ledgerState0, []), Origin) - - clientIdle_RequestMoreN - :: WithOrigin BlockNo - -> WithOrigin BlockNo - -> Nat n -- Number of requests inflight. - -> LedgerStateHistory - -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () - clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates - = case pipelineDecisionMax pipelineSize n clientTip serverTip of - Collect -> case n of - Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) - _ -> CSP.SendMsgRequestNextPipelined (pure ()) (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) - - clientNextN - :: Nat n -- Number of requests inflight. - -> LedgerStateHistory - -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () - clientNextN n knownLedgerStates = - CSP.ClientStNext { - CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do - let newLedgerStateE = applyBlock - env - (maybe - (error "Impossible! Missing Ledger state") - (\(_,(ledgerState, _),_) -> ledgerState) - (Seq.lookup 0 knownLedgerStates) - ) - validationMode - blockInMode - case newLedgerStateE of - Left err -> clientIdle_DoneNwithMaybeError n (Just err) - Right newLedgerState -> do - let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode - newClientTip = At currBlockNo - newServerTip = fromChainTip serverChainTip - - ledgerStateSingleFold - :: (SlotNo, (LedgerState, [LedgerEvent]), WithOrigin BlockInMode) -- Ledger events for a single block - -> IO FoldStatus - ledgerStateSingleFold (_, _, Origin) = return ContinueFold - ledgerStateSingleFold (_, (ledgerState, ledgerEvents), At currBlock) = do - accumulatorState <- readIORef stateIORef - (newState, foldStatus) <- accumulate - env - ledgerState - ledgerEvents - currBlock - accumulatorState - atomicWriteIORef stateIORef newState - return foldStatus - - ledgerStateRecurser - :: Seq (SlotNo, LedgerStateEvents, WithOrigin BlockInMode) -- Ledger events for multiple blocks - -> IO FoldStatus - ledgerStateRecurser states = go (toList states) ContinueFold - where - go [] foldStatus = return foldStatus - go (s : rest) ContinueFold = do - newFoldStatus <- ledgerStateSingleFold s - go rest newFoldStatus - go _ StopFold = go [] StopFold - go _ DebugFold = go [] DebugFold - - -- NB: knownLedgerStates' is the new ledger state history i.e k blocks from the tip - -- or also known as the mutable blocks. We default to using the mutable blocks. - finalFoldStatus <- ledgerStateRecurser knownLedgerStates' - - case finalFoldStatus of - StopFold -> - -- We return StopFold in our accumulate function if we want to terminate the fold. - -- This allow us to check for a specific condition in our accumulate function - -- and then terminate e.g a specific stake pool was registered - let noError = Nothing - in clientIdle_DoneNwithMaybeError n noError - - DebugFold -> do - currentIORefState <- readIORef stateIORef - - -- Useful for debugging: - let !ioRefErr = DebugError . force - $ unlines [ "newClientTip: " <> show newClientTip - , "newServerTip: " <> show newServerTip - , "newLedgerState: " <> show (snd newLedgerState) - , "knownLedgerStates: " <> show (extractHistory knownLedgerStates) - , "committedStates: " <> show (extractHistory committedStates) - , "numberOfRequestsInFlight: " <> show n - , "k: " <> show (envSecurityParam env) - , "Current IORef State: " <> show currentIORefState - ] - clientIdle_DoneNwithMaybeError n $ Just ioRefErr - - ContinueFold -> return $ clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates' - - , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do - let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. - newServerTip = fromChainTip serverChainTip - truncatedKnownLedgerStates = case chainPoint of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo - return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates) - } - - - clientIdle_DoneNwithMaybeError - :: Nat n -- Number of requests inflight. - -> Maybe LedgerStateError -- Return value (maybe an error) - -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) - clientIdle_DoneNwithMaybeError n errorMay = case n of - Succ predN -> return (CSP.CollectResponse Nothing (clientNext_DoneNwithMaybeError predN errorMay)) -- Ignore remaining message responses - Zero -> do - writeIORef errorIORef errorMay - return (CSP.SendMsgDone ()) - - clientNext_DoneNwithMaybeError - :: Nat n -- Number of requests inflight. - -> Maybe LedgerStateError -- Return value (maybe an error) - -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () - clientNext_DoneNwithMaybeError n errorMay = - CSP.ClientStNext { - CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay - , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay - } - - fromChainTip :: ChainTip -> WithOrigin BlockNo - fromChainTip ct = case ct of - ChainTipAtGenesis -> Origin - ChainTip _ _ bno -> At bno + clientIdle_DoneNwithMaybeError + :: Nat n -- Number of requests inflight. + -> Maybe LedgerStateError -- Return value (maybe an error) + -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) + clientIdle_DoneNwithMaybeError n errorMay = case n of + Succ predN -> return (CSP.CollectResponse Nothing (clientNext_DoneNwithMaybeError predN errorMay)) -- Ignore remaining message responses + Zero -> do + writeIORef errorIORef errorMay + return (CSP.SendMsgDone ()) + + clientNext_DoneNwithMaybeError + :: Nat n -- Number of requests inflight. + -> Maybe LedgerStateError -- Return value (maybe an error) + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () + clientNext_DoneNwithMaybeError n errorMay = + CSP.ClientStNext + { CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay + , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay + } + fromChainTip :: ChainTip -> WithOrigin BlockNo + fromChainTip ct = case ct of + ChainTipAtGenesis -> Origin + ChainTip _ _ bno -> At bno -- | Wrap a 'ChainSyncClient' with logic that tracks the ledger state. chainSyncClientWithLedgerState - :: forall m a. - Monad m + :: forall m a + . Monad m => Env -> LedgerState -- ^ Initial ledger state -> ValidationMode - -> CS.ChainSyncClient (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) - ChainPoint - ChainTip - m - a + -> CS.ChainSyncClient + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a -- ^ A client to wrap. The block is annotated with a 'Either LedgerStateError -- LedgerState'. This is either an error from validating a block or -- the current 'LedgerState' from applying the current block. If we -- trust the node, then we generally expect blocks to validate. Also note that -- after a block fails to validate we may still roll back to a validated -- block, in which case the valid 'LedgerState' will be passed here again. - -> CS.ChainSyncClient BlockInMode - ChainPoint - ChainTip - m - a + -> CS.ChainSyncClient + BlockInMode + ChainPoint + ChainTip + m + a -- ^ A client that acts just like the wrapped client but doesn't require the -- 'LedgerState' annotation on the block type. -chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClient clientTop) - = CS.ChainSyncClient (goClientStIdle (Right initialLedgerStateHistory) <$> clientTop) - where - goClientStIdle - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIdle (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIdle BlockInMode ChainPoint ChainTip m a - goClientStIdle history client = case client of - CS.SendMsgRequestNext a b -> CS.SendMsgRequestNext a (goClientStNext history b) - CS.SendMsgFindIntersect ps a -> CS.SendMsgFindIntersect ps (goClientStIntersect history a) - CS.SendMsgDone a -> CS.SendMsgDone a - - -- This is where the magic happens. We intercept the blocks and rollbacks - -- and use it to maintain the correct ledger state. - goClientStNext - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStNext (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStNext BlockInMode ChainPoint ChainTip m a - goClientStNext (Left err) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode tip -> CS.ChainSyncClient $ - goClientStIdle (Left err) <$> CS.runChainSyncClient +chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClient clientTop) = + CS.ChainSyncClient (goClientStIdle (Right initialLedgerStateHistory) <$> clientTop) + where + goClientStIdle + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> CS.ClientStIdle + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CS.ClientStIdle + BlockInMode + ChainPoint + ChainTip + m + a + goClientStIdle history client = case client of + CS.SendMsgRequestNext a b -> CS.SendMsgRequestNext a (goClientStNext history b) + CS.SendMsgFindIntersect ps a -> CS.SendMsgFindIntersect ps (goClientStIntersect history a) + CS.SendMsgDone a -> CS.SendMsgDone a + + -- This is where the magic happens. We intercept the blocks and rollbacks + -- and use it to maintain the correct ledger state. + goClientStNext + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> CS.ClientStNext + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CS.ClientStNext + BlockInMode + ChainPoint + ChainTip + m + a + goClientStNext (Left err) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = + CS.ClientStNext + ( \blkInMode tip -> + CS.ChainSyncClient $ + goClientStIdle (Left err) + <$> CS.runChainSyncClient (recvMsgRollForward (blkInMode, Left err) tip) ) - (\point tip -> CS.ChainSyncClient $ + ( \point tip -> + CS.ChainSyncClient $ goClientStIdle (Left err) <$> CS.runChainSyncClient (recvMsgRollBackward point tip) ) - goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip -> CS.ChainSyncClient $ let - newLedgerStateE = case Seq.lookup 0 history of - Nothing -> error "Impossible! History should always be non-empty" - Just (_, Left err, _) -> Left err - Just (_, Right (oldLedgerState, _), _) -> applyBlock - env - oldLedgerState - validationMode - blkInMode - (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode - in goClientStIdle (Right history') <$> CS.runChainSyncClient - (recvMsgRollForward (blkInMode, newLedgerStateE) tip) + goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = + CS.ClientStNext + ( \blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip -> + CS.ChainSyncClient $ + let + newLedgerStateE = case Seq.lookup 0 history of + Nothing -> error "Impossible! History should always be non-empty" + Just (_, Left err, _) -> Left err + Just (_, Right (oldLedgerState, _), _) -> + applyBlock + env + oldLedgerState + validationMode + blkInMode + (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode + in + goClientStIdle (Right history') + <$> CS.runChainSyncClient + (recvMsgRollForward (blkInMode, newLedgerStateE) tip) ) - (\point tip -> let - oldestSlot = case history of - _ Seq.:|> (s, _, _) -> s - Seq.Empty -> error "Impossible! History should always be non-empty" - history' = (\h -> if Seq.null h - then Left (InvalidRollback oldestSlot point) - else Right h) - $ case point of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo - in CS.ChainSyncClient $ goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollBackward point tip) + ( \point tip -> + let + oldestSlot = case history of + _ Seq.:|> (s, _, _) -> s + Seq.Empty -> error "Impossible! History should always be non-empty" + history' = ( \h -> + if Seq.null h + then Left (InvalidRollback oldestSlot point) + else Right h + ) + $ case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in + CS.ChainSyncClient $ + goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollBackward point tip) ) - goClientStIntersect - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIntersect (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIntersect BlockInMode ChainPoint ChainTip m a - goClientStIntersect history (CS.ClientStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CS.ClientStIntersect - (\point tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectFound point tip))) - (\tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectNotFound tip))) + goClientStIntersect + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> CS.ClientStIntersect + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CS.ClientStIntersect + BlockInMode + ChainPoint + ChainTip + m + a + goClientStIntersect history (CS.ClientStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = + CS.ClientStIntersect + ( \point tip -> + CS.ChainSyncClient + (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectFound point tip)) + ) + ( \tip -> + CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectNotFound tip)) + ) - initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) - initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) + initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) + initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) -- | See 'chainSyncClientWithLedgerState'. chainSyncClientPipelinedWithLedgerState - :: forall m a. - Monad m + :: forall m a + . Monad m => Env -> LedgerState -> ValidationMode -> CSP.ChainSyncClientPipelined - (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) - ChainPoint - ChainTip - m - a + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a -> CSP.ChainSyncClientPipelined - BlockInMode - ChainPoint - ChainTip - m - a -chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.ChainSyncClientPipelined clientTop) - = CSP.ChainSyncClientPipelined (goClientPipelinedStIdle (Right initialLedgerStateHistory) Zero <$> clientTop) - where - goClientPipelinedStIdle - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientPipelinedStIdle n (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a - goClientPipelinedStIdle history n client = case client of - CSP.SendMsgRequestNext a b -> CSP.SendMsgRequestNext a (goClientStNext history n b) - CSP.SendMsgRequestNextPipelined m a -> CSP.SendMsgRequestNextPipelined m (goClientPipelinedStIdle history (Succ n) a) - CSP.SendMsgFindIntersect ps a -> CSP.SendMsgFindIntersect ps (goClientPipelinedStIntersect history n a) - CSP.CollectResponse a b -> case n of - Succ nPrev -> CSP.CollectResponse ((fmap . fmap) (goClientPipelinedStIdle history n) a) (goClientStNext history nPrev b) - CSP.SendMsgDone a -> CSP.SendMsgDone a - - -- This is where the magic happens. We intercept the blocks and rollbacks - -- and use it to maintain the correct ledger state. - goClientStNext - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientStNext n (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip m a - goClientStNext (Left err) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode tip -> - goClientPipelinedStIdle (Left err) n <$> recvMsgRollForward - (blkInMode, Left err) tip + BlockInMode + ChainPoint + ChainTip + m + a +chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.ChainSyncClientPipelined clientTop) = + CSP.ChainSyncClientPipelined + (goClientPipelinedStIdle (Right initialLedgerStateHistory) Zero <$> clientTop) + where + goClientPipelinedStIdle + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> Nat n + -> CSP.ClientPipelinedStIdle + n + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CSP.ClientPipelinedStIdle + n + BlockInMode + ChainPoint + ChainTip + m + a + goClientPipelinedStIdle history n client = case client of + CSP.SendMsgRequestNext a b -> CSP.SendMsgRequestNext a (goClientStNext history n b) + CSP.SendMsgRequestNextPipelined m a -> CSP.SendMsgRequestNextPipelined m (goClientPipelinedStIdle history (Succ n) a) + CSP.SendMsgFindIntersect ps a -> CSP.SendMsgFindIntersect ps (goClientPipelinedStIntersect history n a) + CSP.CollectResponse a b -> case n of + Succ nPrev -> + CSP.CollectResponse + ((fmap . fmap) (goClientPipelinedStIdle history n) a) + (goClientStNext history nPrev b) + CSP.SendMsgDone a -> CSP.SendMsgDone a + + -- This is where the magic happens. We intercept the blocks and rollbacks + -- and use it to maintain the correct ledger state. + goClientStNext + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> Nat n + -> CSP.ClientStNext + n + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CSP.ClientStNext + n + BlockInMode + ChainPoint + ChainTip + m + a + goClientStNext (Left err) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = + CSP.ClientStNext + ( \blkInMode tip -> + goClientPipelinedStIdle (Left err) n + <$> recvMsgRollForward + (blkInMode, Left err) + tip ) - (\point tip -> + ( \point tip -> goClientPipelinedStIdle (Left err) n <$> recvMsgRollBackward point tip ) - goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip -> let - newLedgerStateE = case Seq.lookup 0 history of - Nothing -> error "Impossible! History should always be non-empty" - Just (_, Left err, _) -> Left err - Just (_, Right (oldLedgerState, _), _) -> applyBlock + goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = + CSP.ClientStNext + ( \blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip -> + let + newLedgerStateE = case Seq.lookup 0 history of + Nothing -> error "Impossible! History should always be non-empty" + Just (_, Left err, _) -> Left err + Just (_, Right (oldLedgerState, _), _) -> + applyBlock env oldLedgerState validationMode blkInMode - (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode - in goClientPipelinedStIdle (Right history') n <$> recvMsgRollForward - (blkInMode, newLedgerStateE) tip + (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode + in + goClientPipelinedStIdle (Right history') n + <$> recvMsgRollForward + (blkInMode, newLedgerStateE) + tip ) - (\point tip -> let - oldestSlot = case history of - _ Seq.:|> (s, _, _) -> s - Seq.Empty -> error "Impossible! History should always be non-empty" - history' = (\h -> if Seq.null h - then Left (InvalidRollback oldestSlot point) - else Right h) - $ case point of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo - in goClientPipelinedStIdle history' n <$> recvMsgRollBackward point tip + ( \point tip -> + let + oldestSlot = case history of + _ Seq.:|> (s, _, _) -> s + Seq.Empty -> error "Impossible! History should always be non-empty" + history' = ( \h -> + if Seq.null h + then Left (InvalidRollback oldestSlot point) + else Right h + ) + $ case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in + goClientPipelinedStIdle history' n <$> recvMsgRollBackward point tip ) - goClientPipelinedStIntersect - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientPipelinedStIntersect (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a - goClientPipelinedStIntersect history _ (CSP.ClientPipelinedStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CSP.ClientPipelinedStIntersect + goClientPipelinedStIntersect + :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -> Nat n + -> CSP.ClientPipelinedStIntersect + (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + ChainPoint + ChainTip + m + a + -> CSP.ClientPipelinedStIntersect + BlockInMode + ChainPoint + ChainTip + m + a + goClientPipelinedStIntersect history _ (CSP.ClientPipelinedStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = + CSP.ClientPipelinedStIntersect (\point tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectFound point tip) (\tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectNotFound tip) - initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) - initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) - + initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) + initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) extractHistory :: History LedgerStateEvents -> [(SlotNo, [LedgerEvent], BlockNo)] extractHistory historySeq = let histList = toList historySeq - in List.map (\(slotNo, (_ledgerState, ledgerEvents), block) -> (slotNo, ledgerEvents, getBlockNo block)) histList + in List.map + (\(slotNo, (_ledgerState, ledgerEvents), block) -> (slotNo, ledgerEvents, getBlockNo block)) + histList getBlockNo :: WithOrigin BlockInMode -> BlockNo getBlockNo = Consensus.withOrigin (BlockNo 0) (blockNo . toConsensusBlock) @@ -822,31 +968,35 @@ getBlockNo = Consensus.withOrigin (BlockNo 0) (blockNo . toConsensusBlock) -- * Slot number that a new block occurred -- * The ledger state and events after applying the new block -- * The new block --- type LedgerStateHistory = History LedgerStateEvents + type History a = Seq (SlotNo, a, WithOrigin BlockInMode) -- | Add a new ledger state to the history pushLedgerState - :: Env -- ^ Environment used to get the security param, k. - -> History a -- ^ History of k items. - -> SlotNo -- ^ Slot number of the new item. - -> a -- ^ New item to add to the history + :: Env + -- ^ Environment used to get the security param, k. + -> History a + -- ^ History of k items. + -> SlotNo + -- ^ Slot number of the new item. + -> a + -- ^ New item to add to the history -> BlockInMode - -- ^ The block that (when applied to the previous - -- item) resulted in the new item. + -- ^ The block that (when applied to the previous + -- item) resulted in the new item. -> (History a, History a) -- ^ ( The new history with the new item appended -- , Any existing items that are now past the security parameter -- and hence can no longer be rolled back. -- ) -pushLedgerState env hist sn st block - = Seq.splitAt - (fromIntegral $ envSecurityParam env + 1) - ((sn, st, At block) Seq.:<| hist) +pushLedgerState env hist sn st block = + Seq.splitAt + (fromIntegral $ envSecurityParam env + 1) + ((sn, st, At block) Seq.:<| hist) rollBackLedgerStateHist :: History a -> SlotNo -> History a -rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x,_,_) -> x)) hist +rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x, _, _) -> x)) hist -------------------------------------------------------------------------------- -- Everything below was copied/adapted from db-sync -- @@ -860,28 +1010,36 @@ genesisConfigToEnv genCfg = case genCfg of GenesisCardano _ bCfg _ transCfg - | Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Cardano.Chain.Genesis.configProtocolMagicId bCfg) /= Ledger.sgNetworkMagic shelleyGenesis -> + | Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Cardano.Chain.Genesis.configProtocolMagicId bCfg) + /= Ledger.sgNetworkMagic shelleyGenesis -> Left . NECardanoConfig $ mconcat - [ "ProtocolMagicId ", textShow (Cardano.Crypto.ProtocolMagic.unProtocolMagicId $ Cardano.Chain.Genesis.configProtocolMagicId bCfg) - , " /= ", textShow (Ledger.sgNetworkMagic shelleyGenesis) + [ "ProtocolMagicId " + , textShow + (Cardano.Crypto.ProtocolMagic.unProtocolMagicId $ Cardano.Chain.Genesis.configProtocolMagicId bCfg) + , " /= " + , textShow (Ledger.sgNetworkMagic shelleyGenesis) ] - | Cardano.Chain.Genesis.gdStartTime (Cardano.Chain.Genesis.configGenesisData bCfg) /= Ledger.sgSystemStart shelleyGenesis -> + | Cardano.Chain.Genesis.gdStartTime (Cardano.Chain.Genesis.configGenesisData bCfg) + /= Ledger.sgSystemStart shelleyGenesis -> Left . NECardanoConfig $ mconcat - [ "SystemStart ", textShow (Cardano.Chain.Genesis.gdStartTime $ Cardano.Chain.Genesis.configGenesisData bCfg) - , " /= ", textShow (Ledger.sgSystemStart shelleyGenesis) + [ "SystemStart " + , textShow (Cardano.Chain.Genesis.gdStartTime $ Cardano.Chain.Genesis.configGenesisData bCfg) + , " /= " + , textShow (Ledger.sgSystemStart shelleyGenesis) ] | otherwise -> let topLevelConfig = Consensus.pInfoConfig $ fst $ mkProtocolInfoCardano genCfg - in - Right $ Env + in + Right $ + Env { envLedgerConfig = Consensus.topLevelConfigLedger topLevelConfig , envConsensusConfig = Consensus.topLevelConfigProtocol topLevelConfig } - where - shelleyGenesis = transCfg ^. Ledger.tcShelleyGenesisL + where + shelleyGenesis = transCfg ^. Ledger.tcShelleyGenesisL readNodeConfig :: MonadError Text m @@ -889,8 +1047,9 @@ readNodeConfig => NodeConfigFile 'In -> m NodeConfig readNodeConfig (File ncf) = do - ncfg <- liftEither . parseNodeConfig =<< readByteString ncf "node" - return ncfg + ncfg <- liftEither . parseNodeConfig =<< readByteString ncf "node" + return + ncfg { ncByronGenesisFile = mapFile (mkAdjustPath ncf) (ncByronGenesisFile ncfg) , ncShelleyGenesisFile = @@ -918,86 +1077,86 @@ data NodeConfig = NodeConfig instance FromJSON NodeConfig where parseJSON = - Aeson.withObject "NodeConfig" parse - where - parse :: Object -> Parser NodeConfig - parse o = - NodeConfig - <$> o .:? "PBftSignatureThreshold" - <*> fmap File (o .: "ByronGenesisFile") - <*> fmap GenesisHashByron (o .: "ByronGenesisHash") - <*> fmap File (o .: "ShelleyGenesisFile") - <*> fmap GenesisHashShelley (o .: "ShelleyGenesisHash") - <*> fmap File (o .: "AlonzoGenesisFile") - <*> fmap GenesisHashAlonzo (o .: "AlonzoGenesisHash") - <*> (fmap . fmap) File (o .:? "ConwayGenesisFile") - <*> (fmap . fmap) GenesisHashConway (o .:? "ConwayGenesisHash") - <*> o .: "RequiresNetworkMagic" - <*> parseByronProtocolVersion o - <*> parseHardForkTriggers o - - parseByronProtocolVersion :: Object -> Parser Cardano.Chain.Update.ProtocolVersion - parseByronProtocolVersion o = - Cardano.Chain.Update.ProtocolVersion - <$> o .: "LastKnownBlockVersion-Major" - <*> o .: "LastKnownBlockVersion-Minor" - <*> o .: "LastKnownBlockVersion-Alt" - - parseHardForkTriggers :: Object -> Parser Consensus.CardanoHardForkTriggers - parseHardForkTriggers o = - Consensus.CardanoHardForkTriggers' - <$> parseShelleyHardForkEpoch o - <*> parseAllegraHardForkEpoch o - <*> parseMaryHardForkEpoch o - <*> parseAlonzoHardForkEpoch o - <*> parseBabbageHardForkEpoch o - <*> parseConwayHardForkEpoch o - - parseShelleyHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseShelleyHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestShelleyHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 2 -- Mainnet default - ] - - parseAllegraHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseAllegraHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestAllegraHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 3 -- Mainnet default - ] - - parseMaryHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseMaryHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestMaryHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 4 -- Mainnet default - ] - - parseAlonzoHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseAlonzoHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestAlonzoHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 5 -- Mainnet default - ] - parseBabbageHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseBabbageHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestBabbageHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 7 -- Mainnet default - ] - - parseConwayHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork - parseConwayHardForkEpoch o = - asum - [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestConwayHardForkAtEpoch" - , pure $ Consensus.TriggerHardForkAtVersion 9 -- Mainnet default - ] - - ---------------------------------------------------------------------- - -- WARNING When adding new entries above, be aware that if there is an - -- intra-era fork, then the numbering is not consecutive. - ---------------------------------------------------------------------- + Aeson.withObject "NodeConfig" parse + where + parse :: Object -> Parser NodeConfig + parse o = + NodeConfig + <$> o .:? "PBftSignatureThreshold" + <*> fmap File (o .: "ByronGenesisFile") + <*> fmap GenesisHashByron (o .: "ByronGenesisHash") + <*> fmap File (o .: "ShelleyGenesisFile") + <*> fmap GenesisHashShelley (o .: "ShelleyGenesisHash") + <*> fmap File (o .: "AlonzoGenesisFile") + <*> fmap GenesisHashAlonzo (o .: "AlonzoGenesisHash") + <*> (fmap . fmap) File (o .:? "ConwayGenesisFile") + <*> (fmap . fmap) GenesisHashConway (o .:? "ConwayGenesisHash") + <*> o .: "RequiresNetworkMagic" + <*> parseByronProtocolVersion o + <*> parseHardForkTriggers o + + parseByronProtocolVersion :: Object -> Parser Cardano.Chain.Update.ProtocolVersion + parseByronProtocolVersion o = + Cardano.Chain.Update.ProtocolVersion + <$> o .: "LastKnownBlockVersion-Major" + <*> o .: "LastKnownBlockVersion-Minor" + <*> o .: "LastKnownBlockVersion-Alt" + + parseHardForkTriggers :: Object -> Parser Consensus.CardanoHardForkTriggers + parseHardForkTriggers o = + Consensus.CardanoHardForkTriggers' + <$> parseShelleyHardForkEpoch o + <*> parseAllegraHardForkEpoch o + <*> parseMaryHardForkEpoch o + <*> parseAlonzoHardForkEpoch o + <*> parseBabbageHardForkEpoch o + <*> parseConwayHardForkEpoch o + + parseShelleyHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseShelleyHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestShelleyHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 2 -- Mainnet default + ] + + parseAllegraHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseAllegraHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestAllegraHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 3 -- Mainnet default + ] + + parseMaryHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseMaryHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestMaryHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 4 -- Mainnet default + ] + + parseAlonzoHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseAlonzoHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestAlonzoHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 5 -- Mainnet default + ] + parseBabbageHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseBabbageHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestBabbageHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 7 -- Mainnet default + ] + + parseConwayHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork + parseConwayHardForkEpoch o = + asum + [ Consensus.TriggerHardForkAtEpoch <$> o .: "TestConwayHardForkAtEpoch" + , pure $ Consensus.TriggerHardForkAtVersion 9 -- Mainnet default + ] + +---------------------------------------------------------------------- +-- WARNING When adding new entries above, be aware that if there is an +-- intra-era fork, then the numbering is not consecutive. +---------------------------------------------------------------------- parseNodeConfig :: ByteString -> Either Text NodeConfig parseNodeConfig bs = @@ -1016,20 +1175,23 @@ readByteString -> m ByteString readByteString fp cfgType = (liftEither <=< liftIO) $ catch (Right <$> BS.readFile fp) $ \(_ :: IOException) -> - return $ Left $ mconcat - [ "Cannot read the ", cfgType, " configuration file at : ", Text.pack fp ] + return $ + Left $ + mconcat + ["Cannot read the ", cfgType, " configuration file at : ", Text.pack fp] initLedgerStateVar :: GenesisConfig -> LedgerState -initLedgerStateVar genesisConfig = LedgerState - { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo - } - where - protocolInfo = mkProtocolInfoCardano genesisConfig +initLedgerStateVar genesisConfig = + LedgerState + { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo + } + where + protocolInfo = mkProtocolInfoCardano genesisConfig newtype LedgerState = LedgerState { clsState :: Consensus.CardanoLedgerState Consensus.StandardCrypto - } deriving Show - + } + deriving (Show) -- | Retrieve new epoch state from the ledger state, or an error on failure getAnyNewEpochState @@ -1072,37 +1234,40 @@ getNewEpochState era x = do pure $ Shelley.shelleyLedgerState current _ -> Left err ShelleyBasedEraConway -> - case x of + case x of Consensus.LedgerStateConway current -> pure $ Shelley.shelleyLedgerState current _ -> Left err -encodeLedgerState :: - Consensus.CardanoCodecConfig Consensus.StandardCrypto +encodeLedgerState + :: Consensus.CardanoCodecConfig Consensus.StandardCrypto -> LedgerState -> CBOR.Encoding encodeLedgerState ccfg (LedgerState st) = encodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) ccfg st -decodeLedgerState :: - Consensus.CardanoCodecConfig Consensus.StandardCrypto - -> forall s. CBOR.Decoder s LedgerState +decodeLedgerState + :: Consensus.CardanoCodecConfig Consensus.StandardCrypto + -> forall s + . CBOR.Decoder s LedgerState decodeLedgerState ccfg = LedgerState <$> decodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) ccfg type LedgerStateEvents = (LedgerState, [LedgerEvent]) -toLedgerStateEvents :: - Ledger.LedgerResult - (Consensus.CardanoLedgerState Consensus.StandardCrypto) - (Consensus.CardanoLedgerState Consensus.StandardCrypto) - -> - LedgerStateEvents +toLedgerStateEvents + :: Ledger.LedgerResult + (Consensus.CardanoLedgerState Consensus.StandardCrypto) + (Consensus.CardanoLedgerState Consensus.StandardCrypto) + -> LedgerStateEvents toLedgerStateEvents lr = (ledgerState, ledgerEvents) - where - ledgerState = LedgerState (Ledger.lrResult lr) - ledgerEvents = mapMaybe (toLedgerEvent - . WrapLedgerEvent @(Consensus.CardanoBlock Consensus.StandardCrypto)) + where + ledgerState = LedgerState (Ledger.lrResult lr) + ledgerEvents = + mapMaybe + ( toLedgerEvent + . WrapLedgerEvent @(Consensus.CardanoBlock Consensus.StandardCrypto) + ) $ Ledger.lrEvents lr -- Usually only one constructor, but may have two when we are preparing for a HFC event. @@ -1114,26 +1279,31 @@ data GenesisConfig !(Ledger.TransitionConfig (Ledger.LatestKnownEra Consensus.StandardCrypto)) newtype LedgerStateDir = LedgerStateDir - { unLedgerStateDir :: FilePath - } deriving Show + { unLedgerStateDir :: FilePath + } + deriving (Show) newtype NetworkName = NetworkName { unNetworkName :: Text - } deriving Show + } + deriving (Show) type NodeConfigFile = File NodeConfig -mkProtocolInfoCardano :: - GenesisConfig -> - (Consensus.ProtocolInfo - (Consensus.CardanoBlock Consensus.StandardCrypto) - , IO [BlockForging IO (Consensus.CardanoBlock Consensus.StandardCrypto)]) -mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesisHash transCfg) - = Consensus.protocolInfoCardano Consensus.CardanoProtocolParams +mkProtocolInfoCardano + :: GenesisConfig + -> ( Consensus.ProtocolInfo + (Consensus.CardanoBlock Consensus.StandardCrypto) + , IO [BlockForging IO (Consensus.CardanoBlock Consensus.StandardCrypto)] + ) +mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesisHash transCfg) = + Consensus.protocolInfoCardano + Consensus.CardanoProtocolParams { Consensus.paramsByron = Consensus.ProtocolParamsByron { Consensus.byronGenesis = byronGenesis - , Consensus.byronPbftSignatureThreshold = Consensus.PBftSignatureThreshold <$> ncPBftSignatureThreshold dnc + , Consensus.byronPbftSignatureThreshold = + Consensus.PBftSignatureThreshold <$> ncPBftSignatureThreshold dnc , Consensus.byronProtocolVersion = ncByronProtocolVersion dnc , Consensus.byronSoftwareVersion = Byron.softwareVersion , Consensus.byronLeaderCredentials = Nothing @@ -1162,7 +1332,7 @@ mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesisHash transC , Consensus.paramsAlonzo = Consensus.ProtocolParamsAlonzo { Consensus.alonzoProtVer = ProtVer (natVersion @7) 0 - , Consensus.alonzoMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure + , Consensus.alonzoMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } , Consensus.paramsBabbage = Consensus.ProtocolParamsBabbage @@ -1176,8 +1346,8 @@ mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesisHash transC } , Consensus.hardForkTriggers = ncHardForkTriggers dnc , Consensus.ledgerTransitionConfig = transCfg - -- NOTE: this can become a parameter once https://github.com/IntersectMBO/cardano-node/issues/5730 is implemented. - , Consensus.checkpoints = Consensus.emptyCheckpointsMap + , -- NOTE: this can become a parameter once https://github.com/IntersectMBO/cardano-node/issues/5730 is implemented. + Consensus.checkpoints = Consensus.emptyCheckpointsMap } -- | Compute the Nonce from the hash of the Genesis file. @@ -1204,7 +1374,7 @@ data GenesisConfigError | NEAlonzoConfig !FilePath !Text | NEConwayConfig !FilePath !Text | NECardanoConfig !Text - deriving Show + deriving (Show) instance Exception GenesisConfigError @@ -1213,24 +1383,37 @@ instance Error GenesisConfigError where NEError t -> "Error:" <+> pretty t NEByronConfig fp ce -> mconcat - [ "Failed reading Byron genesis file ", pretty fp, ": ", pshow ce + [ "Failed reading Byron genesis file " + , pretty fp + , ": " + , pshow ce ] NEShelleyConfig fp txt -> mconcat - [ "Failed reading Shelley genesis file ", pretty fp, ": ", pretty txt + [ "Failed reading Shelley genesis file " + , pretty fp + , ": " + , pretty txt ] NEAlonzoConfig fp txt -> mconcat - [ "Failed reading Alonzo genesis file ", pretty fp, ": ", pretty txt + [ "Failed reading Alonzo genesis file " + , pretty fp + , ": " + , pretty txt ] NEConwayConfig fp txt -> mconcat - [ "Failed reading Conway genesis file ", pretty fp, ": ", pretty txt + [ "Failed reading Conway genesis file " + , pretty fp + , ": " + , pretty txt ] NECardanoConfig err -> mconcat [ "With Cardano protocol, Byron/Shelley config mismatch:\n" - , " ", pretty err + , " " + , pretty err ] readByronGenesisConfig @@ -1239,11 +1422,12 @@ readByronGenesisConfig -> t m Cardano.Chain.Genesis.Config readByronGenesisConfig enc = do let file = unFile $ ncByronGenesisFile enc - genHash <- liftEither - . first NEError - $ Cardano.Crypto.Hashing.decodeAbstractHash (unGenesisHashByron $ ncByronGenesisHash enc) - modifyError (NEByronConfig file) - $ Cardano.Chain.Genesis.mkConfigFromFile (ncRequiresNetworkMagic enc) file genHash + genHash <- + liftEither + . first NEError + $ Cardano.Crypto.Hashing.decodeAbstractHash (unGenesisHashByron $ ncByronGenesisHash enc) + modifyError (NEByronConfig file) $ + Cardano.Chain.Genesis.mkConfigFromFile (ncRequiresNetworkMagic enc) file genHash readShelleyGenesisConfig :: MonadIOTransError GenesisConfigError t m @@ -1251,8 +1435,8 @@ readShelleyGenesisConfig -> t m ShelleyConfig readShelleyGenesisConfig enc = do let file = ncShelleyGenesisFile enc - modifyError (NEShelleyConfig (unFile file) . renderShelleyGenesisError) - $ readShelleyGenesis file (ncShelleyGenesisHash enc) + modifyError (NEShelleyConfig (unFile file) . renderShelleyGenesisError) $ + readShelleyGenesis file (ncShelleyGenesisHash enc) readAlonzoGenesisConfig :: MonadIOTransError GenesisConfigError t m @@ -1260,8 +1444,8 @@ readAlonzoGenesisConfig -> t m AlonzoGenesis readAlonzoGenesisConfig enc = do let file = ncAlonzoGenesisFile enc - modifyError (NEAlonzoConfig (unFile file) . renderAlonzoGenesisError) - $ readAlonzoGenesis file (ncAlonzoGenesisHash enc) + modifyError (NEAlonzoConfig (unFile file) . renderAlonzoGenesisError) $ + readAlonzoGenesis file (ncAlonzoGenesisHash enc) -- | If the conway genesis file does not exist we simply put in a default. readConwayGenesisConfig @@ -1273,106 +1457,122 @@ readConwayGenesisConfig enc = do case mFile of Nothing -> return conwayGenesisDefaults Just fp -> - modifyError (NEConwayConfig (unFile fp) . renderConwayGenesisError) - $ readConwayGenesis (ncConwayGenesisFile enc) (ncConwayGenesisHash enc) + modifyError (NEConwayConfig (unFile fp) . renderConwayGenesisError) $ + readConwayGenesis (ncConwayGenesisFile enc) (ncConwayGenesisHash enc) readShelleyGenesis - :: forall m t. MonadIOTransError ShelleyGenesisError t m + :: forall m t + . MonadIOTransError ShelleyGenesisError t m => ShelleyGenesisFile 'In -> GenesisHashShelley -> t m ShelleyConfig readShelleyGenesis (File file) expectedGenesisHash = do - content <- modifyError id $ handleIOExceptT (ShelleyGenesisReadError file . textShow) $ BS.readFile file - let genesisHash = GenesisHashShelley (Cardano.Crypto.Hash.Class.hashWith id content) - checkExpectedGenesisHash genesisHash - genesis <- liftEither - . first (ShelleyGenesisDecodeError file . Text.pack) - $ Aeson.eitherDecodeStrict' content - pure $ ShelleyConfig genesis genesisHash - where - checkExpectedGenesisHash :: GenesisHashShelley -> t m () - checkExpectedGenesisHash actual = - when (actual /= expectedGenesisHash) $ - throwError (ShelleyGenesisHashMismatch actual expectedGenesisHash) + content <- + modifyError id $ handleIOExceptT (ShelleyGenesisReadError file . textShow) $ BS.readFile file + let genesisHash = GenesisHashShelley (Cardano.Crypto.Hash.Class.hashWith id content) + checkExpectedGenesisHash genesisHash + genesis <- + liftEither + . first (ShelleyGenesisDecodeError file . Text.pack) + $ Aeson.eitherDecodeStrict' content + pure $ ShelleyConfig genesis genesisHash + where + checkExpectedGenesisHash :: GenesisHashShelley -> t m () + checkExpectedGenesisHash actual = + when (actual /= expectedGenesisHash) $ + throwError (ShelleyGenesisHashMismatch actual expectedGenesisHash) data ShelleyGenesisError - = ShelleyGenesisReadError !FilePath !Text - | ShelleyGenesisHashMismatch !GenesisHashShelley !GenesisHashShelley -- actual, expected - | ShelleyGenesisDecodeError !FilePath !Text - deriving Show + = ShelleyGenesisReadError !FilePath !Text + | ShelleyGenesisHashMismatch !GenesisHashShelley !GenesisHashShelley -- actual, expected + | ShelleyGenesisDecodeError !FilePath !Text + deriving (Show) instance Exception ShelleyGenesisError renderShelleyGenesisError :: ShelleyGenesisError -> Text renderShelleyGenesisError sge = - case sge of - ShelleyGenesisReadError fp err -> - mconcat - [ "There was an error reading the genesis file: ", Text.pack fp - , " Error: ", err - ] - - ShelleyGenesisHashMismatch actual expected -> - mconcat - [ "Wrong Shelley genesis file: the actual hash is ", renderHash (unGenesisHashShelley actual) - , ", but the expected Shelley genesis hash given in the node " - , "configuration file is ", renderHash (unGenesisHashShelley expected), "." - ] - - ShelleyGenesisDecodeError fp err -> - mconcat - [ "There was an error parsing the genesis file: ", Text.pack fp - , " Error: ", err - ] + case sge of + ShelleyGenesisReadError fp err -> + mconcat + [ "There was an error reading the genesis file: " + , Text.pack fp + , " Error: " + , err + ] + ShelleyGenesisHashMismatch actual expected -> + mconcat + [ "Wrong Shelley genesis file: the actual hash is " + , renderHash (unGenesisHashShelley actual) + , ", but the expected Shelley genesis hash given in the node " + , "configuration file is " + , renderHash (unGenesisHashShelley expected) + , "." + ] + ShelleyGenesisDecodeError fp err -> + mconcat + [ "There was an error parsing the genesis file: " + , Text.pack fp + , " Error: " + , err + ] readAlonzoGenesis - :: forall m t. MonadIOTransError AlonzoGenesisError t m + :: forall m t + . MonadIOTransError AlonzoGenesisError t m => File AlonzoGenesis 'In -> GenesisHashAlonzo -> t m AlonzoGenesis readAlonzoGenesis (File file) expectedGenesisHash = do - content <- modifyError id $ handleIOExceptT (AlonzoGenesisReadError file . textShow) $ BS.readFile file - let genesisHash = GenesisHashAlonzo (Cardano.Crypto.Hash.Class.hashWith id content) - checkExpectedGenesisHash genesisHash - liftEither . first (AlonzoGenesisDecodeError file . Text.pack) $ Aeson.eitherDecodeStrict' content - where - checkExpectedGenesisHash :: GenesisHashAlonzo -> t m () - checkExpectedGenesisHash actual = - when (actual /= expectedGenesisHash) $ - throwError (AlonzoGenesisHashMismatch actual expectedGenesisHash) + content <- + modifyError id $ handleIOExceptT (AlonzoGenesisReadError file . textShow) $ BS.readFile file + let genesisHash = GenesisHashAlonzo (Cardano.Crypto.Hash.Class.hashWith id content) + checkExpectedGenesisHash genesisHash + liftEither . first (AlonzoGenesisDecodeError file . Text.pack) $ Aeson.eitherDecodeStrict' content + where + checkExpectedGenesisHash :: GenesisHashAlonzo -> t m () + checkExpectedGenesisHash actual = + when (actual /= expectedGenesisHash) $ + throwError (AlonzoGenesisHashMismatch actual expectedGenesisHash) data AlonzoGenesisError - = AlonzoGenesisReadError !FilePath !Text - | AlonzoGenesisHashMismatch !GenesisHashAlonzo !GenesisHashAlonzo -- actual, expected - | AlonzoGenesisDecodeError !FilePath !Text - deriving Show + = AlonzoGenesisReadError !FilePath !Text + | AlonzoGenesisHashMismatch !GenesisHashAlonzo !GenesisHashAlonzo -- actual, expected + | AlonzoGenesisDecodeError !FilePath !Text + deriving (Show) instance Exception AlonzoGenesisError renderAlonzoGenesisError :: AlonzoGenesisError -> Text renderAlonzoGenesisError sge = - case sge of - AlonzoGenesisReadError fp err -> - mconcat - [ "There was an error reading the genesis file: ", Text.pack fp - , " Error: ", err - ] - - AlonzoGenesisHashMismatch actual expected -> - mconcat - [ "Wrong Alonzo genesis file: the actual hash is ", renderHash (unGenesisHashAlonzo actual) - , ", but the expected Alonzo genesis hash given in the node " - , "configuration file is ", renderHash (unGenesisHashAlonzo expected), "." - ] - - AlonzoGenesisDecodeError fp err -> - mconcat - [ "There was an error parsing the genesis file: ", Text.pack fp - , " Error: ", err - ] + case sge of + AlonzoGenesisReadError fp err -> + mconcat + [ "There was an error reading the genesis file: " + , Text.pack fp + , " Error: " + , err + ] + AlonzoGenesisHashMismatch actual expected -> + mconcat + [ "Wrong Alonzo genesis file: the actual hash is " + , renderHash (unGenesisHashAlonzo actual) + , ", but the expected Alonzo genesis hash given in the node " + , "configuration file is " + , renderHash (unGenesisHashAlonzo expected) + , "." + ] + AlonzoGenesisDecodeError fp err -> + mconcat + [ "There was an error parsing the genesis file: " + , Text.pack fp + , " Error: " + , err + ] readConwayGenesis - :: forall m t. MonadIOTransError ConwayGenesisError t m + :: forall m t + . MonadIOTransError ConwayGenesisError t m => Maybe (ConwayGenesisFile 'In) -> Maybe GenesisHashConway -> t m (ConwayGenesis Consensus.StandardCrypto) @@ -1380,62 +1580,69 @@ readConwayGenesis Nothing Nothing = return conwayGenesisDefaults readConwayGenesis (Just fp) Nothing = throwError $ ConwayGenesisHashMissing $ unFile fp readConwayGenesis Nothing (Just _) = throwError ConwayGenesisFileMissing readConwayGenesis (Just (File file)) (Just expectedGenesisHash) = do - content <- modifyError id $ handleIOExceptT (ConwayGenesisReadError file . textShow) $ BS.readFile file - let genesisHash = GenesisHashConway (Cardano.Crypto.Hash.Class.hashWith id content) - checkExpectedGenesisHash genesisHash - liftEither . first (ConwayGenesisDecodeError file . Text.pack) $ Aeson.eitherDecodeStrict' content - where - checkExpectedGenesisHash :: GenesisHashConway -> t m () - checkExpectedGenesisHash actual = - when (actual /= expectedGenesisHash) $ - throwError (ConwayGenesisHashMismatch actual expectedGenesisHash) + content <- + modifyError id $ handleIOExceptT (ConwayGenesisReadError file . textShow) $ BS.readFile file + let genesisHash = GenesisHashConway (Cardano.Crypto.Hash.Class.hashWith id content) + checkExpectedGenesisHash genesisHash + liftEither . first (ConwayGenesisDecodeError file . Text.pack) $ Aeson.eitherDecodeStrict' content + where + checkExpectedGenesisHash :: GenesisHashConway -> t m () + checkExpectedGenesisHash actual = + when (actual /= expectedGenesisHash) $ + throwError (ConwayGenesisHashMismatch actual expectedGenesisHash) data ConwayGenesisError - = ConwayGenesisReadError !FilePath !Text - | ConwayGenesisHashMismatch !GenesisHashConway !GenesisHashConway -- actual, expected - | ConwayGenesisHashMissing !FilePath - | ConwayGenesisFileMissing - | ConwayGenesisDecodeError !FilePath !Text - deriving Show + = ConwayGenesisReadError !FilePath !Text + | ConwayGenesisHashMismatch !GenesisHashConway !GenesisHashConway -- actual, expected + | ConwayGenesisHashMissing !FilePath + | ConwayGenesisFileMissing + | ConwayGenesisDecodeError !FilePath !Text + deriving (Show) instance Exception ConwayGenesisError renderConwayGenesisError :: ConwayGenesisError -> Text renderConwayGenesisError sge = - case sge of - ConwayGenesisFileMissing -> - mconcat - [ "\"ConwayGenesisFile\" is missing from node configuration. " - ] - ConwayGenesisHashMissing fp -> - mconcat - [ "\"ConwayGenesisHash\" is missing from node configuration: " - , Text.pack fp - ] - ConwayGenesisReadError fp err -> - mconcat - [ "There was an error reading the genesis file: ", Text.pack fp - , " Error: ", err - ] - - ConwayGenesisHashMismatch actual expected -> - mconcat - [ "Wrong Conway genesis file: the actual hash is ", renderHash (unGenesisHashConway actual) - , ", but the expected Conway genesis hash given in the node " - , "configuration file is ", renderHash (unGenesisHashConway expected), "." - ] - - ConwayGenesisDecodeError fp err -> - mconcat - [ "There was an error parsing the genesis file: ", Text.pack fp - , " Error: ", err - ] + case sge of + ConwayGenesisFileMissing -> + mconcat + [ "\"ConwayGenesisFile\" is missing from node configuration. " + ] + ConwayGenesisHashMissing fp -> + mconcat + [ "\"ConwayGenesisHash\" is missing from node configuration: " + , Text.pack fp + ] + ConwayGenesisReadError fp err -> + mconcat + [ "There was an error reading the genesis file: " + , Text.pack fp + , " Error: " + , err + ] + ConwayGenesisHashMismatch actual expected -> + mconcat + [ "Wrong Conway genesis file: the actual hash is " + , renderHash (unGenesisHashConway actual) + , ", but the expected Conway genesis hash given in the node " + , "configuration file is " + , renderHash (unGenesisHashConway expected) + , "." + ] + ConwayGenesisDecodeError fp err -> + mconcat + [ "There was an error parsing the genesis file: " + , Text.pack fp + , " Error: " + , err + ] -renderHash :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString -> Text +renderHash + :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString -> Text renderHash h = Text.decodeUtf8 $ Base16.encode (Cardano.Crypto.Hash.Class.hashToBytes h) newtype StakeCred - = StakeCred { _unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto } + = StakeCred {_unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto} deriving (Eq, Ord) data Env = Env @@ -1445,18 +1652,18 @@ data Env = Env envSecurityParam :: Env -> Word64 envSecurityParam env = k - where - Consensus.SecurityParam k - = HFC.hardForkConsensusConfigK - $ envConsensusConfig env + where + Consensus.SecurityParam k = + HFC.hardForkConsensusConfigK $ + envConsensusConfig env -- | How to do validation when applying a block to a ledger state. data ValidationMode - -- | Do all validation implied by the ledger layer's 'applyBlock`. - = FullValidation - -- | Only check that the previous hash from the block matches the head hash of - -- the ledger state. - | QuickValidation + = -- | Do all validation implied by the ledger layer's 'applyBlock`. + FullValidation + | -- | Only check that the previous hash from the block matches the head hash of + -- the ledger state. + QuickValidation -- The function 'tickThenReapply' does zero validation, so add minimal -- validation ('blockPrevHash' matches the tip hash of the 'LedgerState'). This @@ -1491,46 +1698,50 @@ applyBlockWithEvents env oldState enableValidation block = do -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from -- the block matches the head hash of the ledger state. tickThenReapplyCheckHash - :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto - -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Consensus.CardanoLedgerState Consensus.StandardCrypto - -> Either LedgerStateError LedgerStateEvents + :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto + -> Consensus.CardanoBlock Consensus.StandardCrypto + -> Consensus.CardanoLedgerState Consensus.StandardCrypto + -> Either LedgerStateError LedgerStateEvents tickThenReapplyCheckHash cfg block lsb = if Consensus.blockPrevHash block == Ledger.ledgerTipHash lsb - then Right . toLedgerStateEvents - $ Ledger.tickThenReapplyLedgerResult cfg block lsb - else Left $ ApplyBlockHashMismatch $ mconcat - [ "Ledger state hash mismatch. Ledger head is slot " - , textShow - $ Slot.unSlotNo - $ Slot.fromWithOrigin - (Slot.SlotNo 0) - (Ledger.ledgerTipSlot lsb) - , " hash " - , renderByteArray - $ unChainHash - $ Ledger.ledgerTipHash lsb - , " but block previous hash is " - , renderByteArray (unChainHash $ Consensus.blockPrevHash block) - , " and block current hash is " - , renderByteArray - $ BSS.fromShort - $ HFC.getOneEraHash - $ Ouroboros.Network.Block.blockHash block - , "." - ] + then + Right . toLedgerStateEvents $ + Ledger.tickThenReapplyLedgerResult cfg block lsb + else + Left $ + ApplyBlockHashMismatch $ + mconcat + [ "Ledger state hash mismatch. Ledger head is slot " + , textShow $ + Slot.unSlotNo $ + Slot.fromWithOrigin + (Slot.SlotNo 0) + (Ledger.ledgerTipSlot lsb) + , " hash " + , renderByteArray $ + unChainHash $ + Ledger.ledgerTipHash lsb + , " but block previous hash is " + , renderByteArray (unChainHash $ Consensus.blockPrevHash block) + , " and block current hash is " + , renderByteArray $ + BSS.fromShort $ + HFC.getOneEraHash $ + Ouroboros.Network.Block.blockHash block + , "." + ] -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from -- the block matches the head hash of the ledger state. tickThenApply - :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto - -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Consensus.CardanoLedgerState Consensus.StandardCrypto - -> Either LedgerStateError LedgerStateEvents -tickThenApply cfg block lsb - = either (Left . ApplyBlockError) (Right . toLedgerStateEvents) - $ runExcept - $ Ledger.tickThenApplyLedgerResult cfg block lsb + :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto + -> Consensus.CardanoBlock Consensus.StandardCrypto + -> Consensus.CardanoLedgerState Consensus.StandardCrypto + -> Either LedgerStateError LedgerStateEvents +tickThenApply cfg block lsb = + either (Left . ApplyBlockError) (Right . toLedgerStateEvents) $ + runExcept $ + Ledger.tickThenApplyLedgerResult cfg block lsb renderByteArray :: ByteArrayAccess bin => bin -> Text renderByteArray = @@ -1542,23 +1753,24 @@ unChainHash ch = Ouroboros.Network.Block.GenesisHash -> "genesis" Ouroboros.Network.Block.BlockHash bh -> BSS.fromShort (HFC.getOneEraHash bh) -data LeadershipError = LeaderErrDecodeLedgerStateFailure - | LeaderErrDecodeProtocolStateFailure (LB.ByteString, DecoderError) - | LeaderErrDecodeProtocolEpochStateFailure DecoderError - | LeaderErrGenesisSlot - | LeaderErrStakePoolHasNoStake PoolId - | LeaderErrStakeDistribUnstable - SlotNo - -- ^ Current slot - SlotNo - -- ^ Stable after - SlotNo - -- ^ Stability window size - SlotNo - -- ^ Predicted last slot of the epoch - | LeaderErrSlotRangeCalculationFailure Text - | LeaderErrCandidateNonceStillEvolving - deriving Show +data LeadershipError + = LeaderErrDecodeLedgerStateFailure + | LeaderErrDecodeProtocolStateFailure (LB.ByteString, DecoderError) + | LeaderErrDecodeProtocolEpochStateFailure DecoderError + | LeaderErrGenesisSlot + | LeaderErrStakePoolHasNoStake PoolId + | LeaderErrStakeDistribUnstable + SlotNo + -- ^ Current slot + SlotNo + -- ^ Stable after + SlotNo + -- ^ Stability window size + SlotNo + -- ^ Predicted last slot of the epoch + | LeaderErrSlotRangeCalculationFailure Text + | LeaderErrCandidateNonceStillEvolving + deriving (Show) instance Api.Error LeadershipError where prettyError = \case @@ -1588,7 +1800,9 @@ instance Api.Error LeadershipError where LeaderErrCandidateNonceStillEvolving -> "Candidate nonce is still evolving" -nextEpochEligibleLeadershipSlots :: forall era. () +nextEpochEligibleLeadershipSlots + :: forall era + . () => ShelleyBasedEra era -> ShelleyGenesis Consensus.StandardCrypto -> SerialisedCurrentEpochState era @@ -1605,12 +1819,13 @@ nextEpochEligibleLeadershipSlots :: forall era. () -> Either LeadershipError (Set SlotNo) nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pp eInfo (cTip, currentEpoch) = shelleyBasedEraConstraints sbe $ do - (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo currentEpoch - - (firstSlotOfEpoch, lastSlotofEpoch) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo (currentEpoch `Slot.addEpochInterval` Slot.EpochInterval 1) + (_, currentEpochLastSlot) <- + first LeaderErrSlotRangeCalculationFailure $ + Slot.epochInfoRange eInfo currentEpoch + (firstSlotOfEpoch, lastSlotofEpoch) <- + first LeaderErrSlotRangeCalculationFailure $ + Slot.epochInfoRange eInfo (currentEpoch `Slot.addEpochInterval` Slot.EpochInterval 1) -- First we check if we are within 3k/f slots of the end of the current epoch. -- Why? Because the stake distribution is stable at this point. @@ -1622,21 +1837,23 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr stabilityWindowSlots = fromIntegral @Word64 $ floor $ fromRational @Double stabilityWindowR stableStakeDistribSlot = currentEpochLastSlot - stabilityWindowSlots - case cTip of ChainTipAtGenesis -> Left LeaderErrGenesisSlot ChainTip tip _ _ -> if tip > stableStakeDistribSlot - then return () - else Left $ LeaderErrStakeDistribUnstable tip stableStakeDistribSlot stabilityWindowSlots currentEpochLastSlot + then return () + else + Left $ + LeaderErrStakeDistribUnstable tip stableStakeDistribSlot stabilityWindowSlots currentEpochLastSlot - chainDepState <- first LeaderErrDecodeProtocolStateFailure - $ decodeProtocolState ptclState + chainDepState <- + first LeaderErrDecodeProtocolStateFailure $ + decodeProtocolState ptclState -- We need the candidate nonce, the previous epoch's last block header hash -- and the extra entropy from the protocol parameters. We then need to combine them -- with the (⭒) operator. - let Consensus.PraosNonces { Consensus.candidateNonce, Consensus.evolvingNonce } = + let Consensus.PraosNonces {Consensus.candidateNonce, Consensus.evolvingNonce} = Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState -- Let's do a nonce check. The candidate nonce and the evolving nonce should not be equal. @@ -1644,7 +1861,9 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr Left LeaderErrCandidateNonceStillEvolving -- Get the previous epoch's last block header hash nonce - let previousLabNonce = Consensus.previousLabNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) + let previousLabNonce = + Consensus.previousLabNonce + (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) extraEntropy :: Nonce extraEntropy = caseShelleyToAlonzoOrBabbageEraOnwards @@ -1662,36 +1881,47 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr let snapshot :: ShelleyAPI.SnapShot Consensus.StandardCrypto snapshot = ShelleyAPI.ssStakeMark $ ShelleyAPI.esSnapshots cEstate - markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) (SL.IndividualPoolStake Consensus.StandardCrypto) + markSnapshotPoolDistr + :: Map + (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) + (SL.IndividualPoolStake Consensus.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo - slotRangeOfInterest pp' = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) - $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] + slotRangeOfInterest pp' = + Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] caseShelleyToAlonzoOrBabbageEraOnwards - (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) - (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) + ( const + (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f) + ) + ( const + (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f) + ) sbe - where - globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL - - f :: Ledger.ActiveSlotCoeff - f = activeSlotCoeff globals + where + globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL + f :: Ledger.ActiveSlotCoeff + f = activeSlotCoeff globals -- | Return slots a given stake pool operator is leading. -- See Leader Value Calculation in the Shelley ledger specification. -- We need the certified natural value from the VRF, active slot coefficient -- and the stake proportion of the stake pool. -isLeadingSlotsTPraos :: forall v. () +isLeadingSlotsTPraos + :: forall v + . () => Crypto.Signable v Ledger.Seed => Crypto.VRFAlgorithm v => Crypto.ContextVRF v ~ () => Set SlotNo -> PoolId - -> Map (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) (SL.IndividualPoolStake Consensus.StandardCrypto) + -> Map + (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) + (SL.IndividualPoolStake Consensus.StandardCrypto) -> Consensus.Nonce -> Crypto.SignKeyVRF v -> Ledger.ActiveSlotCoeff @@ -1709,10 +1939,13 @@ isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey return $ Set.filter isLeader slotRangeOfInterest -isLeadingSlotsPraos :: () +isLeadingSlotsPraos + :: () => Set SlotNo -> PoolId - -> Map (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) (SL.IndividualPoolStake Consensus.StandardCrypto) + -> Map + (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto) + (SL.IndividualPoolStake Consensus.StandardCrypto) -> Consensus.Nonce -> SL.SignKeyVRF Consensus.StandardCrypto -> Ledger.ActiveSlotCoeff @@ -1720,18 +1953,22 @@ isLeadingSlotsPraos :: () isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do let StakePoolKeyHash poolHash = poolid - stakePoolStake <- note (LeaderErrStakePoolHasNoStake poolid) $ - ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr + stakePoolStake <- + note (LeaderErrStakePoolHasNoStake poolid) $ + ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr let isLeader slotNo = checkLeaderNatValue certifiedNatValue stakePoolStake activeSlotCoeff' - where rho = VRF.evalCertified () (mkInputVRF slotNo eNonce) vrfSkey - certifiedNatValue = vrfLeaderValue (Proxy @Consensus.StandardCrypto) rho + where + rho = VRF.evalCertified () (mkInputVRF slotNo eNonce) vrfSkey + certifiedNatValue = vrfLeaderValue (Proxy @Consensus.StandardCrypto) rho Right $ Set.filter isLeader slotRangeOfInterest -- | Return the slots at which a particular stake pool operator is -- expected to mint a block. -currentEpochEligibleLeadershipSlots :: forall era. () +currentEpochEligibleLeadershipSlots + :: forall era + . () => ShelleyBasedEra era -> ShelleyGenesis Consensus.StandardCrypto -> EpochInfo (Either Text) @@ -1740,7 +1977,8 @@ currentEpochEligibleLeadershipSlots :: forall era. () -> PoolId -> SigningKey VrfKey -> SerialisedPoolDistribution era - -> EpochNo -- ^ Current EpochInfo + -> EpochNo + -- ^ Current EpochInfo -> Either LeadershipError (Set SlotNo) currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid (VrfSigningKey vrkSkey) serPoolDistr currentEpoch = shelleyBasedEraConstraints sbe $ do @@ -1750,30 +1988,37 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid (VrfSigni -- We use the current epoch's nonce for the current leadership schedule -- calculation because the TICKN transition updates the epoch nonce -- at the start of the epoch. - let epochNonce :: Nonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) + let epochNonce :: Nonce = + Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo currentEpoch + (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- + first LeaderErrSlotRangeCalculationFailure $ + Slot.epochInfoRange eInfo currentEpoch setSnapshotPoolDistr <- - first LeaderErrDecodeProtocolEpochStateFailure . fmap (SL.unPoolDistr . fromConsensusPoolDistr . unPoolDistr) + first LeaderErrDecodeProtocolEpochStateFailure + . fmap (SL.unPoolDistr . fromConsensusPoolDistr . unPoolDistr) $ decodePoolDistribution sbe serPoolDistr let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo - slotRangeOfInterest pp' = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) - $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] + slotRangeOfInterest pp' = + Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] caseShelleyToAlonzoOrBabbageEraOnwards - (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) - (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) + ( const + (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f) + ) + ( const + (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f) + ) sbe + where + globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL - where - globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL - - f :: Ledger.ActiveSlotCoeff - f = activeSlotCoeff globals + f :: Ledger.ActiveSlotCoeff + f = activeSlotCoeff globals constructGlobals :: ShelleyGenesis Consensus.StandardCrypto @@ -1783,8 +2028,6 @@ constructGlobals constructGlobals sGen eInfo (Ledger.ProtVer majorPParamsVer _) = Ledger.mkShelleyGlobals sGen eInfo majorPParamsVer - - -------------------------------------------------------------------------- -- | Type isomorphic to bool, representing condition check result @@ -1811,12 +2054,12 @@ instance Show AnyNewEpochState where showsPrec p (AnyNewEpochState sbe ledgerNewEpochState) = shelleyBasedEraConstraints sbe $ showsPrec p ledgerNewEpochState - -- | Reconstructs the ledger's new epoch state and applies a supplied condition to it for every block. This -- function only terminates if the condition is met or we have reached the termination epoch. We need to -- provide a termination epoch otherwise blocks would be applied indefinitely. foldEpochState - :: forall t m s. MonadIOTransError FoldBlocksError t m + :: forall t m s + . MonadIOTransError FoldBlocksError t m => NodeConfigFile 'In -- ^ Path to the cardano-node config file (e.g. /configuration/cardano/mainnet-config.json) -> SocketPath @@ -1827,9 +2070,9 @@ foldEpochState -> s -- ^ an initial value for the condition state -> ( AnyNewEpochState - -> SlotNo - -> BlockNo - -> StateT s IO ConditionResult + -> SlotNo + -> BlockNo + -> StateT s IO ConditionResult ) -- ^ Condition you want to check against the new epoch state. -- @@ -1850,8 +2093,9 @@ foldEpochState nodeConfigFilePath socketPath validationMode terminationEpoch ini -- * Non-pipelined: 1h 0m 19s -- * Pipelined: 46m 23s - (env, ledgerState) <- modifyError FoldBlocksInitialLedgerStateError - $ initialLedgerState nodeConfigFilePath + (env, ledgerState) <- + modifyError FoldBlocksInitialLedgerStateError $ + initialLedgerState nodeConfigFilePath -- Place to store the accumulated state -- This is a bit ugly, but easy. @@ -1862,17 +2106,17 @@ foldEpochState nodeConfigFilePath socketPath validationMode terminationEpoch ini -- Derive the NetworkId as described in network-magic.md from the -- cardano-ledger-specs repo. - let byronConfig - = (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* _) -> bc) - . HFC.getPerEraLedgerConfig - . HFC.hardForkLedgerConfigPerEra - $ envLedgerConfig env - - networkMagic - = NetworkMagic - $ unProtocolMagicId - $ Cardano.Chain.Genesis.gdProtocolMagicId - $ Cardano.Chain.Genesis.configGenesisData byronConfig + let byronConfig = + (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* _) -> bc) + . HFC.getPerEraLedgerConfig + . HFC.hardForkLedgerConfigPerEra + $ envLedgerConfig env + + networkMagic = + NetworkMagic $ + unProtocolMagicId $ + Cardano.Chain.Genesis.gdProtocolMagicId $ + Cardano.Chain.Genesis.configGenesisData byronConfig networkId' = case Cardano.Chain.Genesis.configReqNetMagic byronConfig of RequiresNoMagic -> Mainnet @@ -1881,173 +2125,187 @@ foldEpochState nodeConfigFilePath socketPath validationMode terminationEpoch ini cardanoModeParams = CardanoModeParams . EpochSlots $ 10 * envSecurityParam env -- Connect to the node. - let connectInfo = LocalNodeConnectInfo - { localConsensusModeParams = cardanoModeParams - , localNodeNetworkId = networkId' - , localNodeSocketPath = socketPath - } - - modifyError FoldBlocksIOException $ liftIO $ connectToLocalNode - connectInfo - (protocols stateMv errorIORef env ledgerState) + let connectInfo = + LocalNodeConnectInfo + { localConsensusModeParams = cardanoModeParams + , localNodeNetworkId = networkId' + , localNodeSocketPath = socketPath + } + + modifyError FoldBlocksIOException $ + liftIO $ + connectToLocalNode + connectInfo + (protocols stateMv errorIORef env ledgerState) liftIO (readIORef errorIORef) >>= \case Just err -> throwError $ FoldBlocksApplyBlockError err Nothing -> modifyError FoldBlocksIOException . liftIO $ readMVar stateMv - where - protocols :: () - => MVar (ConditionResult, s) - -> IORef (Maybe LedgerStateError) - -> Env - -> LedgerState - -> LocalNodeClientProtocolsInMode - protocols stateMv errorIORef env ledgerState = - LocalNodeClientProtocols { - localChainSyncClient = LocalChainSyncClientPipelined (chainSyncClient 50 stateMv errorIORef env ledgerState), - localTxSubmissionClient = Nothing, - localStateQueryClient = Nothing, - localTxMonitoringClient = Nothing + where + protocols + :: () + => MVar (ConditionResult, s) + -> IORef (Maybe LedgerStateError) + -> Env + -> LedgerState + -> LocalNodeClientProtocolsInMode + protocols stateMv errorIORef env ledgerState = + LocalNodeClientProtocols + { localChainSyncClient = + LocalChainSyncClientPipelined (chainSyncClient 50 stateMv errorIORef env ledgerState) + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } + + -- \| Defines the client side of the chain sync protocol. + chainSyncClient + :: Word16 + -- \^ The maximum number of concurrent requests. + -> MVar (ConditionResult, s) + -- \^ State accumulator. Written to on every block. + -> IORef (Maybe LedgerStateError) + -- \^ Resulting error if any. Written to once on protocol + -- completion. + -> Env + -> LedgerState + -> CSP.ChainSyncClientPipelined + BlockInMode + ChainPoint + ChainTip + IO + () + -- \^ Client returns maybe an error. + chainSyncClient pipelineSize stateMv errorIORef' env ledgerState0 = + CSP.ChainSyncClientPipelined $ + pure $ + clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory + where + initialLedgerStateHistory = Seq.singleton (0, (ledgerState0, []), Origin) + + clientIdle_RequestMoreN + :: WithOrigin BlockNo + -> WithOrigin BlockNo + -> Nat n -- Number of requests inflight. + -> LedgerStateHistory + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () + clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates = + case pipelineDecisionMax pipelineSize n clientTip serverTip of + Collect -> case n of + Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) + _ -> + CSP.SendMsgRequestNextPipelined + (pure ()) + (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) + + clientNextN + :: Nat n -- Number of requests inflight. + -> LedgerStateHistory + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () + clientNextN n knownLedgerStates = + CSP.ClientStNext + { CSP.recvMsgRollForward = \blockInMode@(BlockInMode era (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do + let newLedgerStateE = + applyBlock + env + ( maybe + (error "Impossible! Missing Ledger state") + (\(_, (ledgerState, _), _) -> ledgerState) + (Seq.lookup 0 knownLedgerStates) + ) + validationMode + blockInMode + case forEraMaybeEon era of + Nothing -> + let !err = Just ByronEraUnsupported + in clientIdle_DoneNwithMaybeError n err + Just sbe -> + case newLedgerStateE of + Left err -> clientIdle_DoneNwithMaybeError n (Just err) + Right new@(newLedgerState, ledgerEvents) -> do + let (knownLedgerStates', _) = pushLedgerState env knownLedgerStates slotNo new blockInMode + newClientTip = At currBlockNo + newServerTip = fromChainTip serverChainTip + case getNewEpochState sbe $ clsState newLedgerState of + Left e -> + let !err = Just e + in clientIdle_DoneNwithMaybeError n err + Right lState -> do + let newEpochState = AnyNewEpochState sbe lState + -- Run the condition function in an exclusive lock. + -- There can be only one place where `takeMVar stateMv` exists otherwise this + -- code will deadlock! + condition <- bracket (takeMVar stateMv) (tryPutMVar stateMv) $ \(_prevCondition, previousState) -> do + updatedState@(!newCondition, !_) <- + runStateT (checkCondition newEpochState slotNo currBlockNo) previousState + putMVar stateMv updatedState + pure newCondition + -- Have we reached the termination epoch? + case atTerminationEpoch terminationEpoch ledgerEvents of + Just !currentEpoch -> do + -- confirmed this works: error $ "atTerminationEpoch: Terminated at: " <> show currentEpoch + let !err = Just $ TerminationEpochReached currentEpoch + clientIdle_DoneNwithMaybeError n err + Nothing -> do + case condition of + ConditionMet -> + let !noError = Nothing + in clientIdle_DoneNwithMaybeError n noError + ConditionNotMet -> return $ clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates' + , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do + let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. + newServerTip = fromChainTip serverChainTip + truncatedKnownLedgerStates = case chainPoint of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo + return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates) } - -- | Defines the client side of the chain sync protocol. - chainSyncClient :: Word16 - -- ^ The maximum number of concurrent requests. - -> MVar (ConditionResult, s) - -- ^ State accumulator. Written to on every block. - -> IORef (Maybe LedgerStateError) - -- ^ Resulting error if any. Written to once on protocol - -- completion. - -> Env - -> LedgerState - -> CSP.ChainSyncClientPipelined - BlockInMode - ChainPoint - ChainTip - IO () - -- ^ Client returns maybe an error. - chainSyncClient pipelineSize stateMv errorIORef' env ledgerState0 - = CSP.ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory - where - initialLedgerStateHistory = Seq.singleton (0, (ledgerState0, []), Origin) - - clientIdle_RequestMoreN - :: WithOrigin BlockNo - -> WithOrigin BlockNo - -> Nat n -- Number of requests inflight. - -> LedgerStateHistory - -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () - clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates - = case pipelineDecisionMax pipelineSize n clientTip serverTip of - Collect -> case n of - Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) - _ -> CSP.SendMsgRequestNextPipelined (pure ()) (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) - - clientNextN - :: Nat n -- Number of requests inflight. - -> LedgerStateHistory - -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () - clientNextN n knownLedgerStates = - CSP.ClientStNext { - CSP.recvMsgRollForward = \blockInMode@(BlockInMode era (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do - let newLedgerStateE = applyBlock - env - (maybe - (error "Impossible! Missing Ledger state") - (\(_,(ledgerState, _),_) -> ledgerState) - (Seq.lookup 0 knownLedgerStates) - ) - validationMode - blockInMode - case forEraMaybeEon era of - Nothing -> let !err = Just ByronEraUnsupported - in clientIdle_DoneNwithMaybeError n err - Just sbe -> - case newLedgerStateE of - Left err -> clientIdle_DoneNwithMaybeError n (Just err) - Right new@(newLedgerState, ledgerEvents) -> do - let (knownLedgerStates', _) = pushLedgerState env knownLedgerStates slotNo new blockInMode - newClientTip = At currBlockNo - newServerTip = fromChainTip serverChainTip - case getNewEpochState sbe $ clsState newLedgerState of - Left e -> - let !err = Just e - in clientIdle_DoneNwithMaybeError n err - Right lState -> do - let newEpochState = AnyNewEpochState sbe lState - -- Run the condition function in an exclusive lock. - -- There can be only one place where `takeMVar stateMv` exists otherwise this - -- code will deadlock! - condition <- bracket (takeMVar stateMv) (tryPutMVar stateMv) $ \(_prevCondition, previousState) -> do - updatedState@(!newCondition, !_) <- runStateT (checkCondition newEpochState slotNo currBlockNo) previousState - putMVar stateMv updatedState - pure newCondition - -- Have we reached the termination epoch? - case atTerminationEpoch terminationEpoch ledgerEvents of - Just !currentEpoch -> do - -- confirmed this works: error $ "atTerminationEpoch: Terminated at: " <> show currentEpoch - let !err = Just $ TerminationEpochReached currentEpoch - clientIdle_DoneNwithMaybeError n err - Nothing -> do - case condition of - ConditionMet -> - let !noError = Nothing - in clientIdle_DoneNwithMaybeError n noError - ConditionNotMet -> return $ clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates' - - , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do - let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. - newServerTip = fromChainTip serverChainTip - truncatedKnownLedgerStates = case chainPoint of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo - return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates) - } - - - - clientIdle_DoneNwithMaybeError - :: Nat n -- Number of requests inflight. - -> Maybe LedgerStateError -- Return value (maybe an error) - -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) - clientIdle_DoneNwithMaybeError n errorMay = case n of - Succ predN -> do - return (CSP.CollectResponse Nothing (clientNext_DoneNwithMaybeError predN errorMay)) -- Ignore remaining message responses - Zero -> do - atomicModifyIORef' errorIORef' . const $ (errorMay, ()) - return (CSP.SendMsgDone ()) - - clientNext_DoneNwithMaybeError - :: Nat n -- Number of requests inflight. - -> Maybe LedgerStateError -- Return value (maybe an error) - -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () - clientNext_DoneNwithMaybeError n errorMay = - CSP.ClientStNext { - CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay - , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay - } - - fromChainTip :: ChainTip -> WithOrigin BlockNo - fromChainTip ct = case ct of - ChainTipAtGenesis -> Origin - ChainTip _ _ bno -> At bno + clientIdle_DoneNwithMaybeError + :: Nat n -- Number of requests inflight. + -> Maybe LedgerStateError -- Return value (maybe an error) + -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) + clientIdle_DoneNwithMaybeError n errorMay = case n of + Succ predN -> do + return (CSP.CollectResponse Nothing (clientNext_DoneNwithMaybeError predN errorMay)) -- Ignore remaining message responses + Zero -> do + atomicModifyIORef' errorIORef' . const $ (errorMay, ()) + return (CSP.SendMsgDone ()) + + clientNext_DoneNwithMaybeError + :: Nat n -- Number of requests inflight. + -> Maybe LedgerStateError -- Return value (maybe an error) + -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO () + clientNext_DoneNwithMaybeError n errorMay = + CSP.ClientStNext + { CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay + , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneNwithMaybeError n errorMay + } + fromChainTip :: ChainTip -> WithOrigin BlockNo + fromChainTip ct = case ct of + ChainTipAtGenesis -> Origin + ChainTip _ _ bno -> At bno atTerminationEpoch :: EpochNo -> [LedgerEvent] -> Maybe EpochNo atTerminationEpoch terminationEpoch events = listToMaybe - [ currentEpoch' | PoolReap poolReapDets <- events + [ currentEpoch' + | PoolReap poolReapDets <- events , let currentEpoch' = prdEpochNo poolReapDets , currentEpoch' >= terminationEpoch ] -handleExceptions :: MonadIOTransError FoldBlocksError t m - => ExceptT FoldBlocksError IO a - -> t m a +handleExceptions + :: MonadIOTransError FoldBlocksError t m + => ExceptT FoldBlocksError IO a + -> t m a handleExceptions = liftEither <=< liftIO . runExceptT . flip catches handlers - where - handlers = [ Handler $ throwError . FoldBlocksIOException - , Handler $ throwError . FoldBlocksMuxError - ] + where + handlers = + [ Handler $ throwError . FoldBlocksIOException + , Handler $ throwError . FoldBlocksMuxError + ] -- WARNING: Do NOT use this function anywhere else except in its current call sites. -- This is a temporary work around. @@ -2061,8 +2319,9 @@ fromConsensusPoolDistr cpd = -- WARNING: Do NOT use this function anywhere else except in its current call sites. -- This is a temporary work around. toLedgerIndividualPoolStake :: Consensus.IndividualPoolStake c -> SL.IndividualPoolStake c -toLedgerIndividualPoolStake ips = SL.IndividualPoolStake { - SL.individualPoolStake = Consensus.individualPoolStake ips +toLedgerIndividualPoolStake ips = + SL.IndividualPoolStake + { SL.individualPoolStake = Consensus.individualPoolStake ips , SL.individualPoolStakeVrf = Consensus.individualPoolStakeVrf ips , SL.individualTotalPoolStake = SL.CompactCoin 0 } diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index 2cb6ca0b38..ed0fa6c33f 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -10,41 +10,42 @@ -- | Consensus modes. The node supports several different modes with different -- combinations of consensus protocols and ledger eras. --- -module Cardano.Api.Modes ( - -- * The protocols supported in each era - ConsensusProtocol, - ChainDepStateProtocol, +module Cardano.Api.Modes + ( -- * The protocols supported in each era + ConsensusProtocol + , ChainDepStateProtocol -- * Connection parameters for each mode - ConsensusModeParams(..), - Byron.EpochSlots(..), + , ConsensusModeParams (..) + , Byron.EpochSlots (..) -- * Conversions to and from types in the consensus library - ConsensusCryptoForBlock, - ConsensusBlockForEra, - toConsensusEraIndex, - fromConsensusEraIndex, - ) where - -import Cardano.Api.Eras.Core - + , ConsensusCryptoForBlock + , ConsensusBlockForEra + , toConsensusEraIndex + , fromConsensusEraIndex + ) +where + +import Cardano.Api.Eras.Core import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..)) import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) +import Data.SOP (K (K)) +import Data.SOP.Strict (NS (S, Z)) import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus -import Ouroboros.Consensus.HardFork.Combinator as Consensus (EraIndex (..), eraIndexSucc, - eraIndexZero) +import Ouroboros.Consensus.HardFork.Combinator as Consensus + ( EraIndex (..) + , eraIndexSucc + , eraIndexZero + ) import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus -import Data.SOP (K (K)) -import Data.SOP.Strict (NS (S, Z)) - -- ---------------------------------------------------------------------------- -- Consensus modes -- @@ -60,7 +61,6 @@ import Data.SOP.Strict (NS (S, Z)) -- -- It is possible in future that we may be able to eliminate this parameter by -- discovering it from the node during the initial handshake. --- data ConsensusModeParams where CardanoModeParams :: Byron.EpochSlots @@ -74,20 +74,20 @@ deriving instance Show ConsensusModeParams -- | A closed type family that maps between the consensus mode (from this API) -- and the block type used by the consensus libraries. --- - type family ConsensusBlockForEra era where - ConsensusBlockForEra ByronEra = Consensus.ByronBlock + ConsensusBlockForEra ByronEra = Consensus.ByronBlock ConsensusBlockForEra ShelleyEra = Consensus.StandardShelleyBlock ConsensusBlockForEra AllegraEra = Consensus.StandardAllegraBlock - ConsensusBlockForEra MaryEra = Consensus.StandardMaryBlock - ConsensusBlockForEra AlonzoEra = Consensus.StandardAlonzoBlock + ConsensusBlockForEra MaryEra = Consensus.StandardMaryBlock + ConsensusBlockForEra AlonzoEra = Consensus.StandardAlonzoBlock ConsensusBlockForEra BabbageEra = Consensus.StandardBabbageBlock ConsensusBlockForEra ConwayEra = Consensus.StandardConwayBlock type family ConsensusCryptoForBlock block where ConsensusCryptoForBlock Consensus.ByronBlockHFC = StandardCrypto - ConsensusCryptoForBlock (Consensus.ShelleyBlockHFC (Consensus.TPraos StandardCrypto) Consensus.StandardShelley) = Consensus.StandardShelley + ConsensusCryptoForBlock + (Consensus.ShelleyBlockHFC (Consensus.TPraos StandardCrypto) Consensus.StandardShelley) = + Consensus.StandardShelley ConsensusCryptoForBlock (Consensus.CardanoBlock StandardCrypto) = StandardCrypto type family ConsensusProtocol era where @@ -127,20 +127,22 @@ eraIndex5 = eraIndexSucc eraIndex4 eraIndex6 :: Consensus.EraIndex (x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs) eraIndex6 = eraIndexSucc eraIndex5 -toConsensusEraIndex :: () +toConsensusEraIndex + :: () => Consensus.CardanoBlock L.StandardCrypto ~ Consensus.HardForkBlock xs => CardanoEra era -> Consensus.EraIndex xs toConsensusEraIndex = \case - ByronEra -> eraIndex0 - ShelleyEra -> eraIndex1 - AllegraEra -> eraIndex2 - MaryEra -> eraIndex3 - AlonzoEra -> eraIndex4 - BabbageEra -> eraIndex5 - ConwayEra -> eraIndex6 - -fromConsensusEraIndex :: () + ByronEra -> eraIndex0 + ShelleyEra -> eraIndex1 + AllegraEra -> eraIndex2 + MaryEra -> eraIndex3 + AlonzoEra -> eraIndex4 + BabbageEra -> eraIndex5 + ConwayEra -> eraIndex6 + +fromConsensusEraIndex + :: () => Consensus.EraIndex (Consensus.CardanoEras StandardCrypto) -> AnyCardanoEra fromConsensusEraIndex = \case diff --git a/cardano-api/internal/Cardano/Api/Monad/Error.hs b/cardano-api/internal/Cardano/Api/Monad/Error.hs index 919b941b65..49a092e2a5 100644 --- a/cardano-api/internal/Cardano/Api/Monad/Error.hs +++ b/cardano-api/internal/Cardano/Api/Monad/Error.hs @@ -2,10 +2,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{- | This module serves purpose as a single source of abstractions used in handling 'MonadError' and -'ExceptT' through 'cardano-api'. --} - +-- | This module serves purpose as a single source of abstractions used in handling 'MonadError' and +-- 'ExceptT' through 'cardano-api'. module Cardano.Api.Monad.Error ( MonadTransError , MonadIOTransError @@ -15,28 +13,40 @@ module Cardano.Api.Monad.Error , handleIOExceptionsLiftWith , hoistIOEither , liftMaybe - , module Control.Monad.Except , module Control.Monad.IO.Class , module Control.Monad.Trans.Class , module Control.Monad.Trans.Except , module Control.Monad.Trans.Except.Extra - ) where + ) +where -import Control.Exception.Safe -import Control.Monad.Except (ExceptT (..), MonadError (..), catchError, liftEither, - mapExcept, mapExceptT, runExcept, runExceptT, withExcept) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Except.Extra -import Data.Bifunctor (first) +import Control.Exception.Safe +import Control.Monad.Except + ( ExceptT (..) + , MonadError (..) + , catchError + , liftEither + , mapExcept + , mapExceptT + , runExcept + , runExceptT + , withExcept + ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Except.Extra +import Data.Bifunctor (first) -- | Convenience alias type MonadTransError e t m = (Monad m, MonadTrans t, MonadError e (t m)) + -- + -- | Same as 'MonadTransError', but with also 'MonadIO' constraint -type MonadIOTransError e t m = (MonadIO m, MonadIO (t m), MonadCatch m, MonadTrans t, MonadError e (t m)) +type MonadIOTransError e t m = + (MonadIO m, MonadIO (t m), MonadCatch m, MonadTrans t, MonadError e (t m)) -- | Modify an 'ExceptT' error and lift it to 'MonadError' transformer stack. -- @@ -52,9 +62,12 @@ type MonadIOTransError e t m = (MonadIO m, MonadIO (t m), MonadCatch m, MonadTra -- This function avoids that, but at the cost of limiting its application to transformers. modifyError :: MonadTransError e' t m - => (e -> e') -- ^ mapping function - -> ExceptT e m a -- ^ value - -> t m a -- ^ result with modified error + => (e -> e') + -- ^ mapping function + -> ExceptT e m a + -- ^ value + -> t m a + -- ^ result with modified error modifyError f m = lift (runExceptT m) >>= either (throwError . f) pure -- | Wrap an exception and lift it into 'MonadError'. @@ -62,36 +75,45 @@ handleIOExceptionsWith :: MonadError e' m => MonadCatch m => Exception e - => (e -> e') -- ^ mapping function - -> m a -- ^ action that can throw - -> m a -- ^ result with caught exception + => (e -> e') + -- ^ mapping function + -> m a + -- ^ action that can throw + -> m a + -- ^ result with caught exception handleIOExceptionsWith f act = liftEither . first f =<< try act -- | Wrap an exception and lift it into 'MonadError' stack. handleIOExceptionsLiftWith :: MonadIOTransError e' t m => Exception e - => (e -> e') -- ^ mapping function - -> m a -- ^ action that can throw - -> t m a -- ^ action with caught error lifted into 'MonadError' stack + => (e -> e') + -- ^ mapping function + -> m a + -- ^ action that can throw + -> t m a + -- ^ action with caught error lifted into 'MonadError' stack handleIOExceptionsLiftWith f act = liftEither =<< lift (first f <$> try act) -- | Lift 'ExceptT' into 'MonadTransError' -liftExceptT :: MonadTransError e t m - => ExceptT e m a - -> t m a +liftExceptT + :: MonadTransError e t m + => ExceptT e m a + -> t m a liftExceptT = modifyError id - -- | Lift an 'IO' action that returns 'Either' into 'MonadIOTransError' -hoistIOEither :: MonadIOTransError e t m - => IO (Either e a) - -> t m a +hoistIOEither + :: MonadIOTransError e t m + => IO (Either e a) + -> t m a hoistIOEither = liftExceptT . ExceptT . liftIO -- | Lift 'Maybe' into 'MonadError' -liftMaybe :: MonadError e m - => e -- ^ Error to throw, if 'Nothing' - -> Maybe a - -> m a +liftMaybe + :: MonadError e m + => e + -- ^ Error to throw, if 'Nothing' + -> Maybe a + -> m a liftMaybe e = maybe (throwError e) pure diff --git a/cardano-api/internal/Cardano/Api/NetworkId.hs b/cardano-api/internal/Cardano/Api/NetworkId.hs index 3b96dfcf7b..99cc43ea69 100644 --- a/cardano-api/internal/Cardano/Api/NetworkId.hs +++ b/cardano-api/internal/Cardano/Api/NetworkId.hs @@ -1,52 +1,54 @@ -- | The 'NetworkId' type and related functions --- -module Cardano.Api.NetworkId ( - -- * Network types - NetworkId(..), - NetworkMagic(..), - fromNetworkMagic, - toNetworkMagic, - mainnetNetworkMagic, +module Cardano.Api.NetworkId + ( -- * Network types + NetworkId (..) + , NetworkMagic (..) + , fromNetworkMagic + , toNetworkMagic + , mainnetNetworkMagic -- * Internal conversion functions - toByronProtocolMagicId, - toByronNetworkMagic, - toByronRequiresNetworkMagic, - toShelleyNetwork, - fromShelleyNetwork, - ) where + , toByronProtocolMagicId + , toByronNetworkMagic + , toByronRequiresNetworkMagic + , toShelleyNetwork + , fromShelleyNetwork + ) +where import qualified Cardano.Chain.Common as Byron (NetworkMagic (..)) import qualified Cardano.Chain.Genesis as Byron (mainnetProtocolMagicId) -import qualified Cardano.Crypto.ProtocolMagic as Byron (ProtocolMagicId (..), - RequiresNetworkMagic (..)) +import qualified Cardano.Crypto.ProtocolMagic as Byron + ( ProtocolMagicId (..) + , RequiresNetworkMagic (..) + ) import qualified Cardano.Ledger.BaseTypes as Shelley (Network (..)) -import Ouroboros.Network.Magic (NetworkMagic (..)) - +import Ouroboros.Network.Magic (NetworkMagic (..)) -- ---------------------------------------------------------------------------- -- NetworkId type -- -data NetworkId = Mainnet - | Testnet !NetworkMagic +data NetworkId + = Mainnet + | Testnet !NetworkMagic deriving (Eq, Show) fromNetworkMagic :: NetworkMagic -> NetworkId fromNetworkMagic nm = if nm == mainnetNetworkMagic - then Mainnet - else Testnet nm + then Mainnet + else Testnet nm toNetworkMagic :: NetworkId -> NetworkMagic toNetworkMagic (Testnet nm) = nm -toNetworkMagic Mainnet = mainnetNetworkMagic +toNetworkMagic Mainnet = mainnetNetworkMagic mainnetNetworkMagic :: NetworkMagic -mainnetNetworkMagic = NetworkMagic - . Byron.unProtocolMagicId - $ Byron.mainnetProtocolMagicId - +mainnetNetworkMagic = + NetworkMagic + . Byron.unProtocolMagicId + $ Byron.mainnetProtocolMagicId -- ---------------------------------------------------------------------------- -- Byron conversion functions @@ -57,20 +59,19 @@ toByronProtocolMagicId Mainnet = Byron.mainnetProtocolMagicId toByronProtocolMagicId (Testnet (NetworkMagic pm)) = Byron.ProtocolMagicId pm toByronNetworkMagic :: NetworkId -> Byron.NetworkMagic -toByronNetworkMagic Mainnet = Byron.NetworkMainOrStage +toByronNetworkMagic Mainnet = Byron.NetworkMainOrStage toByronNetworkMagic (Testnet (NetworkMagic nm)) = Byron.NetworkTestnet nm toByronRequiresNetworkMagic :: NetworkId -> Byron.RequiresNetworkMagic -toByronRequiresNetworkMagic Mainnet = Byron.RequiresNoMagic -toByronRequiresNetworkMagic Testnet{} = Byron.RequiresMagic - +toByronRequiresNetworkMagic Mainnet = Byron.RequiresNoMagic +toByronRequiresNetworkMagic Testnet {} = Byron.RequiresMagic -- ---------------------------------------------------------------------------- -- Shelley conversion functions -- toShelleyNetwork :: NetworkId -> Shelley.Network -toShelleyNetwork Mainnet = Shelley.Mainnet +toShelleyNetwork Mainnet = Shelley.Mainnet toShelleyNetwork (Testnet _) = Shelley.Testnet fromShelleyNetwork :: Shelley.Network -> NetworkMagic -> NetworkId @@ -78,4 +79,3 @@ fromShelleyNetwork Shelley.Testnet nm = Testnet nm fromShelleyNetwork Shelley.Mainnet nm | nm == mainnetNetworkMagic = Mainnet | otherwise = error "fromShelleyNetwork Mainnet: wrong mainnet network magic" - diff --git a/cardano-api/internal/Cardano/Api/OperationalCertificate.hs b/cardano-api/internal/Cardano/Api/OperationalCertificate.hs index 2b7861fe69..8c066415f4 100644 --- a/cardano-api/internal/Cardano/Api/OperationalCertificate.hs +++ b/cardano-api/internal/Cardano/Api/OperationalCertificate.hs @@ -3,155 +3,168 @@ {-# LANGUAGE TypeFamilies #-} -- | Operational certificates --- -module Cardano.Api.OperationalCertificate ( - OperationalCertificate(..), - OperationalCertificateIssueCounter(..), - Shelley.KESPeriod(..), - OperationalCertIssueError(..), - getHotKey, - getKesPeriod, - getOpCertCount, - issueOperationalCertificate, +module Cardano.Api.OperationalCertificate + ( OperationalCertificate (..) + , OperationalCertificateIssueCounter (..) + , Shelley.KESPeriod (..) + , OperationalCertIssueError (..) + , getHotKey + , getKesPeriod + , getOpCertCount + , issueOperationalCertificate -- * Data family instances - AsType(..) - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Class -import Cardano.Api.Keys.Praos -import Cardano.Api.Keys.Shelley -import Cardano.Api.ProtocolParameters -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.Tx.Sign - -import Cardano.Ledger.Crypto (StandardCrypto) + , AsType (..) + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Class +import Cardano.Api.Keys.Praos +import Cardano.Api.Keys.Shelley +import Cardano.Api.ProtocolParameters +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.Tx.Sign +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Protocol.TPraos.OCert as Shelley - -import Data.Word +import Data.Word -- ---------------------------------------------------------------------------- -- Operational certificates -- -data OperationalCertificate = - OperationalCertificate - !(Shelley.OCert StandardCrypto) - !(VerificationKey StakePoolKey) +data OperationalCertificate + = OperationalCertificate + !(Shelley.OCert StandardCrypto) + !(VerificationKey StakePoolKey) deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) -data OperationalCertificateIssueCounter = - OperationalCertificateIssueCounter - { opCertIssueCount :: !Word64 - , opCertIssueColdKey :: !(VerificationKey StakePoolKey) -- For consistency checking - } +data OperationalCertificateIssueCounter + = OperationalCertificateIssueCounter + { opCertIssueCount :: !Word64 + , opCertIssueColdKey :: !(VerificationKey StakePoolKey) -- For consistency checking + } deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance ToCBOR OperationalCertificate where - toCBOR (OperationalCertificate ocert vkey) = - toCBOR (ocert, vkey) + toCBOR (OperationalCertificate ocert vkey) = + toCBOR (ocert, vkey) instance FromCBOR OperationalCertificate where - fromCBOR = do - (ocert, vkey) <- fromCBOR - return (OperationalCertificate ocert vkey) + fromCBOR = do + (ocert, vkey) <- fromCBOR + return (OperationalCertificate ocert vkey) instance ToCBOR OperationalCertificateIssueCounter where - toCBOR (OperationalCertificateIssueCounter counter vkey) = - toCBOR (counter, vkey) + toCBOR (OperationalCertificateIssueCounter counter vkey) = + toCBOR (counter, vkey) instance FromCBOR OperationalCertificateIssueCounter where - fromCBOR = do - (counter, vkey) <- fromCBOR - return (OperationalCertificateIssueCounter counter vkey) + fromCBOR = do + (counter, vkey) <- fromCBOR + return (OperationalCertificateIssueCounter counter vkey) instance HasTypeProxy OperationalCertificate where - data AsType OperationalCertificate = AsOperationalCertificate - proxyToAsType _ = AsOperationalCertificate + data AsType OperationalCertificate = AsOperationalCertificate + proxyToAsType _ = AsOperationalCertificate instance HasTypeProxy OperationalCertificateIssueCounter where - data AsType OperationalCertificateIssueCounter = AsOperationalCertificateIssueCounter - proxyToAsType _ = AsOperationalCertificateIssueCounter + data AsType OperationalCertificateIssueCounter = AsOperationalCertificateIssueCounter + proxyToAsType _ = AsOperationalCertificateIssueCounter instance HasTextEnvelope OperationalCertificate where - textEnvelopeType _ = "NodeOperationalCertificate" + textEnvelopeType _ = "NodeOperationalCertificate" instance HasTextEnvelope OperationalCertificateIssueCounter where - textEnvelopeType _ = "NodeOperationalCertificateIssueCounter" - -data OperationalCertIssueError = - -- | The stake pool verification key expected for the - -- 'OperationalCertificateIssueCounter' does not match the signing key - -- supplied for signing. - -- - -- Order: pool vkey expected, pool skey supplied - -- - OperationalCertKeyMismatch (VerificationKey StakePoolKey) - (VerificationKey StakePoolKey) - deriving Show + textEnvelopeType _ = "NodeOperationalCertificateIssueCounter" + +data OperationalCertIssueError + = -- | The stake pool verification key expected for the + -- 'OperationalCertificateIssueCounter' does not match the signing key + -- supplied for signing. + -- + -- Order: pool vkey expected, pool skey supplied + OperationalCertKeyMismatch + (VerificationKey StakePoolKey) + (VerificationKey StakePoolKey) + deriving (Show) instance Error OperationalCertIssueError where prettyError (OperationalCertKeyMismatch _counterKey _signingKey) = "Key mismatch: the signing key does not match the one that goes with the counter" - --TODO: include key ids - -issueOperationalCertificate :: VerificationKey KesKey - -> Either (SigningKey StakePoolKey) - (SigningKey GenesisDelegateExtendedKey) - --TODO: this may be better with a type that - -- captured the three (four?) choices, stake pool - -- or genesis delegate, extended or normal. - -> Shelley.KESPeriod - -> OperationalCertificateIssueCounter - -> Either OperationalCertIssueError - (OperationalCertificate, - OperationalCertificateIssueCounter) -issueOperationalCertificate (KesVerificationKey kesVKey) - skey - kesPeriod - (OperationalCertificateIssueCounter counter poolVKey) - | poolVKey /= poolVKey' - = Left (OperationalCertKeyMismatch poolVKey poolVKey') - - | otherwise - = Right (OperationalCertificate ocert poolVKey, - OperationalCertificateIssueCounter (succ counter) poolVKey) - where + +-- TODO: include key ids + +issueOperationalCertificate + :: VerificationKey KesKey + -> Either + (SigningKey StakePoolKey) + (SigningKey GenesisDelegateExtendedKey) + -- TODO: this may be better with a type that + -- captured the three (four?) choices, stake pool + -- or genesis delegate, extended or normal. + -> Shelley.KESPeriod + -> OperationalCertificateIssueCounter + -> Either + OperationalCertIssueError + ( OperationalCertificate + , OperationalCertificateIssueCounter + ) +issueOperationalCertificate + (KesVerificationKey kesVKey) + skey + kesPeriod + (OperationalCertificateIssueCounter counter poolVKey) + | poolVKey /= poolVKey' = + Left (OperationalCertKeyMismatch poolVKey poolVKey') + | otherwise = + Right + ( OperationalCertificate ocert poolVKey + , OperationalCertificateIssueCounter (succ counter) poolVKey + ) + where poolVKey' :: VerificationKey StakePoolKey poolVKey' = either getVerificationKey (convert . getVerificationKey) skey - where - convert :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey StakePoolKey - convert = (castVerificationKey :: VerificationKey GenesisDelegateKey - -> VerificationKey StakePoolKey) - . (castVerificationKey :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey GenesisDelegateKey) - - ocert :: Shelley.OCert StandardCrypto - ocert = Shelley.OCert kesVKey counter kesPeriod signature - - signature :: Shelley.SignedDSIGN - StandardCrypto - (Shelley.OCertSignable StandardCrypto) - signature = makeShelleySignature - (Shelley.OCertSignable kesVKey counter kesPeriod) - skey' - where - skey' :: ShelleySigningKey - skey' = case skey of - Left (StakePoolSigningKey poolSKey) -> - ShelleyNormalSigningKey poolSKey - Right (GenesisDelegateExtendedSigningKey delegSKey) -> - ShelleyExtendedSigningKey delegSKey + where + convert + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey StakePoolKey + convert = + ( castVerificationKey + :: VerificationKey GenesisDelegateKey + -> VerificationKey StakePoolKey + ) + . ( castVerificationKey + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey GenesisDelegateKey + ) + + ocert :: Shelley.OCert StandardCrypto + ocert = Shelley.OCert kesVKey counter kesPeriod signature + + signature + :: Shelley.SignedDSIGN + StandardCrypto + (Shelley.OCertSignable StandardCrypto) + signature = + makeShelleySignature + (Shelley.OCertSignable kesVKey counter kesPeriod) + skey' + where + skey' :: ShelleySigningKey + skey' = case skey of + Left (StakePoolSigningKey poolSKey) -> + ShelleyNormalSigningKey poolSKey + Right (GenesisDelegateExtendedSigningKey delegSKey) -> + ShelleyExtendedSigningKey delegSKey getHotKey :: OperationalCertificate -> VerificationKey KesKey getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index dcac5f67a3..2df04691d1 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -11,25 +11,23 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} module Cardano.Api.Orphans () where -import Cardano.Api.Pretty (Pretty (..), prettyException, (<+>)) -import Cardano.Api.Via.ShowOf - -import Cardano.Binary (DecoderError (..)) +import Cardano.Api.Pretty (Pretty (..), prettyException, (<+>)) +import Cardano.Api.Via.ShowOf +import Cardano.Binary (DecoderError (..)) import qualified Cardano.Chain.Byron.API as L import qualified Cardano.Chain.Common as L import qualified Cardano.Chain.Delegation.Validation.Scheduling as L.Scheduling +import qualified Cardano.Chain.UTxO.UTxO as L +import qualified Cardano.Chain.UTxO.Validation as L import qualified Cardano.Chain.Update as L import qualified Cardano.Chain.Update.Validation.Endorsement as L.Endorsement import qualified Cardano.Chain.Update.Validation.Interface as L.Interface import qualified Cardano.Chain.Update.Validation.Registration as L.Registration import qualified Cardano.Chain.Update.Validation.Voting as L.Voting -import qualified Cardano.Chain.UTxO.UTxO as L -import qualified Cardano.Chain.UTxO.Validation as L import qualified Cardano.Ledger.Allegra.Rules as L import qualified Cardano.Ledger.Alonzo.PParams as Ledger import qualified Cardano.Ledger.Alonzo.Rules as L @@ -37,21 +35,21 @@ import qualified Cardano.Ledger.Alonzo.Tx as L import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage.PParams as Ledger import qualified Cardano.Ledger.Babbage.Rules as L -import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) +import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Binary +import Cardano.Ledger.Binary import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.PParams as Ledger import qualified Cardano.Ledger.Conway.Rules as L import qualified Cardano.Ledger.Conway.TxCert as L import qualified Cardano.Ledger.Core as L -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Crypto as CC (Crypto) import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.Crypto as L -import Cardano.Ledger.HKD (NoUpdate (..)) +import Cardano.Ledger.HKD (NoUpdate (..)) import qualified Cardano.Ledger.Keys as L.Keys import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.Shelley.API.Mempool as L @@ -60,95 +58,127 @@ import qualified Cardano.Ledger.Shelley.Rules as L import qualified Cardano.Ledger.Shelley.TxBody as L import qualified Cardano.Ledger.Shelley.TxCert as L import qualified Cardano.Protocol.TPraos.API as Ledger -import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) +import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) import qualified Cardano.Protocol.TPraos.Rules.Prtcl as L import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger -import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) -import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) -import Ouroboros.Consensus.Protocol.Praos (PraosState) -import qualified Ouroboros.Consensus.Protocol.Praos as Consensus -import Ouroboros.Consensus.Protocol.TPraos (TPraosState) -import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import qualified Ouroboros.Consensus.Shelley.Eras as Consensus -import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..)) -import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus -import Ouroboros.Network.Block (HeaderHash, Tip (..)) -import Ouroboros.Network.Mux (MuxError) - import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.CBOR.Read as CBOR -import Data.Aeson (KeyValue ((.=)), ToJSON (..), ToJSONKey (..), object, pairs) +import Data.Aeson (KeyValue ((.=)), ToJSON (..), ToJSONKey (..), object, pairs) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Short as SBS -import Data.Data (Data) -import Data.Kind (Constraint, Type) -import Data.Maybe.Strict (StrictMaybe (..)) -import Data.Monoid +import Data.Data (Data) +import Data.Kind (Constraint, Type) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Monoid import qualified Data.Text.Encoding as Text -import Data.Typeable (Typeable) -import GHC.Generics -import GHC.Stack (HasCallStack) -import GHC.TypeLits -import Lens.Micro +import Data.Typeable (Typeable) +import GHC.Generics +import GHC.Stack (HasCallStack) +import GHC.TypeLits +import Lens.Micro +import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) +import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) +import Ouroboros.Consensus.Protocol.Praos (PraosState) +import qualified Ouroboros.Consensus.Protocol.Praos as Consensus +import Ouroboros.Consensus.Protocol.TPraos (TPraosState) +import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus +import qualified Ouroboros.Consensus.Shelley.Eras as Consensus +import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..)) +import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus +import Ouroboros.Network.Block (HeaderHash, Tip (..)) +import Ouroboros.Network.Mux (MuxError) deriving instance Generic (L.ApplyTxError era) + deriving instance Generic (L.Registration.TooLarge a) + deriving instance Generic L.ApplicationNameError + deriving instance Generic L.ApplyMempoolPayloadErr + deriving instance Generic L.Endorsement.Error + deriving instance Generic L.Interface.Error + deriving instance Generic L.LovelaceError + deriving instance Generic L.Registration.Adopted + deriving instance Generic L.Registration.Error + deriving instance Generic L.Scheduling.Error + deriving instance Generic L.SoftwareVersionError + deriving instance Generic L.SystemTagError + deriving instance Generic L.TxValidationError + deriving instance Generic L.UTxOError + deriving instance Generic L.UTxOValidationError + deriving instance Generic L.Voting.Error deriving anyclass instance ToJSON L.ApplicationNameError + deriving anyclass instance ToJSON L.ApplyMempoolPayloadErr + deriving anyclass instance ToJSON L.Endorsement.Error + deriving anyclass instance ToJSON L.Interface.Error + deriving anyclass instance ToJSON L.LovelaceError + deriving anyclass instance ToJSON L.Registration.Adopted + deriving anyclass instance ToJSON L.Registration.ApplicationVersion + deriving anyclass instance ToJSON L.Registration.Error + deriving anyclass instance ToJSON L.Scheduling.Error + deriving anyclass instance ToJSON L.SoftwareVersionError + deriving anyclass instance ToJSON L.SystemTagError + deriving anyclass instance ToJSON L.TxValidationError + deriving anyclass instance ToJSON L.UTxOError + deriving anyclass instance ToJSON L.UTxOValidationError + deriving anyclass instance ToJSON L.Voting.Error -deriving anyclass instance ToJSON L.VotingPeriod +deriving anyclass instance ToJSON L.VotingPeriod deriving anyclass instance ( ToJSON (L.PredicateFailure (L.EraRule "UTXOW" ledgerera)) , ToJSON (L.PredicateFailure (L.EraRule "DELEGS" ledgerera)) - ) => ToJSON (L.ShelleyLedgerPredFailure ledgerera) + ) + => ToJSON (L.ShelleyLedgerPredFailure ledgerera) deriving anyclass instance ( L.Crypto (L.EraCrypto ledgerera) , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) - ) => ToJSON (L.ShelleyUtxowPredFailure ledgerera) + ) + => ToJSON (L.ShelleyUtxowPredFailure ledgerera) deriving anyclass instance ( L.Crypto (L.EraCrypto ledgerera) , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) - ) => ToJSON (L.ShelleyPpupPredFailure ledgerera) + ) + => ToJSON (L.ShelleyPpupPredFailure ledgerera) deriving anyclass instance ( L.Crypto (L.EraCrypto ledgerera) , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) , ToJSON (L.PlutusPurpose L.AsItem ledgerera) , ToJSON (L.PlutusPurpose L.AsIx ledgerera) - ) => ToJSON (L.AlonzoUtxowPredFailure ledgerera) + ) + => ToJSON (L.AlonzoUtxowPredFailure ledgerera) deriving anyclass instance ( L.Crypto (L.EraCrypto ledgerera) @@ -156,30 +186,60 @@ deriving anyclass instance , ToJSON (L.TxCert ledgerera) , ToJSON (L.PlutusPurpose L.AsItem ledgerera) , ToJSON (L.PlutusPurpose L.AsIx ledgerera) - ) => ToJSON (L.BabbageUtxowPredFailure ledgerera) + ) + => ToJSON (L.BabbageUtxowPredFailure ledgerera) deriving anyclass instance - ( ToJSON (L.PredicateFailure (L.EraRule "LEDGER" ledgerera)) - ) => ToJSON (L.ApplyTxError ledgerera) - -deriving via ShowOf (L.Keys.VKey L.Keys.Witness c) instance L.Crypto c => ToJSON (L.Keys.VKey L.Keys.Witness c) - -deriving via ShowOf (L.AllegraUtxoPredFailure ledgerera) instance Show (L.AllegraUtxoPredFailure ledgerera) => ToJSON (L.AllegraUtxoPredFailure ledgerera) -deriving via ShowOf (L.AlonzoUtxoPredFailure ledgerera) instance Show (L.AlonzoUtxoPredFailure ledgerera) => ToJSON (L.AlonzoUtxoPredFailure ledgerera) -deriving via ShowOf (L.BabbageUtxoPredFailure ledgerera) instance Show (L.BabbageUtxoPredFailure ledgerera) => ToJSON (L.BabbageUtxoPredFailure ledgerera) -deriving via ShowOf (L.ConwayLedgerPredFailure ledgerera) instance Show (L.ConwayLedgerPredFailure ledgerera) => ToJSON (L.ConwayLedgerPredFailure ledgerera) -deriving via ShowOf (L.ShelleyDelegsPredFailure ledgerera) instance Show (L.ShelleyDelegsPredFailure ledgerera) => ToJSON (L.ShelleyDelegsPredFailure ledgerera) -deriving via ShowOf (L.ShelleyUtxoPredFailure ledgerera) instance Show (L.ShelleyUtxoPredFailure ledgerera) => ToJSON (L.ShelleyUtxoPredFailure ledgerera) + ToJSON (L.PredicateFailure (L.EraRule "LEDGER" ledgerera)) + => ToJSON (L.ApplyTxError ledgerera) + +deriving via + ShowOf (L.Keys.VKey L.Keys.Witness c) + instance + L.Crypto c => ToJSON (L.Keys.VKey L.Keys.Witness c) + +deriving via + ShowOf (L.AllegraUtxoPredFailure ledgerera) + instance + Show (L.AllegraUtxoPredFailure ledgerera) => ToJSON (L.AllegraUtxoPredFailure ledgerera) + +deriving via + ShowOf (L.AlonzoUtxoPredFailure ledgerera) + instance + Show (L.AlonzoUtxoPredFailure ledgerera) => ToJSON (L.AlonzoUtxoPredFailure ledgerera) + +deriving via + ShowOf (L.BabbageUtxoPredFailure ledgerera) + instance + Show (L.BabbageUtxoPredFailure ledgerera) => ToJSON (L.BabbageUtxoPredFailure ledgerera) + +deriving via + ShowOf (L.ConwayLedgerPredFailure ledgerera) + instance + Show (L.ConwayLedgerPredFailure ledgerera) => ToJSON (L.ConwayLedgerPredFailure ledgerera) + +deriving via + ShowOf (L.ShelleyDelegsPredFailure ledgerera) + instance + Show (L.ShelleyDelegsPredFailure ledgerera) => ToJSON (L.ShelleyDelegsPredFailure ledgerera) + +deriving via + ShowOf (L.ShelleyUtxoPredFailure ledgerera) + instance + Show (L.ShelleyUtxoPredFailure ledgerera) => ToJSON (L.ShelleyUtxoPredFailure ledgerera) deriving instance ToJSON a => ToJSON (L.Registration.TooLarge a) -deriving via ShowOf L.KeyHash instance ToJSON L.KeyHash +deriving via ShowOf L.KeyHash instance ToJSON L.KeyHash deriving via ShowOf L.ApplicationName instance ToJSONKey L.ApplicationName deriving instance Data DecoderError + deriving instance Data CBOR.DeserialiseFailure + deriving instance Data Bech32.DecodingError + deriving instance Data Bech32.CharPosition -- | These instances originally existed on the Lovelace type. @@ -189,8 +249,11 @@ deriving instance Data Bech32.CharPosition -- L.Coin but be aware that not all uses of these typeclasses -- are valid. deriving newtype instance Real L.Coin + deriving newtype instance Integral L.Coin + deriving newtype instance Num L.Coin + instance Pretty L.Coin where pretty (L.Coin n) = pretty n <+> "Lovelace" @@ -201,19 +264,22 @@ instance Crypto.Crypto crypto => ToJSON (Consensus.StakeSnapshots crypto) where toJSON = object . stakeSnapshotsToPair toEncoding = pairs . mconcat . stakeSnapshotsToPair -stakeSnapshotsToPair :: (Aeson.KeyValue e a, Crypto.Crypto crypto) => Consensus.StakeSnapshots crypto -> [a] -stakeSnapshotsToPair Consensus.StakeSnapshots +stakeSnapshotsToPair + :: (Aeson.KeyValue e a, Crypto.Crypto crypto) => Consensus.StakeSnapshots crypto -> [a] +stakeSnapshotsToPair + Consensus.StakeSnapshots { Consensus.ssStakeSnapshots , Consensus.ssMarkTotal , Consensus.ssSetTotal , Consensus.ssGoTotal } = [ "pools" .= ssStakeSnapshots - , "total" .= object - [ "stakeMark" .= ssMarkTotal - , "stakeSet" .= ssSetTotal - , "stakeGo" .= ssGoTotal - ] + , "total" + .= object + [ "stakeMark" .= ssMarkTotal + , "stakeSet" .= ssSetTotal + , "stakeGo" .= ssGoTotal + ] ] instance ToJSON (Consensus.StakeSnapshot crypto) where @@ -221,7 +287,8 @@ instance ToJSON (Consensus.StakeSnapshot crypto) where toEncoding = pairs . mconcat . stakeSnapshotToPair stakeSnapshotToPair :: Aeson.KeyValue e a => Consensus.StakeSnapshot crypto -> [a] -stakeSnapshotToPair Consensus.StakeSnapshot +stakeSnapshotToPair + Consensus.StakeSnapshot { Consensus.ssMarkPool , Consensus.ssSetPool , Consensus.ssGoPool @@ -232,23 +299,24 @@ stakeSnapshotToPair Consensus.StakeSnapshot ] instance ToJSON (OneEraHash xs) where - toJSON = toJSON - . Text.decodeLatin1 - . Base16.encode - . SBS.fromShort - . getOneEraHash + toJSON = + toJSON + . Text.decodeLatin1 + . Base16.encode + . SBS.fromShort + . getOneEraHash deriving newtype instance ToJSON ByronHash -- This instance is temporarily duplicated in cardano-config instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where - toJSON TipGenesis = Aeson.object [ "genesis" .= True ] + toJSON TipGenesis = Aeson.object ["genesis" .= True] toJSON (Tip slotNo headerHash blockNo) = Aeson.object - [ "slotNo" .= slotNo + [ "slotNo" .= slotNo , "headerHash" .= headerHash - , "blockNo" .= blockNo + , "blockNo" .= blockNo ] -- @@ -256,30 +324,33 @@ instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where -- deriving newtype instance CC.Crypto crypto => ToJSON (ShelleyHash crypto) + deriving newtype instance CC.Crypto crypto => ToJSON (HashHeader crypto) deriving instance ToJSON (Ledger.PrtclState StandardCrypto) + deriving instance ToJSON Ledger.TicknState + deriving instance ToJSON (Ledger.ChainDepState StandardCrypto) instance ToJSON (TPraosState StandardCrypto) where - toJSON s = Aeson.object - [ "lastSlot" .= Consensus.tpraosStateLastSlot s - , "chainDepState" .= Consensus.tpraosStateChainDepState s - ] + toJSON s = + Aeson.object + [ "lastSlot" .= Consensus.tpraosStateLastSlot s + , "chainDepState" .= Consensus.tpraosStateChainDepState s + ] instance ToJSON (PraosState StandardCrypto) where - toJSON s = Aeson.object - [ "lastSlot" .= Consensus.praosStateLastSlot s - , "oCertCounters" .= Consensus.praosStateOCertCounters s - , "evolvingNonce" .= Consensus.praosStateEvolvingNonce s - , "candidateNonce" .= Consensus.praosStateCandidateNonce s - , "epochNonce" .= Consensus.praosStateEpochNonce s - , "labNonce" .= Consensus.praosStateLabNonce s - , "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s - ] - - + toJSON s = + Aeson.object + [ "lastSlot" .= Consensus.praosStateLastSlot s + , "oCertCounters" .= Consensus.praosStateOCertCounters s + , "evolvingNonce" .= Consensus.praosStateEvolvingNonce s + , "candidateNonce" .= Consensus.praosStateCandidateNonce s + , "epochNonce" .= Consensus.praosStateEpochNonce s + , "labNonce" .= Consensus.praosStateLabNonce s + , "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s + ] -- We wrap the individual records with Last and use Last's Semigroup instance. -- In this instance we take the last 'Just' value or the only 'Just' value @@ -302,25 +373,25 @@ instance Semigroup (Ledger.ShelleyPParams StrictMaybe era) where fsppProtocolVersion = lastMappendWith Ledger.sppProtocolVersion pp1 pp2 fsppMinUTxOValue = lastMappendWith Ledger.sppMinUTxOValue pp1 pp2 fsppMinPoolCost = lastMappendWith Ledger.sppMinPoolCost pp1 pp2 - in Ledger.ShelleyPParams - { Ledger.sppMinFeeA = fsppMinFeeA - , Ledger.sppMinFeeB = fsppMinFeeB - , Ledger.sppMaxBBSize = fsppMaxBBSize - , Ledger.sppMaxTxSize = fsppMaxTxSize - , Ledger.sppMaxBHSize = fsppMaxBHSize - , Ledger.sppKeyDeposit = fsppKeyDeposit - , Ledger.sppPoolDeposit = fsppPoolDeposit - , Ledger.sppEMax = fsppEMax - , Ledger.sppNOpt = fsppNOpt - , Ledger.sppA0 = fsppA0 - , Ledger.sppRho = fsppRho - , Ledger.sppTau = fsppTau - , Ledger.sppD = fsppD - , Ledger.sppExtraEntropy = fsppExtraEntropy - , Ledger.sppProtocolVersion = fsppProtocolVersion - , Ledger.sppMinUTxOValue = fsppMinUTxOValue - , Ledger.sppMinPoolCost = fsppMinPoolCost - } + in Ledger.ShelleyPParams + { Ledger.sppMinFeeA = fsppMinFeeA + , Ledger.sppMinFeeB = fsppMinFeeB + , Ledger.sppMaxBBSize = fsppMaxBBSize + , Ledger.sppMaxTxSize = fsppMaxTxSize + , Ledger.sppMaxBHSize = fsppMaxBHSize + , Ledger.sppKeyDeposit = fsppKeyDeposit + , Ledger.sppPoolDeposit = fsppPoolDeposit + , Ledger.sppEMax = fsppEMax + , Ledger.sppNOpt = fsppNOpt + , Ledger.sppA0 = fsppA0 + , Ledger.sppRho = fsppRho + , Ledger.sppTau = fsppTau + , Ledger.sppD = fsppD + , Ledger.sppExtraEntropy = fsppExtraEntropy + , Ledger.sppProtocolVersion = fsppProtocolVersion + , Ledger.sppMinUTxOValue = fsppMinUTxOValue + , Ledger.sppMinPoolCost = fsppMinPoolCost + } instance Semigroup (Ledger.AlonzoPParams StrictMaybe era) where (<>) p1 p2 = @@ -348,32 +419,32 @@ instance Semigroup (Ledger.AlonzoPParams StrictMaybe era) where fappMaxValSize = lastMappendWith Ledger.appMaxValSize p1 p2 fappCollateralPercentage = lastMappendWith Ledger.appCollateralPercentage p1 p2 fappMaxCollateralInputs = lastMappendWith Ledger.appMaxCollateralInputs p1 p2 - in Ledger.AlonzoPParams - { Ledger.appMinFeeA = fappMinFeeA - , Ledger.appMinFeeB = fappMinFeeB - , Ledger.appMaxBBSize = fappMaxBBSize - , Ledger.appMaxTxSize = fappMaxTxSize - , Ledger.appMaxBHSize = fappMaxBHSize - , Ledger.appKeyDeposit = fappKeyDeposit - , Ledger.appPoolDeposit = fappPoolDeposit - , Ledger.appEMax = fappEMax - , Ledger.appNOpt = fappNOpt - , Ledger.appA0 = fappA0 - , Ledger.appRho = fappRho - , Ledger.appTau = fappTau - , Ledger.appD = fappD - , Ledger.appExtraEntropy = fappExtraEntropy - , Ledger.appProtocolVersion = fappProtocolVersion - , Ledger.appMinPoolCost = fappMinPoolCost - , Ledger.appCoinsPerUTxOWord = fappCoinsPerUTxOWord - , Ledger.appCostModels = fappCostModels - , Ledger.appPrices = fappPrices - , Ledger.appMaxTxExUnits = fappMaxTxExUnits - , Ledger.appMaxBlockExUnits = fappMaxBlockExUnits - , Ledger.appMaxValSize = fappMaxValSize - , Ledger.appCollateralPercentage = fappCollateralPercentage - , Ledger.appMaxCollateralInputs = fappMaxCollateralInputs - } + in Ledger.AlonzoPParams + { Ledger.appMinFeeA = fappMinFeeA + , Ledger.appMinFeeB = fappMinFeeB + , Ledger.appMaxBBSize = fappMaxBBSize + , Ledger.appMaxTxSize = fappMaxTxSize + , Ledger.appMaxBHSize = fappMaxBHSize + , Ledger.appKeyDeposit = fappKeyDeposit + , Ledger.appPoolDeposit = fappPoolDeposit + , Ledger.appEMax = fappEMax + , Ledger.appNOpt = fappNOpt + , Ledger.appA0 = fappA0 + , Ledger.appRho = fappRho + , Ledger.appTau = fappTau + , Ledger.appD = fappD + , Ledger.appExtraEntropy = fappExtraEntropy + , Ledger.appProtocolVersion = fappProtocolVersion + , Ledger.appMinPoolCost = fappMinPoolCost + , Ledger.appCoinsPerUTxOWord = fappCoinsPerUTxOWord + , Ledger.appCostModels = fappCostModels + , Ledger.appPrices = fappPrices + , Ledger.appMaxTxExUnits = fappMaxTxExUnits + , Ledger.appMaxBlockExUnits = fappMaxBlockExUnits + , Ledger.appMaxValSize = fappMaxValSize + , Ledger.appCollateralPercentage = fappCollateralPercentage + , Ledger.appMaxCollateralInputs = fappMaxCollateralInputs + } -- We're not interested in trying to mappend the underlying `Maybe` types -- we only want to select one or the other therefore we use `Last`. @@ -385,9 +456,9 @@ lastMappend a b = Ledger.maybeToStrictMaybe . getLast $ strictMaybeToLast a <> s lastMappendWith :: (a -> StrictMaybe b) -> a -> a -> StrictMaybe b lastMappendWith l = under2 l lastMappend - where - under2 :: (a -> c) -> (c -> c -> c) -> a -> a -> c - under2 f g x y = g (f x) (f y) + where + under2 :: (a -> c) -> (c -> c -> c) -> a -> a -> c + under2 f g x y = g (f x) (f y) instance Semigroup (Ledger.BabbagePParams StrictMaybe era) where (<>) p1 p2 = @@ -413,69 +484,70 @@ instance Semigroup (Ledger.BabbagePParams StrictMaybe era) where fbppMaxValSize = lastMappendWith Ledger.bppMaxValSize p1 p2 fbppCollateralPercentage = lastMappendWith Ledger.bppCollateralPercentage p1 p2 fbppMaxCollateralInputs = lastMappendWith Ledger.bppMaxCollateralInputs p1 p2 - in Ledger.BabbagePParams - { Ledger.bppMinFeeA = fbppMinFeeA - , Ledger.bppMinFeeB = fbppMinFeeB - , Ledger.bppMaxBBSize = fbppMaxBBSize - , Ledger.bppMaxTxSize = fbppMaxTxSize - , Ledger.bppMaxBHSize = fbppMaxBHSize - , Ledger.bppKeyDeposit = fbppKeyDeposit - , Ledger.bppPoolDeposit = fbppPoolDeposit - , Ledger.bppEMax = fbppEMax - , Ledger.bppNOpt = fbppNOpt - , Ledger.bppA0 = fbppA0 - , Ledger.bppRho = fbppRho - , Ledger.bppTau = fbppTau - , Ledger.bppProtocolVersion = fbppProtocolVersion - , Ledger.bppMinPoolCost = fbppMinPoolCost - , Ledger.bppCoinsPerUTxOByte = fbppCoinsPerUTxOByte - , Ledger.bppCostModels = fbppCostModels - , Ledger.bppPrices = fbppPrices - , Ledger.bppMaxTxExUnits = fbppMaxTxExUnits - , Ledger.bppMaxBlockExUnits = fbppMaxBlockExUnits - , Ledger.bppMaxValSize = fbppMaxValSize - , Ledger.bppCollateralPercentage = fbppCollateralPercentage - , Ledger.bppMaxCollateralInputs = fbppMaxCollateralInputs - } + in Ledger.BabbagePParams + { Ledger.bppMinFeeA = fbppMinFeeA + , Ledger.bppMinFeeB = fbppMinFeeB + , Ledger.bppMaxBBSize = fbppMaxBBSize + , Ledger.bppMaxTxSize = fbppMaxTxSize + , Ledger.bppMaxBHSize = fbppMaxBHSize + , Ledger.bppKeyDeposit = fbppKeyDeposit + , Ledger.bppPoolDeposit = fbppPoolDeposit + , Ledger.bppEMax = fbppEMax + , Ledger.bppNOpt = fbppNOpt + , Ledger.bppA0 = fbppA0 + , Ledger.bppRho = fbppRho + , Ledger.bppTau = fbppTau + , Ledger.bppProtocolVersion = fbppProtocolVersion + , Ledger.bppMinPoolCost = fbppMinPoolCost + , Ledger.bppCoinsPerUTxOByte = fbppCoinsPerUTxOByte + , Ledger.bppCostModels = fbppCostModels + , Ledger.bppPrices = fbppPrices + , Ledger.bppMaxTxExUnits = fbppMaxTxExUnits + , Ledger.bppMaxBlockExUnits = fbppMaxBlockExUnits + , Ledger.bppMaxValSize = fbppMaxValSize + , Ledger.bppCollateralPercentage = fbppCollateralPercentage + , Ledger.bppMaxCollateralInputs = fbppMaxCollateralInputs + } instance Semigroup (Ledger.ConwayPParams StrictMaybe era) where - (<>) p1 p2 = Ledger.ConwayPParams - { Ledger.cppMinFeeA = lastMappendWithTHKD Ledger.cppMinFeeA p1 p2 - , Ledger.cppMinFeeB = lastMappendWithTHKD Ledger.cppMinFeeB p1 p2 - , Ledger.cppMaxBBSize = lastMappendWithTHKD Ledger.cppMaxBBSize p1 p2 - , Ledger.cppMaxTxSize = lastMappendWithTHKD Ledger.cppMaxTxSize p1 p2 - , Ledger.cppMaxBHSize = lastMappendWithTHKD Ledger.cppMaxBHSize p1 p2 - , Ledger.cppKeyDeposit = lastMappendWithTHKD Ledger.cppKeyDeposit p1 p2 - , Ledger.cppPoolDeposit = lastMappendWithTHKD Ledger.cppPoolDeposit p1 p2 - , Ledger.cppEMax = lastMappendWithTHKD Ledger.cppEMax p1 p2 - , Ledger.cppNOpt = lastMappendWithTHKD Ledger.cppNOpt p1 p2 - , Ledger.cppA0 = lastMappendWithTHKD Ledger.cppA0 p1 p2 - , Ledger.cppRho = lastMappendWithTHKD Ledger.cppRho p1 p2 - , Ledger.cppTau = lastMappendWithTHKD Ledger.cppTau p1 p2 - , Ledger.cppProtocolVersion = NoUpdate -- For conway, protocol version cannot be changed via `PParamsUpdate` - , Ledger.cppMinPoolCost = lastMappendWithTHKD Ledger.cppMinPoolCost p1 p2 - , Ledger.cppCoinsPerUTxOByte = lastMappendWithTHKD Ledger.cppCoinsPerUTxOByte p1 p2 - , Ledger.cppCostModels = lastMappendWithTHKD Ledger.cppCostModels p1 p2 - , Ledger.cppPrices = lastMappendWithTHKD Ledger.cppPrices p1 p2 - , Ledger.cppMaxTxExUnits = lastMappendWithTHKD Ledger.cppMaxTxExUnits p1 p2 - , Ledger.cppMaxBlockExUnits = lastMappendWithTHKD Ledger.cppMaxBlockExUnits p1 p2 - , Ledger.cppMaxValSize = lastMappendWithTHKD Ledger.cppMaxValSize p1 p2 - , Ledger.cppCollateralPercentage = lastMappendWithTHKD Ledger.cppCollateralPercentage p1 p2 - , Ledger.cppMaxCollateralInputs = lastMappendWithTHKD Ledger.cppMaxCollateralInputs p1 p2 - , Ledger.cppPoolVotingThresholds = lastMappendWithTHKD Ledger.cppPoolVotingThresholds p1 p2 - , Ledger.cppDRepVotingThresholds = lastMappendWithTHKD Ledger.cppDRepVotingThresholds p1 p2 - , Ledger.cppCommitteeMinSize = lastMappendWithTHKD Ledger.cppCommitteeMinSize p1 p2 - , Ledger.cppCommitteeMaxTermLength = lastMappendWithTHKD Ledger.cppCommitteeMaxTermLength p1 p2 - , Ledger.cppGovActionLifetime = lastMappendWithTHKD Ledger.cppGovActionLifetime p1 p2 - , Ledger.cppGovActionDeposit = lastMappendWithTHKD Ledger.cppGovActionDeposit p1 p2 - , Ledger.cppDRepDeposit = lastMappendWithTHKD Ledger.cppDRepDeposit p1 p2 - , Ledger.cppDRepActivity = lastMappendWithTHKD Ledger.cppDRepActivity p1 p2 - , Ledger.cppMinFeeRefScriptCostPerByte = lastMappendWithTHKD Ledger.cppMinFeeRefScriptCostPerByte p1 p2 - } + (<>) p1 p2 = + Ledger.ConwayPParams + { Ledger.cppMinFeeA = lastMappendWithTHKD Ledger.cppMinFeeA p1 p2 + , Ledger.cppMinFeeB = lastMappendWithTHKD Ledger.cppMinFeeB p1 p2 + , Ledger.cppMaxBBSize = lastMappendWithTHKD Ledger.cppMaxBBSize p1 p2 + , Ledger.cppMaxTxSize = lastMappendWithTHKD Ledger.cppMaxTxSize p1 p2 + , Ledger.cppMaxBHSize = lastMappendWithTHKD Ledger.cppMaxBHSize p1 p2 + , Ledger.cppKeyDeposit = lastMappendWithTHKD Ledger.cppKeyDeposit p1 p2 + , Ledger.cppPoolDeposit = lastMappendWithTHKD Ledger.cppPoolDeposit p1 p2 + , Ledger.cppEMax = lastMappendWithTHKD Ledger.cppEMax p1 p2 + , Ledger.cppNOpt = lastMappendWithTHKD Ledger.cppNOpt p1 p2 + , Ledger.cppA0 = lastMappendWithTHKD Ledger.cppA0 p1 p2 + , Ledger.cppRho = lastMappendWithTHKD Ledger.cppRho p1 p2 + , Ledger.cppTau = lastMappendWithTHKD Ledger.cppTau p1 p2 + , Ledger.cppProtocolVersion = NoUpdate -- For conway, protocol version cannot be changed via `PParamsUpdate` + , Ledger.cppMinPoolCost = lastMappendWithTHKD Ledger.cppMinPoolCost p1 p2 + , Ledger.cppCoinsPerUTxOByte = lastMappendWithTHKD Ledger.cppCoinsPerUTxOByte p1 p2 + , Ledger.cppCostModels = lastMappendWithTHKD Ledger.cppCostModels p1 p2 + , Ledger.cppPrices = lastMappendWithTHKD Ledger.cppPrices p1 p2 + , Ledger.cppMaxTxExUnits = lastMappendWithTHKD Ledger.cppMaxTxExUnits p1 p2 + , Ledger.cppMaxBlockExUnits = lastMappendWithTHKD Ledger.cppMaxBlockExUnits p1 p2 + , Ledger.cppMaxValSize = lastMappendWithTHKD Ledger.cppMaxValSize p1 p2 + , Ledger.cppCollateralPercentage = lastMappendWithTHKD Ledger.cppCollateralPercentage p1 p2 + , Ledger.cppMaxCollateralInputs = lastMappendWithTHKD Ledger.cppMaxCollateralInputs p1 p2 + , Ledger.cppPoolVotingThresholds = lastMappendWithTHKD Ledger.cppPoolVotingThresholds p1 p2 + , Ledger.cppDRepVotingThresholds = lastMappendWithTHKD Ledger.cppDRepVotingThresholds p1 p2 + , Ledger.cppCommitteeMinSize = lastMappendWithTHKD Ledger.cppCommitteeMinSize p1 p2 + , Ledger.cppCommitteeMaxTermLength = lastMappendWithTHKD Ledger.cppCommitteeMaxTermLength p1 p2 + , Ledger.cppGovActionLifetime = lastMappendWithTHKD Ledger.cppGovActionLifetime p1 p2 + , Ledger.cppGovActionDeposit = lastMappendWithTHKD Ledger.cppGovActionDeposit p1 p2 + , Ledger.cppDRepDeposit = lastMappendWithTHKD Ledger.cppDRepDeposit p1 p2 + , Ledger.cppDRepActivity = lastMappendWithTHKD Ledger.cppDRepActivity p1 p2 + , Ledger.cppMinFeeRefScriptCostPerByte = + lastMappendWithTHKD Ledger.cppMinFeeRefScriptCostPerByte p1 p2 + } lastMappendWithTHKD :: (a -> Ledger.THKD g StrictMaybe b) -> a -> a -> Ledger.THKD g StrictMaybe b lastMappendWithTHKD f a b = Ledger.THKD $ lastMappendWith (Ledger.unTHKD . f) a b instance Pretty MuxError where pretty err = "Mux layer error:" <+> prettyException err - diff --git a/cardano-api/internal/Cardano/Api/Pretty.hs b/cardano-api/internal/Cardano/Api/Pretty.hs index 93a19ac819..fba616db5b 100644 --- a/cardano-api/internal/Cardano/Api/Pretty.hs +++ b/cardano-api/internal/Cardano/Api/Pretty.hs @@ -1,18 +1,16 @@ module Cardano.Api.Pretty ( Ann , Doc - , Pretty(..) - , ShowOf(..) + , Pretty (..) + , ShowOf (..) , docToLazyText , docToText , docToString , pshow , prettyException - , hsep , vsep , (<+>) - , black , red , green @@ -21,22 +19,22 @@ module Cardano.Api.Pretty , magenta , cyan , white - ) where - -import Cardano.Api.Via.ShowOf + ) +where -import Control.Exception.Safe +import Cardano.Api.Via.ShowOf +import Control.Exception.Safe import qualified Data.Text as Text import qualified Data.Text.Lazy as TextLazy -import Prettyprinter -import Prettyprinter.Render.Terminal +import Prettyprinter +import Prettyprinter.Render.Terminal -- | 'Ann' is the prettyprinter annotation for cardano-api and cardano-cli to enable the printing -- of colored output. This is a type alias for AnsiStyle. type Ann = AnsiStyle docToString :: Doc AnsiStyle -> String -docToString = show +docToString = show docToLazyText :: Doc AnsiStyle -> TextLazy.Text docToLazyText = renderLazy . layoutPretty defaultLayoutOptions diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs index a79ea773a2..ce4ad6b932 100644 --- a/cardano-api/internal/Cardano/Api/Protocol.hs +++ b/cardano-api/internal/Cardano/Api/Protocol.hs @@ -9,36 +9,34 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Protocol - ( BlockType(..) + ( BlockType (..) , SomeBlockType (..) , reflBlockType - , Protocol(..) - , ProtocolInfoArgs(..) - , ProtocolClient(..) - , ProtocolClientInfoArgs(..) - ) where - -import Cardano.Api.Modes - -import Ouroboros.Consensus.Block.Forging (BlockForging) + , Protocol (..) + , ProtocolInfoArgs (..) + , ProtocolClient (..) + , ProtocolClientInfoArgs (..) + ) +where + +import Cardano.Api.Modes +import Data.Bifunctor (bimap) +import Ouroboros.Consensus.Block.Forging (BlockForging) import qualified Ouroboros.Consensus.Byron.Ledger as Byron -import Ouroboros.Consensus.Cardano -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC) -import Ouroboros.Consensus.Cardano.Node -import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary +import Ouroboros.Consensus.Cardano +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC) +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus -import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), ProtocolInfo (..)) -import Ouroboros.Consensus.Node.Run (RunNode) +import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), ProtocolInfo (..)) +import Ouroboros.Consensus.Node.Run (RunNode) import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.Eras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus -import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) -import Ouroboros.Consensus.Util.IOLike (IOLike) - -import Data.Bifunctor (bimap) - -import Type.Reflection ((:~:) (..)) +import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) +import Ouroboros.Consensus.Util.IOLike (IOLike) +import Type.Reflection ((:~:) (..)) class (RunNode blk, IOLike m) => Protocol m blk where data ProtocolInfoArgs blk @@ -48,58 +46,66 @@ class (RunNode blk, IOLike m) => Protocol m blk where -- -- This is like 'Protocol' but for clients of the node, so with less onerous -- requirements than to run a node. --- class RunNode blk => ProtocolClient blk where data ProtocolClientInfoArgs blk protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk - -- | Run PBFT against the Byron ledger instance IOLike m => Protocol m ByronBlockHFC where data ProtocolInfoArgs ByronBlockHFC = ProtocolInfoArgsByron (ProtocolParams Byron.ByronBlock) - protocolInfo (ProtocolInfoArgsByron params) = ( inject $ protocolInfoByron params - , pure . map inject $ blockForgingByron params - ) + protocolInfo (ProtocolInfoArgsByron params) = + ( inject $ protocolInfoByron params + , pure . map inject $ blockForgingByron params + ) instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where - data ProtocolInfoArgs (CardanoBlock StandardCrypto) = - ProtocolInfoArgsCardano - (CardanoProtocolParams StandardCrypto) + data ProtocolInfoArgs (CardanoBlock StandardCrypto) + = ProtocolInfoArgsCardano + (CardanoProtocolParams StandardCrypto) protocolInfo (ProtocolInfoArgsCardano paramsCardano) = protocolInfoCardano paramsCardano instance ProtocolClient ByronBlockHFC where - data ProtocolClientInfoArgs ByronBlockHFC = - ProtocolClientInfoArgsByron EpochSlots + data ProtocolClientInfoArgs ByronBlockHFC + = ProtocolClientInfoArgsByron EpochSlots protocolClientInfo (ProtocolClientInfoArgsByron epochSlots) = inject $ protocolClientInfoByron epochSlots instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where - data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) = - ProtocolClientInfoArgsCardano EpochSlots + data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) + = ProtocolClientInfoArgsCardano EpochSlots protocolClientInfo (ProtocolClientInfoArgsCardano epochSlots) = protocolClientInfoCardano epochSlots -instance ( IOLike m - , Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) - ) - => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) where - data ProtocolInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) = ProtocolInfoArgsShelley - (ShelleyGenesis StandardCrypto) - (ProtocolParamsShelleyBased StandardCrypto) - (ProtocolParams (Consensus.ShelleyBlock (Consensus.TPraos StandardCrypto) StandardShelley)) +instance + ( IOLike m + , Consensus.LedgerSupportsProtocol + ( Consensus.ShelleyBlock + (Consensus.TPraos StandardCrypto) + (ShelleyEra StandardCrypto) + ) + ) + => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) + where + data ProtocolInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) + = ProtocolInfoArgsShelley + (ShelleyGenesis StandardCrypto) + (ProtocolParamsShelleyBased StandardCrypto) + (ProtocolParams (Consensus.ShelleyBlock (Consensus.TPraos StandardCrypto) StandardShelley)) protocolInfo (ProtocolInfoArgsShelley genesis paramsShelleyBased_ paramsShelley_) = bimap inject (fmap $ map inject) $ protocolInfoShelley genesis paramsShelleyBased_ paramsShelley_ -instance Consensus.LedgerSupportsProtocol - (Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) (Consensus.ShelleyEra StandardCrypto)) - => ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) where - data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) = - ProtocolClientInfoArgsShelley +instance + Consensus.LedgerSupportsProtocol + ( Consensus.ShelleyBlock + (Consensus.TPraos StandardCrypto) + (Consensus.ShelleyEra StandardCrypto) + ) + => ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) + where + data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) + = ProtocolClientInfoArgsShelley protocolClientInfo ProtocolClientInfoArgsShelley = inject protocolClientInfoShelley @@ -109,14 +115,14 @@ data BlockType blk where CardanoBlockType :: BlockType (CardanoBlock StandardCrypto) deriving instance Eq (BlockType blk) + deriving instance Show (BlockType blk) reflBlockType :: BlockType blk -> BlockType blk' -> Maybe (blk :~: blk') -reflBlockType ByronBlockType ByronBlockType = Just Refl +reflBlockType ByronBlockType ByronBlockType = Just Refl reflBlockType ShelleyBlockType ShelleyBlockType = Just Refl reflBlockType CardanoBlockType CardanoBlockType = Just Refl -reflBlockType _ _ = Nothing - +reflBlockType _ _ = Nothing data SomeBlockType where SomeBlockType :: BlockType blk -> SomeBlockType diff --git a/cardano-api/internal/Cardano/Api/Protocol/Version.hs b/cardano-api/internal/Cardano/Api/Protocol/Version.hs index 8251a5a8c4..9fc414d99c 100644 --- a/cardano-api/internal/Cardano/Api/Protocol/Version.hs +++ b/cardano-api/internal/Cardano/Api/Protocol/Version.hs @@ -7,7 +7,6 @@ {-# LANGUAGE TypeFamilyDependencies #-} -- UndecidableInstances needed for 9.2.7 and 8.10.7 {-# LANGUAGE UndecidableInstances #-} - -- Only for UninhabitableType {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} @@ -22,17 +21,18 @@ module Cardano.Api.Protocol.Version , VersionToSbe , useEra , protocolVersionToSbe - ) where + ) +where -import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) import qualified Cardano.Api.Eras.Core as Api - -import GHC.TypeLits +import GHC.TypeLits -- | Users typically interact with the latest features on the mainnet or experiment with features -- from the upcoming era. Hence, the protocol versions are limited to the current mainnet era -- and the next era (upcoming era). data BabbageEra + data ConwayEra -- Allows us to gradually change the api without breaking things. @@ -41,89 +41,83 @@ type family VersionToSbe version where VersionToSbe BabbageEra = Api.BabbageEra VersionToSbe ConwayEra = Api.ConwayEra -{- | Represents the eras in Cardano's blockchain. - -Instead of enumerating every possible era, we use two constructors: -'CurrentEra' and 'UpcomingEra'. This design simplifies the handling -of eras, especially for 'cardano-api' consumers who are primarily concerned -with the current mainnet era and the next era for an upcoming hardfork. - -Usage: -- 'CurrentEra': Reflects the era currently active on mainnet. -- 'UpcomingEra': Represents the era planned for the next hardfork. - -After a hardfork, 'cardano-api' should be updated promptly to reflect -the new mainnet era in 'CurrentEra'. - --} +-- | Represents the eras in Cardano's blockchain. +-- +-- Instead of enumerating every possible era, we use two constructors: +-- 'CurrentEra' and 'UpcomingEra'. This design simplifies the handling +-- of eras, especially for 'cardano-api' consumers who are primarily concerned +-- with the current mainnet era and the next era for an upcoming hardfork. +-- +-- Usage: +-- - 'CurrentEra': Reflects the era currently active on mainnet. +-- - 'UpcomingEra': Represents the era planned for the next hardfork. +-- +-- After a hardfork, 'cardano-api' should be updated promptly to reflect +-- the new mainnet era in 'CurrentEra'. data Era version where -- | The era currently active on Cardano's mainnet. CurrentEraInternal :: Era BabbageEra -- | The era planned for the next hardfork on Cardano's mainnet. UpcomingEraInternal :: Era ConwayEra -{- | How to deprecate an era - - 1. Add DEPRECATED pragma to the era type tag. -@ -{-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-} -data BabbageEra -@ - - 2. Add a new era type tag. -@ -data Era version where - -- | The era currently active on Cardano's mainnet. - CurrentEraInternal :: Era ConwayEra - -- | The era planned for the next hardfork on Cardano's mainnet. - UpcomingEraInternal :: Era (UninhabitableType EraCurrentlyNonExistent) -@ - - 3. Update pattern synonyms. -@ -pattern CurrentEra :: Era ConwayEra -pattern CurrentEra = CurrentEraInternal - -pattern UpcomingEra :: Era (UninhabitableType EraCurrentlyNonExistent) -pattern UpcomingEra = UpcomingEraInternal -@ - - 4. Add new 'UseEra' instance and keep the deprecated era's instance. -@ -instance UseEra BabbageEra where - useEra = error "useEra: BabbageEra no longer supported, use ConwayEra" - -instance UseEra ConwayEra where - useEra = CurrentEra -@ - - 5. Update 'protocolVersionToSbe' as follows: -@ -protocolVersionToSbe - :: Era version - -> Maybe (ShelleyBasedEra (VersionToSbe version)) -protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage -protocolVersionToSbe UpcomingEraInternal = Nothing -@ --} - - -{- | 'CurrentEraInternal' and 'UpcomingEraInternal' are for internal use only. -The above restriction combined with the following pattern synonyms -prevents a user from pattern matching on 'Era era' and -avoids the following situation: - -@ -doThing :: Era era -> () -doThing = \case - CurrentEraInternal -> enableFeature - UpcomingEraInternal -> disableFeature -@ - -Consumers of this library must pick one of the two eras while -this library is responsibile for what happens at the boundary of the eras. --} - +-- | How to deprecate an era +-- +-- 1. Add DEPRECATED pragma to the era type tag. +-- @ +-- {-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-} +-- data BabbageEra +-- @ +-- +-- 2. Add a new era type tag. +-- @ +-- data Era version where +-- -- | The era currently active on Cardano's mainnet. +-- CurrentEraInternal :: Era ConwayEra +-- -- | The era planned for the next hardfork on Cardano's mainnet. +-- UpcomingEraInternal :: Era (UninhabitableType EraCurrentlyNonExistent) +-- @ +-- +-- 3. Update pattern synonyms. +-- @ +-- pattern CurrentEra :: Era ConwayEra +-- pattern CurrentEra = CurrentEraInternal +-- +-- pattern UpcomingEra :: Era (UninhabitableType EraCurrentlyNonExistent) +-- pattern UpcomingEra = UpcomingEraInternal +-- @ +-- +-- 4. Add new 'UseEra' instance and keep the deprecated era's instance. +-- @ +-- instance UseEra BabbageEra where +-- useEra = error "useEra: BabbageEra no longer supported, use ConwayEra" +-- +-- instance UseEra ConwayEra where +-- useEra = CurrentEra +-- @ +-- +-- 5. Update 'protocolVersionToSbe' as follows: +-- @ +-- protocolVersionToSbe +-- :: Era version +-- -> Maybe (ShelleyBasedEra (VersionToSbe version)) +-- protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage +-- protocolVersionToSbe UpcomingEraInternal = Nothing +-- @ + +-- | 'CurrentEraInternal' and 'UpcomingEraInternal' are for internal use only. +-- The above restriction combined with the following pattern synonyms +-- prevents a user from pattern matching on 'Era era' and +-- avoids the following situation: +-- +-- @ +-- doThing :: Era era -> () +-- doThing = \case +-- CurrentEraInternal -> enableFeature +-- UpcomingEraInternal -> disableFeature +-- @ +-- +-- Consumers of this library must pick one of the two eras while +-- this library is responsibile for what happens at the boundary of the eras. pattern CurrentEra :: Era BabbageEra pattern CurrentEra = CurrentEraInternal @@ -141,7 +135,6 @@ protocolVersionToSbe UpcomingEraInternal = Nothing ------------------------------------------------------------------------- -- | Type class interface for the 'Era' type. - class UseEra version where useEra :: Era version @@ -151,13 +144,11 @@ instance UseEra BabbageEra where instance UseEra ConwayEra where useEra = UpcomingEra - -- | After a hardfork there is usually no planned upcoming era -- that we are able to experiment with. We force a type era -- in this instance. See docs above. data EraCurrentlyNonExistent -type family UninhabitableType a where - UninhabitableType EraCurrentlyNonExistent = TypeError ('Text "There is currently no planned upcoming era. Use CurrentEra instead.") - - +type family UninhabitableType a where + UninhabitableType EraCurrentlyNonExistent = + TypeError ('Text "There is currently no planned upcoming era. Use CurrentEra instead.") diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 85cfe85e7f..54f0320fd0 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -17,7 +17,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -Wno-orphans #-} {- HLINT ignore "Redundant ==" -} @@ -29,134 +28,140 @@ -- * updates to protocol parameters: 'ProtocolParametersUpdate' -- * update proposals that can be embedded in transactions: 'UpdateProposal' -- * parameters fixed in the genesis file: 'GenesisParameters' --- -module Cardano.Api.ProtocolParameters ( - -- * The updatable protocol parameters - ProtocolParameters(..), - checkProtocolParameters, - EpochNo, +module Cardano.Api.ProtocolParameters + ( -- * The updatable protocol parameters + ProtocolParameters (..) + , checkProtocolParameters + , EpochNo -- * The updatable protocol parameters - LedgerProtocolParameters(..), - EraBasedProtocolParametersUpdate(..), - AlonzoOnwardsPParams(..), - CommonProtocolParametersUpdate(..), - DeprecatedAfterBabbagePParams(..), - DeprecatedAfterMaryPParams(..), - ShelleyToAlonzoPParams(..), - IntroducedInBabbagePParams(..), - IntroducedInConwayPParams(..), - createEraBasedProtocolParamUpdate, - convertToLedgerProtocolParameters, - createPParams, + , LedgerProtocolParameters (..) + , EraBasedProtocolParametersUpdate (..) + , AlonzoOnwardsPParams (..) + , CommonProtocolParametersUpdate (..) + , DeprecatedAfterBabbagePParams (..) + , DeprecatedAfterMaryPParams (..) + , ShelleyToAlonzoPParams (..) + , IntroducedInBabbagePParams (..) + , IntroducedInConwayPParams (..) + , createEraBasedProtocolParamUpdate + , convertToLedgerProtocolParameters + , createPParams -- * Deprecated - ProtocolParametersUpdate(..), + , ProtocolParametersUpdate (..) -- * Errors - ProtocolParametersError(..), - ProtocolParametersConversionError(..), + , ProtocolParametersError (..) + , ProtocolParametersConversionError (..) -- * PraosNonce - PraosNonce, - makePraosNonce, + , PraosNonce + , makePraosNonce -- * Execution units, prices and cost models, - ExecutionUnits(..), - ExecutionUnitPrices(..), - CostModels(..), - CostModel(..), - fromAlonzoCostModels, + , ExecutionUnits (..) + , ExecutionUnitPrices (..) + , CostModels (..) + , CostModel (..) + , fromAlonzoCostModels -- * Update proposals to change the protocol parameters - UpdateProposal(..), - makeShelleyUpdateProposal, + , UpdateProposal (..) + , makeShelleyUpdateProposal -- * Internal conversion functions - toLedgerNonce, - toLedgerUpdate, - fromLedgerUpdate, - toLedgerProposedPPUpdates, - fromLedgerProposedPPUpdates, - toLedgerPParams, - toLedgerPParamsUpdate, - fromLedgerPParams, - fromLedgerPParamsUpdate, - toAlonzoPrices, - fromAlonzoPrices, - toAlonzoScriptLanguage, - fromAlonzoScriptLanguage, - toAlonzoCostModel, - fromAlonzoCostModel, - toAlonzoCostModels, + , toLedgerNonce + , toLedgerUpdate + , fromLedgerUpdate + , toLedgerProposedPPUpdates + , fromLedgerProposedPPUpdates + , toLedgerPParams + , toLedgerPParamsUpdate + , fromLedgerPParams + , fromLedgerPParamsUpdate + , toAlonzoPrices + , fromAlonzoPrices + , toAlonzoScriptLanguage + , fromAlonzoScriptLanguage + , toAlonzoCostModel + , fromAlonzoCostModel + , toAlonzoCostModels -- * Data family instances - AsType(..), + , AsType (..) -- ** Era-dependent protocol features - ) where - -import Cardano.Api.Address -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.Error -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Json (toRationalJSON) -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Shelley -import Cardano.Api.Orphans () -import Cardano.Api.Pretty -import Cardano.Api.Script -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Api.StakePoolMetadata -import Cardano.Api.TxMetadata -import Cardano.Api.Utils -import Cardano.Api.Value - + ) +where + +import Cardano.Api.Address +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Json (toRationalJSON) +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Shelley +import Cardano.Api.Orphans () +import Cardano.Api.Pretty +import Cardano.Api.Script +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Api.StakePoolMetadata +import Cardano.Api.TxMetadata +import Cardano.Api.Utils +import Cardano.Api.Value import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Ledger.Alonzo.PParams as Ledger import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Api.Era as Ledger -import Cardano.Ledger.Api.PParams +import Cardano.Ledger.Api.PParams import qualified Cardano.Ledger.Babbage.Core as Ledger -import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) +import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.PParams as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Plutus.CostModels as Plutus import qualified Cardano.Ledger.Plutus.Language as Plutus import qualified Cardano.Ledger.Shelley.API as Ledger -import Cardano.Slotting.Slot (EpochNo (..)) -import PlutusLedgerApi.Common (CostModelApplyError) - -import Control.Monad -import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), - (.=)) -import Data.Bifunctor (bimap, first) -import Data.ByteString (ByteString) -import Data.Data (Data) -import Data.Either.Combinators (maybeToRight) -import Data.Int (Int64) -import Data.Map.Strict (Map) +import Cardano.Slotting.Slot (EpochNo (..)) +import Control.Monad +import Data.Aeson + ( FromJSON (..) + , ToJSON (..) + , object + , withObject + , (.!=) + , (.:) + , (.:?) + , (.=) + ) +import Data.Bifunctor (bimap, first) +import Data.ByteString (ByteString) +import Data.Data (Data) +import Data.Either.Combinators (maybeToRight) +import Data.Int (Int64) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) -import Data.Maybe.Strict (StrictMaybe (..)) -import Data.String (IsString) -import Data.Text (Text) -import Data.Word -import GHC.Generics -import Lens.Micro -import Numeric.Natural -import Text.PrettyBy.Default (display) +import Data.Maybe (isJust) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.String (IsString) +import Data.Text (Text) +import Data.Word +import GHC.Generics +import Lens.Micro +import Numeric.Natural +import PlutusLedgerApi.Common (CostModelApplyError) +import Text.PrettyBy.Default (display) -- ----------------------------------------------------------------------------- -- Era based ledger protocol parameters @@ -167,15 +172,18 @@ newtype LedgerProtocolParameters era = LedgerProtocolParameters instance IsShelleyBasedEra era => Show (LedgerProtocolParameters era) where show (LedgerProtocolParameters pp) = - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ show pp + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + show pp instance IsShelleyBasedEra era => Eq (LedgerProtocolParameters era) where LedgerProtocolParameters a == LedgerProtocolParameters b = - shelleyBasedEraConstraints (shelleyBasedEra @era) - $ a == b + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + a == b -{-# DEPRECATED convertToLedgerProtocolParameters "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} +{-# DEPRECATED + convertToLedgerProtocolParameters + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} convertToLedgerProtocolParameters :: ShelleyBasedEra era -> ProtocolParameters @@ -190,7 +198,7 @@ createPParams createPParams sbe ebPParamsUpdate = shelleyBasedEraConstraints sbe $ let ppUp = createEraBasedProtocolParamUpdate sbe ebPParamsUpdate - in Ledger.applyPPUpdates emptyPParams ppUp + in Ledger.applyPPUpdates emptyPParams ppUp -- ----------------------------------------------------------------------------- -- Era based Ledger protocol parameters update @@ -205,35 +213,30 @@ data EraBasedProtocolParametersUpdate era where -> DeprecatedAfterBabbagePParams ShelleyEra -> ShelleyToAlonzoPParams ShelleyEra -> EraBasedProtocolParametersUpdate ShelleyEra - AllegraEraBasedProtocolParametersUpdate :: CommonProtocolParametersUpdate -> DeprecatedAfterMaryPParams AllegraEra -> ShelleyToAlonzoPParams AllegraEra -> DeprecatedAfterBabbagePParams ShelleyEra -> EraBasedProtocolParametersUpdate AllegraEra - MaryEraBasedProtocolParametersUpdate :: CommonProtocolParametersUpdate -> DeprecatedAfterMaryPParams MaryEra -> ShelleyToAlonzoPParams MaryEra -> DeprecatedAfterBabbagePParams ShelleyEra -> EraBasedProtocolParametersUpdate MaryEra - AlonzoEraBasedProtocolParametersUpdate :: CommonProtocolParametersUpdate -> ShelleyToAlonzoPParams AlonzoEra -> AlonzoOnwardsPParams AlonzoEra -> DeprecatedAfterBabbagePParams ShelleyEra -> EraBasedProtocolParametersUpdate AlonzoEra - BabbageEraBasedProtocolParametersUpdate :: CommonProtocolParametersUpdate -> AlonzoOnwardsPParams BabbageEra -> DeprecatedAfterBabbagePParams ShelleyEra -> IntroducedInBabbagePParams BabbageEra -> EraBasedProtocolParametersUpdate BabbageEra - ConwayEraBasedProtocolParametersUpdate :: CommonProtocolParametersUpdate -> AlonzoOnwardsPParams ConwayEra @@ -243,110 +246,103 @@ data EraBasedProtocolParametersUpdate era where deriving instance Show (EraBasedProtocolParametersUpdate era) - data IntroducedInConwayPParams era = IntroducedInConwayPParams - { icPoolVotingThresholds :: StrictMaybe Ledger.PoolVotingThresholds - , icDRepVotingThresholds :: StrictMaybe Ledger.DRepVotingThresholds - , icMinCommitteeSize :: StrictMaybe Natural - , icCommitteeTermLength :: StrictMaybe Ledger.EpochInterval - , icGovActionLifetime :: StrictMaybe Ledger.EpochInterval - , icGovActionDeposit :: StrictMaybe Ledger.Coin - , icDRepDeposit :: StrictMaybe Ledger.Coin - , icDRepActivity :: StrictMaybe Ledger.EpochInterval - , icMinFeeRefScriptCostPerByte :: StrictMaybe Ledger.NonNegativeInterval - } deriving Show - + { icPoolVotingThresholds :: StrictMaybe Ledger.PoolVotingThresholds + , icDRepVotingThresholds :: StrictMaybe Ledger.DRepVotingThresholds + , icMinCommitteeSize :: StrictMaybe Natural + , icCommitteeTermLength :: StrictMaybe Ledger.EpochInterval + , icGovActionLifetime :: StrictMaybe Ledger.EpochInterval + , icGovActionDeposit :: StrictMaybe Ledger.Coin + , icDRepDeposit :: StrictMaybe Ledger.Coin + , icDRepActivity :: StrictMaybe Ledger.EpochInterval + , icMinFeeRefScriptCostPerByte :: StrictMaybe Ledger.NonNegativeInterval + } + deriving (Show) createIntroducedInConwayPParams :: Ledger.ConwayEraPParams ledgerera => IntroducedInConwayPParams ledgerera -> Ledger.PParamsUpdate ledgerera -createIntroducedInConwayPParams IntroducedInConwayPParams{..} = - Ledger.emptyPParamsUpdate - & Ledger.ppuPoolVotingThresholdsL .~ icPoolVotingThresholds - & Ledger.ppuDRepVotingThresholdsL .~ icDRepVotingThresholds - & Ledger.ppuCommitteeMinSizeL .~ icMinCommitteeSize - & Ledger.ppuCommitteeMaxTermLengthL .~ icCommitteeTermLength - & Ledger.ppuGovActionLifetimeL .~ icGovActionLifetime - & Ledger.ppuGovActionDepositL .~ icGovActionDeposit - & Ledger.ppuDRepDepositL .~ icDRepDeposit - & Ledger.ppuDRepActivityL .~ icDRepActivity - & Ledger.ppuMinFeeRefScriptCostPerByteL .~ icMinFeeRefScriptCostPerByte - +createIntroducedInConwayPParams IntroducedInConwayPParams {..} = + Ledger.emptyPParamsUpdate + & Ledger.ppuPoolVotingThresholdsL .~ icPoolVotingThresholds + & Ledger.ppuDRepVotingThresholdsL .~ icDRepVotingThresholds + & Ledger.ppuCommitteeMinSizeL .~ icMinCommitteeSize + & Ledger.ppuCommitteeMaxTermLengthL .~ icCommitteeTermLength + & Ledger.ppuGovActionLifetimeL .~ icGovActionLifetime + & Ledger.ppuGovActionDepositL .~ icGovActionDeposit + & Ledger.ppuDRepDepositL .~ icDRepDeposit + & Ledger.ppuDRepActivityL .~ icDRepActivity + & Ledger.ppuMinFeeRefScriptCostPerByteL .~ icMinFeeRefScriptCostPerByte createEraBasedProtocolParamUpdate :: ShelleyBasedEra era -> EraBasedProtocolParametersUpdate era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) createEraBasedProtocolParamUpdate sbe eraPParamsUpdate = - case eraPParamsUpdate of + case eraPParamsUpdate of ShelleyEraBasedProtocolParametersUpdate c depAfterMary depAfterBabbage depAfterAlonzo -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage Ledger.PParamsUpdate depAfterMary' = createDeprecatedAfterMaryPParams sbe depAfterMary Ledger.PParamsUpdate depAfterAlonzo' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzo - in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' - + in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' AllegraEraBasedProtocolParametersUpdate c depAfterMary depAfterAlonzo depAfterBabbage -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage Ledger.PParamsUpdate depAfterMary' = createDeprecatedAfterMaryPParams sbe depAfterMary Ledger.PParamsUpdate depAfterAlonzo' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzo - in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' - + in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' MaryEraBasedProtocolParametersUpdate c depAfterMary depAfterAlonzo depAfterBabbage -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage Ledger.PParamsUpdate depAfterMary' = createDeprecatedAfterMaryPParams sbe depAfterMary Ledger.PParamsUpdate depAfterAlonzo' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzo - in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' - + in Ledger.PParamsUpdate $ common <> withProtVer <> depAfterMary' <> depAfterAlonzo' AlonzoEraBasedProtocolParametersUpdate c depAfterAlonzoA introInAlon depAfterBabbage -> - let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage - Ledger.PParamsUpdate preAl' = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsAlonzo introInAlon - Ledger.PParamsUpdate depAfterAlonzoA' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzoA - in Ledger.PParamsUpdate $ common <> withProtVer <> preAl' <> depAfterAlonzoA' - + let Ledger.PParamsUpdate common = createCommonPParamsUpdate c + Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage + Ledger.PParamsUpdate preAl' = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsAlonzo introInAlon + Ledger.PParamsUpdate depAfterAlonzoA' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzoA + in Ledger.PParamsUpdate $ common <> withProtVer <> preAl' <> depAfterAlonzoA' BabbageEraBasedProtocolParametersUpdate c introInAlonzo depAfterBabbage introInBabbage -> - let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage - Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsBabbage introInAlonzo - Ledger.PParamsUpdate inBAb = createIntroducedInBabbagePParams BabbageEraOnwardsBabbage introInBabbage - in Ledger.PParamsUpdate $ common <> withProtVer <> inAlonzoPParams <> inBAb - + let Ledger.PParamsUpdate common = createCommonPParamsUpdate c + Ledger.PParamsUpdate withProtVer = createPreConwayProtocolVersionUpdate depAfterBabbage + Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsBabbage introInAlonzo + Ledger.PParamsUpdate inBAb = createIntroducedInBabbagePParams BabbageEraOnwardsBabbage introInBabbage + in Ledger.PParamsUpdate $ common <> withProtVer <> inAlonzoPParams <> inBAb ConwayEraBasedProtocolParametersUpdate c introInAlonzo introInBabbage introInConway -> - let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsConway introInAlonzo - Ledger.PParamsUpdate inBab = createIntroducedInBabbagePParams BabbageEraOnwardsConway introInBabbage - Ledger.PParamsUpdate inCon = createIntroducedInConwayPParams introInConway - in Ledger.PParamsUpdate $ common <> inAlonzoPParams <> inBab <> inCon - + let Ledger.PParamsUpdate common = createCommonPParamsUpdate c + Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsConway introInAlonzo + Ledger.PParamsUpdate inBab = createIntroducedInBabbagePParams BabbageEraOnwardsConway introInBabbage + Ledger.PParamsUpdate inCon = createIntroducedInConwayPParams introInConway + in Ledger.PParamsUpdate $ common <> inAlonzoPParams <> inBab <> inCon -- | Protocol parameters common to each era. This can only ever be reduced -- if parameters are deprecated. data CommonProtocolParametersUpdate = CommonProtocolParametersUpdate - { cppMinFeeA :: StrictMaybe Ledger.Coin - , cppMinFeeB :: StrictMaybe Ledger.Coin - , cppMaxBlockBodySize :: StrictMaybe Word32 - , cppMaxTxSize :: StrictMaybe Word32 - , cppMaxBlockHeaderSize :: StrictMaybe Word16 - , cppKeyDeposit :: StrictMaybe Ledger.Coin - , cppPoolDeposit :: StrictMaybe Ledger.Coin - , cppPoolRetireMaxEpoch :: StrictMaybe Ledger.EpochInterval - , cppStakePoolTargetNum :: StrictMaybe Natural - , cppPoolPledgeInfluence :: StrictMaybe Ledger.NonNegativeInterval - , cppTreasuryExpansion :: StrictMaybe Ledger.UnitInterval - , cppMonetaryExpansion :: StrictMaybe Ledger.UnitInterval - , cppMinPoolCost :: StrictMaybe Ledger.Coin - } deriving Show + { cppMinFeeA :: StrictMaybe Ledger.Coin + , cppMinFeeB :: StrictMaybe Ledger.Coin + , cppMaxBlockBodySize :: StrictMaybe Word32 + , cppMaxTxSize :: StrictMaybe Word32 + , cppMaxBlockHeaderSize :: StrictMaybe Word16 + , cppKeyDeposit :: StrictMaybe Ledger.Coin + , cppPoolDeposit :: StrictMaybe Ledger.Coin + , cppPoolRetireMaxEpoch :: StrictMaybe Ledger.EpochInterval + , cppStakePoolTargetNum :: StrictMaybe Natural + , cppPoolPledgeInfluence :: StrictMaybe Ledger.NonNegativeInterval + , cppTreasuryExpansion :: StrictMaybe Ledger.UnitInterval + , cppMonetaryExpansion :: StrictMaybe Ledger.UnitInterval + , cppMinPoolCost :: StrictMaybe Ledger.Coin + } + deriving (Show) -- | Create a protocol parameters update with parameters common to all eras createCommonPParamsUpdate :: EraPParams ledgerera => CommonProtocolParametersUpdate -> Ledger.PParamsUpdate ledgerera -createCommonPParamsUpdate CommonProtocolParametersUpdate{..} = +createCommonPParamsUpdate CommonProtocolParametersUpdate {..} = emptyPParamsUpdate & Ledger.ppuMinFeeAL .~ cppMinFeeA & Ledger.ppuMinFeeBL .~ cppMinFeeB @@ -377,11 +373,11 @@ createPreConwayProtocolVersionUpdate (DeprecatedAfterBabbagePParams cppProtocolV newtype DeprecatedAfterMaryPParams ledgerera = DeprecatedAfterMaryPParams (StrictMaybe Ledger.Coin) -- Minimum UTxO value - deriving Show + deriving (Show) newtype DeprecatedAfterBabbagePParams ledgerera = DeprecatedAfterBabbagePParams (StrictMaybe Ledger.ProtVer) - deriving Show + deriving (Show) type MaxMaryEra ledgerera = Ledger.ProtVerAtMost ledgerera 4 @@ -394,10 +390,11 @@ createDeprecatedAfterMaryPParams _ (DeprecatedAfterMaryPParams minUtxoVal) = data ShelleyToAlonzoPParams ledgerera = ShelleyToAlonzoPParams - (StrictMaybe Ledger.Nonce) -- ^ Extra entropy - (StrictMaybe Ledger.UnitInterval) -- ^ Decentralization parameter - deriving Show - + (StrictMaybe Ledger.Nonce) + -- ^ Extra entropy + (StrictMaybe Ledger.UnitInterval) + -- ^ Decentralization parameter + deriving (Show) type MaxAlonzoEra ledgerera = Ledger.ProtVerAtMost ledgerera 6 @@ -412,24 +409,24 @@ createDeprecatedAfterAlonzoPParams _ (ShelleyToAlonzoPParams extraEntropy decent & Ledger.ppuExtraEntropyL .~ extraEntropy & Ledger.ppuDL .~ decentralization - data AlonzoOnwardsPParams ledgerera = AlonzoOnwardsPParams - { alCostModels :: StrictMaybe Alonzo.CostModels - , alPrices :: StrictMaybe Alonzo.Prices - , alMaxTxExUnits :: StrictMaybe Alonzo.ExUnits - , alMaxBlockExUnits :: StrictMaybe Alonzo.ExUnits - , alMaxValSize :: StrictMaybe Natural - , alCollateralPercentage :: StrictMaybe Natural - , alMaxCollateralInputs :: StrictMaybe Natural - } - deriving Show + { alCostModels :: StrictMaybe Alonzo.CostModels + , alPrices :: StrictMaybe Alonzo.Prices + , alMaxTxExUnits :: StrictMaybe Alonzo.ExUnits + , alMaxBlockExUnits :: StrictMaybe Alonzo.ExUnits + , alMaxValSize :: StrictMaybe Natural + , alCollateralPercentage :: StrictMaybe Natural + , alMaxCollateralInputs :: StrictMaybe Natural + } + deriving (Show) -createPParamsUpdateIntroducedInAlonzo :: () +createPParamsUpdateIntroducedInAlonzo + :: () => AlonzoEraOnwards era -> AlonzoOnwardsPParams era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) -createPParamsUpdateIntroducedInAlonzo w (AlonzoOnwardsPParams {..})= +createPParamsUpdateIntroducedInAlonzo w (AlonzoOnwardsPParams {..}) = alonzoEraOnwardsConstraints w $ Ledger.emptyPParamsUpdate & Ledger.ppuCostModelsL .~ alCostModels @@ -441,11 +438,13 @@ createPParamsUpdateIntroducedInAlonzo w (AlonzoOnwardsPParams {..})= & Ledger.ppuMaxCollateralInputsL .~ alMaxCollateralInputs newtype IntroducedInBabbagePParams era - = IntroducedInBabbagePParams - (StrictMaybe CoinPerByte) -- ^ Coins per UTxO byte - deriving Show + = -- | Coins per UTxO byte + IntroducedInBabbagePParams + (StrictMaybe CoinPerByte) + deriving (Show) -createIntroducedInBabbagePParams :: () +createIntroducedInBabbagePParams + :: () => BabbageEraOnwards era -> IntroducedInBabbagePParams era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) @@ -463,164 +462,126 @@ createIntroducedInBabbagePParams w (IntroducedInBabbagePParams coinsPerUTxOByte) -- 'ProtocolParameters'. -- -- There are also parameters fixed in the Genesis file. See 'GenesisParameters'. --- -{-# DEPRECATED ProtocolParameters "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -data ProtocolParameters = - ProtocolParameters { - - -- | Protocol version, major and minor. Updating the major version is - -- used to trigger hard forks. - -- (Major , Minor ) - protocolParamProtocolVersion :: (Natural, Natural), - - -- | The decentralization parameter. This is fraction of slots that - -- belong to the BFT overlay schedule, rather than the Praos schedule. - -- So 1 means fully centralised, while 0 means fully decentralised. - -- - -- This is the \"d\" parameter from the design document. - -- - -- /Deprecated in Babbage/ - protocolParamDecentralization :: Maybe Rational, - - -- | Extra entropy for the Praos per-epoch nonce. - -- - -- This can be used to add extra entropy during the decentralisation - -- process. If the extra entropy can be demonstrated to be generated - -- randomly then this method can be used to show that the initial - -- federated operators did not subtly bias the initial schedule so that - -- they retain undue influence after decentralisation. - -- - protocolParamExtraPraosEntropy :: Maybe PraosNonce, - - -- | The maximum permitted size of a block header. - -- - -- This must be at least as big as the largest legitimate block headers - -- but should not be too much larger, to help prevent DoS attacks. - -- - -- Caution: setting this to be smaller than legitimate block headers is - -- a sure way to brick the system! - -- - protocolParamMaxBlockHeaderSize :: Natural, - - -- | The maximum permitted size of the block body (that is, the block - -- payload, without the block header). - -- - -- This should be picked with the Praos network delta security parameter - -- in mind. Making this too large can severely weaken the Praos - -- consensus properties. - -- - -- Caution: setting this to be smaller than a transaction that can - -- change the protocol parameters is a sure way to brick the system! - -- - protocolParamMaxBlockBodySize :: Natural, - - -- | The maximum permitted size of a transaction. - -- - -- Typically this should not be too high a fraction of the block size, - -- otherwise wastage from block fragmentation becomes a problem, and - -- the current implementation does not use any sophisticated box packing - -- algorithm. - -- - protocolParamMaxTxSize :: Natural, - - -- | The constant factor for the minimum fee calculation. - -- - protocolParamTxFeeFixed :: L.Coin, - - -- | Per byte linear factor for the minimum fee calculation. - -- - protocolParamTxFeePerByte :: L.Coin, - - -- | The minimum permitted value for new UTxO entries, ie for - -- transaction outputs. - -- - protocolParamMinUTxOValue :: Maybe L.Coin, - - -- | The deposit required to register a stake address. - -- - protocolParamStakeAddressDeposit :: L.Coin, - - -- | The deposit required to register a stake pool. - -- - protocolParamStakePoolDeposit :: L.Coin, - - -- | The minimum value that stake pools are permitted to declare for - -- their cost parameter. - -- - protocolParamMinPoolCost :: L.Coin, - - -- | The maximum number of epochs into the future that stake pools - -- are permitted to schedule a retirement. - -- - protocolParamPoolRetireMaxEpoch :: Ledger.EpochInterval, - - -- | The equilibrium target number of stake pools. - -- - -- This is the \"k\" incentives parameter from the design document. - -- - protocolParamStakePoolTargetNum :: Natural, - - -- | The influence of the pledge in stake pool rewards. - -- - -- This is the \"a_0\" incentives parameter from the design document. - -- - protocolParamPoolPledgeInfluence :: Rational, - - -- | The monetary expansion rate. This determines the fraction of the - -- reserves that are added to the fee pot each epoch. - -- - -- This is the \"rho\" incentives parameter from the design document. - -- - protocolParamMonetaryExpansion :: Rational, - - -- | The fraction of the fee pot each epoch that goes to the treasury. - -- - -- This is the \"tau\" incentives parameter from the design document. - -- - protocolParamTreasuryCut :: Rational, - - -- | Cost models for script languages that use them. - -- - -- /Introduced in Alonzo/ - protocolParamCostModels :: Map AnyPlutusScriptVersion CostModel, - - -- | Price of execution units for script languages that use them. - -- - -- /Introduced in Alonzo/ - protocolParamPrices :: Maybe ExecutionUnitPrices, - - -- | Max total script execution resources units allowed per tx - -- - -- /Introduced in Alonzo/ - protocolParamMaxTxExUnits :: Maybe ExecutionUnits, - - -- | Max total script execution resources units allowed per block - -- - -- /Introduced in Alonzo/ - protocolParamMaxBlockExUnits :: Maybe ExecutionUnits, - - -- | Max size of a Value in a tx output. - -- - -- /Introduced in Alonzo/ - protocolParamMaxValueSize :: Maybe Natural, - - -- | The percentage of the script contribution to the txfee that must be - -- provided as collateral inputs when including Plutus scripts. - -- - -- /Introduced in Alonzo/ - protocolParamCollateralPercent :: Maybe Natural, - - -- | The maximum number of collateral inputs allowed in a transaction. - -- - -- /Introduced in Alonzo/ - protocolParamMaxCollateralInputs :: Maybe Natural, - - -- | Cost in ada per byte of UTxO storage. - -- - -- /Introduced in Babbage/ - protocolParamUTxOCostPerByte :: Maybe L.Coin - - } +{-# DEPRECATED + ProtocolParameters + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} + +data ProtocolParameters + = ProtocolParameters + { protocolParamProtocolVersion :: (Natural, Natural) + -- ^ Protocol version, major and minor. Updating the major version is + -- used to trigger hard forks. + -- (Major , Minor ) + , protocolParamDecentralization :: Maybe Rational + -- ^ The decentralization parameter. This is fraction of slots that + -- belong to the BFT overlay schedule, rather than the Praos schedule. + -- So 1 means fully centralised, while 0 means fully decentralised. + -- + -- This is the \"d\" parameter from the design document. + -- + -- /Deprecated in Babbage/ + , protocolParamExtraPraosEntropy :: Maybe PraosNonce + -- ^ Extra entropy for the Praos per-epoch nonce. + -- + -- This can be used to add extra entropy during the decentralisation + -- process. If the extra entropy can be demonstrated to be generated + -- randomly then this method can be used to show that the initial + -- federated operators did not subtly bias the initial schedule so that + -- they retain undue influence after decentralisation. + , protocolParamMaxBlockHeaderSize :: Natural + -- ^ The maximum permitted size of a block header. + -- + -- This must be at least as big as the largest legitimate block headers + -- but should not be too much larger, to help prevent DoS attacks. + -- + -- Caution: setting this to be smaller than legitimate block headers is + -- a sure way to brick the system! + , protocolParamMaxBlockBodySize :: Natural + -- ^ The maximum permitted size of the block body (that is, the block + -- payload, without the block header). + -- + -- This should be picked with the Praos network delta security parameter + -- in mind. Making this too large can severely weaken the Praos + -- consensus properties. + -- + -- Caution: setting this to be smaller than a transaction that can + -- change the protocol parameters is a sure way to brick the system! + , protocolParamMaxTxSize :: Natural + -- ^ The maximum permitted size of a transaction. + -- + -- Typically this should not be too high a fraction of the block size, + -- otherwise wastage from block fragmentation becomes a problem, and + -- the current implementation does not use any sophisticated box packing + -- algorithm. + , protocolParamTxFeeFixed :: L.Coin + -- ^ The constant factor for the minimum fee calculation. + , protocolParamTxFeePerByte :: L.Coin + -- ^ Per byte linear factor for the minimum fee calculation. + , protocolParamMinUTxOValue :: Maybe L.Coin + -- ^ The minimum permitted value for new UTxO entries, ie for + -- transaction outputs. + , protocolParamStakeAddressDeposit :: L.Coin + -- ^ The deposit required to register a stake address. + , protocolParamStakePoolDeposit :: L.Coin + -- ^ The deposit required to register a stake pool. + , protocolParamMinPoolCost :: L.Coin + -- ^ The minimum value that stake pools are permitted to declare for + -- their cost parameter. + , protocolParamPoolRetireMaxEpoch :: Ledger.EpochInterval + -- ^ The maximum number of epochs into the future that stake pools + -- are permitted to schedule a retirement. + , protocolParamStakePoolTargetNum :: Natural + -- ^ The equilibrium target number of stake pools. + -- + -- This is the \"k\" incentives parameter from the design document. + , protocolParamPoolPledgeInfluence :: Rational + -- ^ The influence of the pledge in stake pool rewards. + -- + -- This is the \"a_0\" incentives parameter from the design document. + , protocolParamMonetaryExpansion :: Rational + -- ^ The monetary expansion rate. This determines the fraction of the + -- reserves that are added to the fee pot each epoch. + -- + -- This is the \"rho\" incentives parameter from the design document. + , protocolParamTreasuryCut :: Rational + -- ^ The fraction of the fee pot each epoch that goes to the treasury. + -- + -- This is the \"tau\" incentives parameter from the design document. + , protocolParamCostModels :: Map AnyPlutusScriptVersion CostModel + -- ^ Cost models for script languages that use them. + -- + -- /Introduced in Alonzo/ + , protocolParamPrices :: Maybe ExecutionUnitPrices + -- ^ Price of execution units for script languages that use them. + -- + -- /Introduced in Alonzo/ + , protocolParamMaxTxExUnits :: Maybe ExecutionUnits + -- ^ Max total script execution resources units allowed per tx + -- + -- /Introduced in Alonzo/ + , protocolParamMaxBlockExUnits :: Maybe ExecutionUnits + -- ^ Max total script execution resources units allowed per block + -- + -- /Introduced in Alonzo/ + , protocolParamMaxValueSize :: Maybe Natural + -- ^ Max size of a Value in a tx output. + -- + -- /Introduced in Alonzo/ + , protocolParamCollateralPercent :: Maybe Natural + -- ^ The percentage of the script contribution to the txfee that must be + -- provided as collateral inputs when including Plutus scripts. + -- + -- /Introduced in Alonzo/ + , protocolParamMaxCollateralInputs :: Maybe Natural + -- ^ The maximum number of collateral inputs allowed in a transaction. + -- + -- /Introduced in Alonzo/ + , protocolParamUTxOCostPerByte :: Maybe L.Coin + -- ^ Cost in ada per byte of UTxO storage. + -- + -- /Introduced in Babbage/ + } deriving (Eq, Generic, Show) instance FromJSON ProtocolParameters where @@ -655,366 +616,322 @@ instance FromJSON ProtocolParameters where <*> o .:? "utxoCostPerByte" instance ToJSON ProtocolParameters where - toJSON ProtocolParameters{..} = + toJSON ProtocolParameters {..} = object - [ "extraPraosEntropy" .= protocolParamExtraPraosEntropy - , "stakePoolTargetNum" .= protocolParamStakePoolTargetNum - , "minUTxOValue" .= protocolParamMinUTxOValue - , "poolRetireMaxEpoch" .= protocolParamPoolRetireMaxEpoch - , "decentralization" .= (toRationalJSON <$> protocolParamDecentralization) - , "stakePoolDeposit" .= protocolParamStakePoolDeposit - , "maxBlockHeaderSize" .= protocolParamMaxBlockHeaderSize - , "maxBlockBodySize" .= protocolParamMaxBlockBodySize - , "maxTxSize" .= protocolParamMaxTxSize - , "treasuryCut" .= toRationalJSON protocolParamTreasuryCut - , "minPoolCost" .= protocolParamMinPoolCost - , "monetaryExpansion" .= toRationalJSON protocolParamMonetaryExpansion + [ "extraPraosEntropy" .= protocolParamExtraPraosEntropy + , "stakePoolTargetNum" .= protocolParamStakePoolTargetNum + , "minUTxOValue" .= protocolParamMinUTxOValue + , "poolRetireMaxEpoch" .= protocolParamPoolRetireMaxEpoch + , "decentralization" .= (toRationalJSON <$> protocolParamDecentralization) + , "stakePoolDeposit" .= protocolParamStakePoolDeposit + , "maxBlockHeaderSize" .= protocolParamMaxBlockHeaderSize + , "maxBlockBodySize" .= protocolParamMaxBlockBodySize + , "maxTxSize" .= protocolParamMaxTxSize + , "treasuryCut" .= toRationalJSON protocolParamTreasuryCut + , "minPoolCost" .= protocolParamMinPoolCost + , "monetaryExpansion" .= toRationalJSON protocolParamMonetaryExpansion , "stakeAddressDeposit" .= protocolParamStakeAddressDeposit , "poolPledgeInfluence" .= toRationalJSON protocolParamPoolPledgeInfluence - , "protocolVersion" .= let (major, minor) = protocolParamProtocolVersion - in object ["major" .= major, "minor" .= minor] - , "txFeeFixed" .= protocolParamTxFeeFixed - , "txFeePerByte" .= protocolParamTxFeePerByte - -- Alonzo era: - , "costModels" .= CostModels protocolParamCostModels - , "executionUnitPrices" .= protocolParamPrices - , "maxTxExecutionUnits" .= protocolParamMaxTxExUnits + , "protocolVersion" + .= let (major, minor) = protocolParamProtocolVersion + in object ["major" .= major, "minor" .= minor] + , "txFeeFixed" .= protocolParamTxFeeFixed + , "txFeePerByte" .= protocolParamTxFeePerByte + , -- Alonzo era: + "costModels" .= CostModels protocolParamCostModels + , "executionUnitPrices" .= protocolParamPrices + , "maxTxExecutionUnits" .= protocolParamMaxTxExUnits , "maxBlockExecutionUnits" .= protocolParamMaxBlockExUnits - , "maxValueSize" .= protocolParamMaxValueSize - , "collateralPercentage" .= protocolParamCollateralPercent - , "maxCollateralInputs" .= protocolParamMaxCollateralInputs - -- Babbage era: - , "utxoCostPerByte" .= protocolParamUTxOCostPerByte + , "maxValueSize" .= protocolParamMaxValueSize + , "collateralPercentage" .= protocolParamCollateralPercent + , "maxCollateralInputs" .= protocolParamMaxCollateralInputs + , -- Babbage era: + "utxoCostPerByte" .= protocolParamUTxOCostPerByte ] - -- ---------------------------------------------------------------------------- -- Updates to the protocol parameters -- -- | The representation of a change in the 'ProtocolParameters'. --- -data ProtocolParametersUpdate = - ProtocolParametersUpdate { - - -- | Protocol version, major and minor. Updating the major version is - -- used to trigger hard forks. - -- - protocolUpdateProtocolVersion :: Maybe (Natural, Natural), - - -- | The decentralization parameter. This is fraction of slots that - -- belong to the BFT overlay schedule, rather than the Praos schedule. - -- So 1 means fully centralised, while 0 means fully decentralised. - -- - -- This is the \"d\" parameter from the design document. - -- - protocolUpdateDecentralization :: Maybe Rational, - - -- | Extra entropy for the Praos per-epoch nonce. - -- - -- This can be used to add extra entropy during the decentralisation - -- process. If the extra entropy can be demonstrated to be generated - -- randomly then this method can be used to show that the initial - -- federated operators did not subtly bias the initial schedule so that - -- they retain undue influence after decentralisation. - -- - protocolUpdateExtraPraosEntropy :: Maybe (Maybe PraosNonce), - - -- | The maximum permitted size of a block header. - -- - -- This must be at least as big as the largest legitimate block headers - -- but should not be too much larger, to help prevent DoS attacks. - -- - -- Caution: setting this to be smaller than legitimate block headers is - -- a sure way to brick the system! - -- - protocolUpdateMaxBlockHeaderSize :: Maybe Word16, - - -- | The maximum permitted size of the block body (that is, the block - -- payload, without the block header). - -- - -- This should be picked with the Praos network delta security parameter - -- in mind. Making this too large can severely weaken the Praos - -- consensus properties. - -- - -- Caution: setting this to be smaller than a transaction that can - -- change the protocol parameters is a sure way to brick the system! - -- - protocolUpdateMaxBlockBodySize :: Maybe Word32, - - -- | The maximum permitted size of a transaction. - -- - -- Typically this should not be too high a fraction of the block size, - -- otherwise wastage from block fragmentation becomes a problem, and - -- the current implementation does not use any sophisticated box packing - -- algorithm. - -- - protocolUpdateMaxTxSize :: Maybe Word32, - - -- | The constant factor for the minimum fee calculation. - -- - protocolUpdateTxFeeFixed :: Maybe L.Coin, - - -- | The linear factor for the minimum fee calculation. - -- - protocolUpdateTxFeePerByte :: Maybe L.Coin, - - -- | The minimum permitted value for new UTxO entries, ie for - -- transaction outputs. - -- - protocolUpdateMinUTxOValue :: Maybe L.Coin, - - -- | The deposit required to register a stake address. - -- - protocolUpdateStakeAddressDeposit :: Maybe L.Coin, - - -- | The deposit required to register a stake pool. - -- - protocolUpdateStakePoolDeposit :: Maybe L.Coin, - - -- | The minimum value that stake pools are permitted to declare for - -- their cost parameter. - -- - protocolUpdateMinPoolCost :: Maybe L.Coin, - - -- | The maximum number of epochs into the future that stake pools - -- are permitted to schedule a retirement. - -- - protocolUpdatePoolRetireMaxEpoch :: Maybe Ledger.EpochInterval, - - -- | The equilibrium target number of stake pools. - -- - -- This is the \"k\" incentives parameter from the design document. - -- - protocolUpdateStakePoolTargetNum :: Maybe Natural, - - -- | The influence of the pledge in stake pool rewards. - -- - -- This is the \"a_0\" incentives parameter from the design document. - -- - protocolUpdatePoolPledgeInfluence :: Maybe Rational, - - -- | The monetary expansion rate. This determines the fraction of the - -- reserves that are added to the fee pot each epoch. - -- - -- This is the \"rho\" incentives parameter from the design document. - -- - protocolUpdateMonetaryExpansion :: Maybe Rational, - - -- | The fraction of the fee pot each epoch that goes to the treasury. - -- - -- This is the \"tau\" incentives parameter from the design document. - -- - protocolUpdateTreasuryCut :: Maybe Rational, - - -- Introduced in Alonzo, - - -- | Cost models for script languages that use them. - -- - -- /Introduced in Alonzo/ - protocolUpdateCostModels :: Map AnyPlutusScriptVersion CostModel, - - -- | Price of execution units for script languages that use them. - -- - -- /Introduced in Alonzo/ - protocolUpdatePrices :: Maybe ExecutionUnitPrices, - - -- | Max total script execution resources units allowed per tx - -- - -- /Introduced in Alonzo/ - protocolUpdateMaxTxExUnits :: Maybe ExecutionUnits, - - -- | Max total script execution resources units allowed per block - -- - -- /Introduced in Alonzo/ - protocolUpdateMaxBlockExUnits :: Maybe ExecutionUnits, - - -- | Max size of a 'Value' in a tx output. - -- - -- /Introduced in Alonzo/ - protocolUpdateMaxValueSize :: Maybe Natural, - - -- | The percentage of the script contribution to the txfee that must be - -- provided as collateral inputs when including Plutus scripts. - -- - -- /Introduced in Alonzo/ - protocolUpdateCollateralPercent :: Maybe Natural, - - -- | The maximum number of collateral inputs allowed in a transaction. - -- - -- /Introduced in Alonzo/ - protocolUpdateMaxCollateralInputs :: Maybe Natural, - - -- | Cost in ada per byte of UTxO storage. - -- - -- /Introduced in Babbage/ - protocolUpdateUTxOCostPerByte :: Maybe L.Coin - } +data ProtocolParametersUpdate + = ProtocolParametersUpdate + { protocolUpdateProtocolVersion :: Maybe (Natural, Natural) + -- ^ Protocol version, major and minor. Updating the major version is + -- used to trigger hard forks. + , protocolUpdateDecentralization :: Maybe Rational + -- ^ The decentralization parameter. This is fraction of slots that + -- belong to the BFT overlay schedule, rather than the Praos schedule. + -- So 1 means fully centralised, while 0 means fully decentralised. + -- + -- This is the \"d\" parameter from the design document. + , protocolUpdateExtraPraosEntropy :: Maybe (Maybe PraosNonce) + -- ^ Extra entropy for the Praos per-epoch nonce. + -- + -- This can be used to add extra entropy during the decentralisation + -- process. If the extra entropy can be demonstrated to be generated + -- randomly then this method can be used to show that the initial + -- federated operators did not subtly bias the initial schedule so that + -- they retain undue influence after decentralisation. + , protocolUpdateMaxBlockHeaderSize :: Maybe Word16 + -- ^ The maximum permitted size of a block header. + -- + -- This must be at least as big as the largest legitimate block headers + -- but should not be too much larger, to help prevent DoS attacks. + -- + -- Caution: setting this to be smaller than legitimate block headers is + -- a sure way to brick the system! + , protocolUpdateMaxBlockBodySize :: Maybe Word32 + -- ^ The maximum permitted size of the block body (that is, the block + -- payload, without the block header). + -- + -- This should be picked with the Praos network delta security parameter + -- in mind. Making this too large can severely weaken the Praos + -- consensus properties. + -- + -- Caution: setting this to be smaller than a transaction that can + -- change the protocol parameters is a sure way to brick the system! + , protocolUpdateMaxTxSize :: Maybe Word32 + -- ^ The maximum permitted size of a transaction. + -- + -- Typically this should not be too high a fraction of the block size, + -- otherwise wastage from block fragmentation becomes a problem, and + -- the current implementation does not use any sophisticated box packing + -- algorithm. + , protocolUpdateTxFeeFixed :: Maybe L.Coin + -- ^ The constant factor for the minimum fee calculation. + , protocolUpdateTxFeePerByte :: Maybe L.Coin + -- ^ The linear factor for the minimum fee calculation. + , protocolUpdateMinUTxOValue :: Maybe L.Coin + -- ^ The minimum permitted value for new UTxO entries, ie for + -- transaction outputs. + , protocolUpdateStakeAddressDeposit :: Maybe L.Coin + -- ^ The deposit required to register a stake address. + , protocolUpdateStakePoolDeposit :: Maybe L.Coin + -- ^ The deposit required to register a stake pool. + , protocolUpdateMinPoolCost :: Maybe L.Coin + -- ^ The minimum value that stake pools are permitted to declare for + -- their cost parameter. + , protocolUpdatePoolRetireMaxEpoch :: Maybe Ledger.EpochInterval + -- ^ The maximum number of epochs into the future that stake pools + -- are permitted to schedule a retirement. + , protocolUpdateStakePoolTargetNum :: Maybe Natural + -- ^ The equilibrium target number of stake pools. + -- + -- This is the \"k\" incentives parameter from the design document. + , protocolUpdatePoolPledgeInfluence :: Maybe Rational + -- ^ The influence of the pledge in stake pool rewards. + -- + -- This is the \"a_0\" incentives parameter from the design document. + , protocolUpdateMonetaryExpansion :: Maybe Rational + -- ^ The monetary expansion rate. This determines the fraction of the + -- reserves that are added to the fee pot each epoch. + -- + -- This is the \"rho\" incentives parameter from the design document. + , protocolUpdateTreasuryCut :: Maybe Rational + -- ^ The fraction of the fee pot each epoch that goes to the treasury. + -- + -- This is the \"tau\" incentives parameter from the design document. + , -- Introduced in Alonzo, + + protocolUpdateCostModels :: Map AnyPlutusScriptVersion CostModel + -- ^ Cost models for script languages that use them. + -- + -- /Introduced in Alonzo/ + , protocolUpdatePrices :: Maybe ExecutionUnitPrices + -- ^ Price of execution units for script languages that use them. + -- + -- /Introduced in Alonzo/ + , protocolUpdateMaxTxExUnits :: Maybe ExecutionUnits + -- ^ Max total script execution resources units allowed per tx + -- + -- /Introduced in Alonzo/ + , protocolUpdateMaxBlockExUnits :: Maybe ExecutionUnits + -- ^ Max total script execution resources units allowed per block + -- + -- /Introduced in Alonzo/ + , protocolUpdateMaxValueSize :: Maybe Natural + -- ^ Max size of a 'Value' in a tx output. + -- + -- /Introduced in Alonzo/ + , protocolUpdateCollateralPercent :: Maybe Natural + -- ^ The percentage of the script contribution to the txfee that must be + -- provided as collateral inputs when including Plutus scripts. + -- + -- /Introduced in Alonzo/ + , protocolUpdateMaxCollateralInputs :: Maybe Natural + -- ^ The maximum number of collateral inputs allowed in a transaction. + -- + -- /Introduced in Alonzo/ + , protocolUpdateUTxOCostPerByte :: Maybe L.Coin + -- ^ Cost in ada per byte of UTxO storage. + -- + -- /Introduced in Babbage/ + } deriving (Eq, Show) instance Semigroup ProtocolParametersUpdate where - ppu1 <> ppu2 = - ProtocolParametersUpdate { - protocolUpdateProtocolVersion = merge protocolUpdateProtocolVersion - , protocolUpdateDecentralization = merge protocolUpdateDecentralization - , protocolUpdateExtraPraosEntropy = merge protocolUpdateExtraPraosEntropy - , protocolUpdateMaxBlockHeaderSize = merge protocolUpdateMaxBlockHeaderSize - , protocolUpdateMaxBlockBodySize = merge protocolUpdateMaxBlockBodySize - , protocolUpdateMaxTxSize = merge protocolUpdateMaxTxSize - , protocolUpdateTxFeeFixed = merge protocolUpdateTxFeeFixed - , protocolUpdateTxFeePerByte = merge protocolUpdateTxFeePerByte - , protocolUpdateMinUTxOValue = merge protocolUpdateMinUTxOValue + ppu1 <> ppu2 = + ProtocolParametersUpdate + { protocolUpdateProtocolVersion = merge protocolUpdateProtocolVersion + , protocolUpdateDecentralization = merge protocolUpdateDecentralization + , protocolUpdateExtraPraosEntropy = merge protocolUpdateExtraPraosEntropy + , protocolUpdateMaxBlockHeaderSize = merge protocolUpdateMaxBlockHeaderSize + , protocolUpdateMaxBlockBodySize = merge protocolUpdateMaxBlockBodySize + , protocolUpdateMaxTxSize = merge protocolUpdateMaxTxSize + , protocolUpdateTxFeeFixed = merge protocolUpdateTxFeeFixed + , protocolUpdateTxFeePerByte = merge protocolUpdateTxFeePerByte + , protocolUpdateMinUTxOValue = merge protocolUpdateMinUTxOValue , protocolUpdateStakeAddressDeposit = merge protocolUpdateStakeAddressDeposit - , protocolUpdateStakePoolDeposit = merge protocolUpdateStakePoolDeposit - , protocolUpdateMinPoolCost = merge protocolUpdateMinPoolCost - , protocolUpdatePoolRetireMaxEpoch = merge protocolUpdatePoolRetireMaxEpoch - , protocolUpdateStakePoolTargetNum = merge protocolUpdateStakePoolTargetNum + , protocolUpdateStakePoolDeposit = merge protocolUpdateStakePoolDeposit + , protocolUpdateMinPoolCost = merge protocolUpdateMinPoolCost + , protocolUpdatePoolRetireMaxEpoch = merge protocolUpdatePoolRetireMaxEpoch + , protocolUpdateStakePoolTargetNum = merge protocolUpdateStakePoolTargetNum , protocolUpdatePoolPledgeInfluence = merge protocolUpdatePoolPledgeInfluence - , protocolUpdateMonetaryExpansion = merge protocolUpdateMonetaryExpansion - , protocolUpdateTreasuryCut = merge protocolUpdateTreasuryCut - -- Introduced in Alonzo below. - , protocolUpdateCostModels = mergeMap protocolUpdateCostModels - , protocolUpdatePrices = merge protocolUpdatePrices - , protocolUpdateMaxTxExUnits = merge protocolUpdateMaxTxExUnits - , protocolUpdateMaxBlockExUnits = merge protocolUpdateMaxBlockExUnits - , protocolUpdateMaxValueSize = merge protocolUpdateMaxValueSize - , protocolUpdateCollateralPercent = merge protocolUpdateCollateralPercent + , protocolUpdateMonetaryExpansion = merge protocolUpdateMonetaryExpansion + , protocolUpdateTreasuryCut = merge protocolUpdateTreasuryCut + , -- Introduced in Alonzo below. + protocolUpdateCostModels = mergeMap protocolUpdateCostModels + , protocolUpdatePrices = merge protocolUpdatePrices + , protocolUpdateMaxTxExUnits = merge protocolUpdateMaxTxExUnits + , protocolUpdateMaxBlockExUnits = merge protocolUpdateMaxBlockExUnits + , protocolUpdateMaxValueSize = merge protocolUpdateMaxValueSize + , protocolUpdateCollateralPercent = merge protocolUpdateCollateralPercent , protocolUpdateMaxCollateralInputs = merge protocolUpdateMaxCollateralInputs - -- Introduced in Babbage below. - , protocolUpdateUTxOCostPerByte = merge protocolUpdateUTxOCostPerByte + , -- Introduced in Babbage below. + protocolUpdateUTxOCostPerByte = merge protocolUpdateUTxOCostPerByte } - where - -- prefer the right hand side: - merge :: (ProtocolParametersUpdate -> Maybe a) -> Maybe a - merge f = f ppu2 `mplus` f ppu1 + where + -- prefer the right hand side: + merge :: (ProtocolParametersUpdate -> Maybe a) -> Maybe a + merge f = f ppu2 `mplus` f ppu1 - -- prefer the right hand side: - mergeMap :: Ord k => (ProtocolParametersUpdate -> Map k a) -> Map k a - mergeMap f = f ppu2 `Map.union` f ppu1 + -- prefer the right hand side: + mergeMap :: Ord k => (ProtocolParametersUpdate -> Map k a) -> Map k a + mergeMap f = f ppu2 `Map.union` f ppu1 instance Monoid ProtocolParametersUpdate where - mempty = - ProtocolParametersUpdate { - protocolUpdateProtocolVersion = Nothing - , protocolUpdateDecentralization = Nothing - , protocolUpdateExtraPraosEntropy = Nothing - , protocolUpdateMaxBlockHeaderSize = Nothing - , protocolUpdateMaxBlockBodySize = Nothing - , protocolUpdateMaxTxSize = Nothing - , protocolUpdateTxFeeFixed = Nothing - , protocolUpdateTxFeePerByte = Nothing - , protocolUpdateMinUTxOValue = Nothing + mempty = + ProtocolParametersUpdate + { protocolUpdateProtocolVersion = Nothing + , protocolUpdateDecentralization = Nothing + , protocolUpdateExtraPraosEntropy = Nothing + , protocolUpdateMaxBlockHeaderSize = Nothing + , protocolUpdateMaxBlockBodySize = Nothing + , protocolUpdateMaxTxSize = Nothing + , protocolUpdateTxFeeFixed = Nothing + , protocolUpdateTxFeePerByte = Nothing + , protocolUpdateMinUTxOValue = Nothing , protocolUpdateStakeAddressDeposit = Nothing - , protocolUpdateStakePoolDeposit = Nothing - , protocolUpdateMinPoolCost = Nothing - , protocolUpdatePoolRetireMaxEpoch = Nothing - , protocolUpdateStakePoolTargetNum = Nothing + , protocolUpdateStakePoolDeposit = Nothing + , protocolUpdateMinPoolCost = Nothing + , protocolUpdatePoolRetireMaxEpoch = Nothing + , protocolUpdateStakePoolTargetNum = Nothing , protocolUpdatePoolPledgeInfluence = Nothing - , protocolUpdateMonetaryExpansion = Nothing - , protocolUpdateTreasuryCut = Nothing - , protocolUpdateCostModels = mempty - , protocolUpdatePrices = Nothing - , protocolUpdateMaxTxExUnits = Nothing - , protocolUpdateMaxBlockExUnits = Nothing - , protocolUpdateMaxValueSize = Nothing - , protocolUpdateCollateralPercent = Nothing + , protocolUpdateMonetaryExpansion = Nothing + , protocolUpdateTreasuryCut = Nothing + , protocolUpdateCostModels = mempty + , protocolUpdatePrices = Nothing + , protocolUpdateMaxTxExUnits = Nothing + , protocolUpdateMaxBlockExUnits = Nothing + , protocolUpdateMaxValueSize = Nothing + , protocolUpdateCollateralPercent = Nothing , protocolUpdateMaxCollateralInputs = Nothing - , protocolUpdateUTxOCostPerByte = Nothing + , protocolUpdateUTxOCostPerByte = Nothing } instance ToCBOR ProtocolParametersUpdate where - toCBOR :: ProtocolParametersUpdate -> CBOR.Encoding - toCBOR ProtocolParametersUpdate{..} = - CBOR.encodeListLen 26 - <> toCBOR protocolUpdateProtocolVersion - <> toCBOR protocolUpdateDecentralization - <> toCBOR protocolUpdateExtraPraosEntropy - <> toCBOR protocolUpdateMaxBlockHeaderSize - <> toCBOR protocolUpdateMaxBlockBodySize - <> toCBOR protocolUpdateMaxTxSize - <> toCBOR protocolUpdateTxFeeFixed - <> toCBOR protocolUpdateTxFeePerByte - <> toCBOR protocolUpdateMinUTxOValue - <> toCBOR protocolUpdateStakeAddressDeposit - <> toCBOR protocolUpdateStakePoolDeposit - <> toCBOR protocolUpdateMinPoolCost - <> toCBOR protocolUpdatePoolRetireMaxEpoch - <> toCBOR protocolUpdateStakePoolTargetNum - <> toCBOR protocolUpdatePoolPledgeInfluence - <> toCBOR protocolUpdateMonetaryExpansion - <> toCBOR protocolUpdateTreasuryCut - <> toCBOR protocolUpdateCostModels - <> toCBOR protocolUpdatePrices - <> toCBOR protocolUpdateMaxTxExUnits - <> toCBOR protocolUpdateMaxBlockExUnits - <> toCBOR protocolUpdateMaxValueSize - <> toCBOR protocolUpdateCollateralPercent - <> toCBOR protocolUpdateMaxCollateralInputs - <> toCBOR protocolUpdateUTxOCostPerByte + toCBOR :: ProtocolParametersUpdate -> CBOR.Encoding + toCBOR ProtocolParametersUpdate {..} = + CBOR.encodeListLen 26 + <> toCBOR protocolUpdateProtocolVersion + <> toCBOR protocolUpdateDecentralization + <> toCBOR protocolUpdateExtraPraosEntropy + <> toCBOR protocolUpdateMaxBlockHeaderSize + <> toCBOR protocolUpdateMaxBlockBodySize + <> toCBOR protocolUpdateMaxTxSize + <> toCBOR protocolUpdateTxFeeFixed + <> toCBOR protocolUpdateTxFeePerByte + <> toCBOR protocolUpdateMinUTxOValue + <> toCBOR protocolUpdateStakeAddressDeposit + <> toCBOR protocolUpdateStakePoolDeposit + <> toCBOR protocolUpdateMinPoolCost + <> toCBOR protocolUpdatePoolRetireMaxEpoch + <> toCBOR protocolUpdateStakePoolTargetNum + <> toCBOR protocolUpdatePoolPledgeInfluence + <> toCBOR protocolUpdateMonetaryExpansion + <> toCBOR protocolUpdateTreasuryCut + <> toCBOR protocolUpdateCostModels + <> toCBOR protocolUpdatePrices + <> toCBOR protocolUpdateMaxTxExUnits + <> toCBOR protocolUpdateMaxBlockExUnits + <> toCBOR protocolUpdateMaxValueSize + <> toCBOR protocolUpdateCollateralPercent + <> toCBOR protocolUpdateMaxCollateralInputs + <> toCBOR protocolUpdateUTxOCostPerByte + instance FromCBOR ProtocolParametersUpdate where - fromCBOR = do - CBOR.enforceSize "ProtocolParametersUpdate" 26 - ProtocolParametersUpdate - <$> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR + fromCBOR = do + CBOR.enforceSize "ProtocolParametersUpdate" 26 + ProtocolParametersUpdate + <$> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR + <*> fromCBOR -- ---------------------------------------------------------------------------- -- Praos nonce -- -newtype PraosNonce = PraosNonce { unPraosNonce :: Ledger.Hash StandardCrypto ByteString } +newtype PraosNonce = PraosNonce {unPraosNonce :: Ledger.Hash StandardCrypto ByteString} deriving stock (Eq, Ord, Generic) - deriving (Show, IsString) via UsingRawBytesHex PraosNonce + deriving (Show, IsString) via UsingRawBytesHex PraosNonce deriving (ToJSON, FromJSON) via UsingRawBytesHex PraosNonce - deriving (ToCBOR, FromCBOR) via UsingRawBytes PraosNonce + deriving (ToCBOR, FromCBOR) via UsingRawBytes PraosNonce instance HasTypeProxy PraosNonce where - data AsType PraosNonce = AsPraosNonce - proxyToAsType _ = AsPraosNonce + data AsType PraosNonce = AsPraosNonce + proxyToAsType _ = AsPraosNonce instance SerialiseAsRawBytes PraosNonce where - serialiseToRawBytes (PraosNonce h) = - Crypto.hashToBytes h - - deserialiseFromRawBytes AsPraosNonce bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise PraosNonce") $ - PraosNonce <$> Crypto.hashFromBytes bs + serialiseToRawBytes (PraosNonce h) = + Crypto.hashToBytes h + deserialiseFromRawBytes AsPraosNonce bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise PraosNonce") $ + PraosNonce <$> Crypto.hashFromBytes bs makePraosNonce :: ByteString -> PraosNonce makePraosNonce = PraosNonce . Crypto.hashWith id toLedgerNonce :: Maybe PraosNonce -> Ledger.Nonce -toLedgerNonce Nothing = Ledger.NeutralNonce +toLedgerNonce Nothing = Ledger.NeutralNonce toLedgerNonce (Just (PraosNonce h)) = Ledger.Nonce (Crypto.castHash h) fromLedgerNonce :: Ledger.Nonce -> Maybe PraosNonce fromLedgerNonce Ledger.NeutralNonce = Nothing -fromLedgerNonce (Ledger.Nonce h) = Just (PraosNonce (Crypto.castHash h)) - +fromLedgerNonce (Ledger.Nonce h) = Just (PraosNonce (Crypto.castHash h)) -- ---------------------------------------------------------------------------- -- Script execution unit prices and cost models @@ -1024,19 +941,18 @@ fromLedgerNonce (Ledger.Nonce h) = Just (PraosNonce (Crypto.castHash h)) -- -- These are used to determine the fee for the use of a script within a -- transaction, based on the 'ExecutionUnits' needed by the use of the script. --- -data ExecutionUnitPrices = - ExecutionUnitPrices { - priceExecutionSteps :: Rational, - priceExecutionMemory :: Rational - } +data ExecutionUnitPrices + = ExecutionUnitPrices + { priceExecutionSteps :: Rational + , priceExecutionMemory :: Rational + } deriving (Eq, Show) instance ToCBOR ExecutionUnitPrices where - toCBOR ExecutionUnitPrices{priceExecutionSteps, priceExecutionMemory} = - CBOR.encodeListLen 2 - <> toCBOR priceExecutionSteps - <> toCBOR priceExecutionMemory + toCBOR ExecutionUnitPrices {priceExecutionSteps, priceExecutionMemory} = + CBOR.encodeListLen 2 + <> toCBOR priceExecutionSteps + <> toCBOR priceExecutionMemory instance FromCBOR ExecutionUnitPrices where fromCBOR = do @@ -1046,10 +962,11 @@ instance FromCBOR ExecutionUnitPrices where <*> fromCBOR instance ToJSON ExecutionUnitPrices where - toJSON ExecutionUnitPrices{priceExecutionSteps, priceExecutionMemory} = - object [ "priceSteps" .= toRationalJSON priceExecutionSteps - , "priceMemory" .= toRationalJSON priceExecutionMemory - ] + toJSON ExecutionUnitPrices {priceExecutionSteps, priceExecutionMemory} = + object + [ "priceSteps" .= toRationalJSON priceExecutionSteps + , "priceMemory" .= toRationalJSON priceExecutionMemory + ] instance FromJSON ExecutionUnitPrices where parseJSON = @@ -1058,26 +975,26 @@ instance FromJSON ExecutionUnitPrices where <$> o .: "priceSteps" <*> o .: "priceMemory" - toAlonzoPrices :: ExecutionUnitPrices -> Either ProtocolParametersConversionError Alonzo.Prices -toAlonzoPrices ExecutionUnitPrices { - priceExecutionSteps, - priceExecutionMemory - } = do - prSteps <- boundRationalEither "Steps" priceExecutionSteps - prMem <- boundRationalEither "Mem" priceExecutionMemory - return Alonzo.Prices { - Alonzo.prSteps, - Alonzo.prMem - } +toAlonzoPrices + ExecutionUnitPrices + { priceExecutionSteps + , priceExecutionMemory + } = do + prSteps <- boundRationalEither "Steps" priceExecutionSteps + prMem <- boundRationalEither "Mem" priceExecutionMemory + return + Alonzo.Prices + { Alonzo.prSteps + , Alonzo.prMem + } fromAlonzoPrices :: Alonzo.Prices -> ExecutionUnitPrices -fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = - ExecutionUnitPrices { - priceExecutionSteps = Ledger.unboundRational prSteps, - priceExecutionMemory = Ledger.unboundRational prMem - } - +fromAlonzoPrices Alonzo.Prices {Alonzo.prSteps, Alonzo.prMem} = + ExecutionUnitPrices + { priceExecutionSteps = Ledger.unboundRational prSteps + , priceExecutionMemory = Ledger.unboundRational prMem + } -- ---------------------------------------------------------------------------- -- Script cost models @@ -1087,7 +1004,7 @@ newtype CostModel = CostModel [Int64] deriving (Eq, Show, Data) deriving newtype (ToCBOR, FromCBOR) -newtype CostModels = CostModels { unCostModels :: Map AnyPlutusScriptVersion CostModel } +newtype CostModels = CostModels {unCostModels :: Map AnyPlutusScriptVersion CostModel} deriving (Eq, Show) instance FromJSON CostModels where @@ -1106,7 +1023,9 @@ toAlonzoCostModels m = do f <- mapM conv $ Map.toList m Right $ Plutus.mkCostModels $ Map.fromList f where - conv :: (AnyPlutusScriptVersion, CostModel) -> Either ProtocolParametersConversionError (Plutus.Language, Alonzo.CostModel) + conv + :: (AnyPlutusScriptVersion, CostModel) + -> Either ProtocolParametersConversionError (Plutus.Language, Alonzo.CostModel) conv (anySVer, cModel) = do alonzoCostModel <- toAlonzoCostModel cModel (toAlonzoScriptLanguage anySVer) Right (toAlonzoScriptLanguage anySVer, alonzoCostModel) @@ -1115,9 +1034,10 @@ fromAlonzoCostModels :: Plutus.CostModels -> Map AnyPlutusScriptVersion CostModel fromAlonzoCostModels cModels = - Map.fromList - . map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel) - $ Map.toList $ Plutus.costModelsValid cModels + Map.fromList + . map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel) + $ Map.toList + $ Plutus.costModelsValid cModels toAlonzoScriptLanguage :: AnyPlutusScriptVersion -> Plutus.Language toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1 @@ -1129,91 +1049,95 @@ fromAlonzoScriptLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1 fromAlonzoScriptLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2 fromAlonzoScriptLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3 -toAlonzoCostModel :: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel +toAlonzoCostModel + :: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel toAlonzoCostModel (CostModel m) l = first (PpceInvalidCostModel (CostModel m)) $ Alonzo.mkCostModel l m fromAlonzoCostModel :: Alonzo.CostModel -> CostModel fromAlonzoCostModel m = CostModel $ Alonzo.getCostModelParams m - -- ---------------------------------------------------------------------------- -- Proposals embedded in transactions to update protocol parameters -- -data UpdateProposal = - UpdateProposal - !(Map (Hash GenesisKey) ProtocolParametersUpdate) - !EpochNo - deriving stock (Eq, Show) - deriving anyclass SerialiseAsCBOR +data UpdateProposal + = UpdateProposal + !(Map (Hash GenesisKey) ProtocolParametersUpdate) + !EpochNo + deriving stock (Eq, Show) + deriving anyclass (SerialiseAsCBOR) instance HasTypeProxy UpdateProposal where - data AsType UpdateProposal = AsUpdateProposal - proxyToAsType _ = AsUpdateProposal + data AsType UpdateProposal = AsUpdateProposal + proxyToAsType _ = AsUpdateProposal instance HasTextEnvelope UpdateProposal where - textEnvelopeType _ = "UpdateProposalShelley" + textEnvelopeType _ = "UpdateProposalShelley" instance ToCBOR UpdateProposal where - toCBOR (UpdateProposal ppup epochno) = - CBOR.encodeListLen 2 - <> toCBOR ppup - <> toCBOR epochno + toCBOR (UpdateProposal ppup epochno) = + CBOR.encodeListLen 2 + <> toCBOR ppup + <> toCBOR epochno instance FromCBOR UpdateProposal where - fromCBOR = do - CBOR.enforceSize "ProtocolParametersUpdate" 2 - UpdateProposal - <$> fromCBOR - <*> fromCBOR - -makeShelleyUpdateProposal :: ProtocolParametersUpdate - -> [Hash GenesisKey] - -> EpochNo - -> UpdateProposal -makeShelleyUpdateProposal params genesisKeyHashes = - --TODO decide how to handle parameter validation - -- for example we need to validate the Rational values can convert - -- into the UnitInterval type ok. - UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ]) + fromCBOR = do + CBOR.enforceSize "ProtocolParametersUpdate" 2 + UpdateProposal + <$> fromCBOR + <*> fromCBOR +makeShelleyUpdateProposal + :: ProtocolParametersUpdate + -> [Hash GenesisKey] + -> EpochNo + -> UpdateProposal +makeShelleyUpdateProposal params genesisKeyHashes = + -- TODO decide how to handle parameter validation + -- for example we need to validate the Rational values can convert + -- into the UnitInterval type ok. + UpdateProposal (Map.fromList [(kh, params) | kh <- genesisKeyHashes]) -- ---------------------------------------------------------------------------- -- Conversion functions: updates to ledger types -- -toLedgerUpdate :: () +toLedgerUpdate + :: () => ShelleyBasedEra era -> UpdateProposal -> Either ProtocolParametersConversionError (Ledger.Update (ShelleyLedgerEra era)) toLedgerUpdate sbe (UpdateProposal ppup epochno) = (`Ledger.Update` epochno) <$> toLedgerProposedPPUpdates sbe ppup -toLedgerProposedPPUpdates :: () +toLedgerProposedPPUpdates + :: () => ShelleyBasedEra era -> Map (Hash GenesisKey) ProtocolParametersUpdate -> Either ProtocolParametersConversionError (Ledger.ProposedPPUpdates (ShelleyLedgerEra era)) toLedgerProposedPPUpdates sbe m = shelleyBasedEraConstraints sbe $ - Ledger.ProposedPPUpdates . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) <$> traverse (toLedgerPParamsUpdate sbe) m + Ledger.ProposedPPUpdates . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) + <$> traverse (toLedgerPParamsUpdate sbe) m -toLedgerPParamsUpdate :: ShelleyBasedEra era - -> ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate (ShelleyLedgerEra era)) +toLedgerPParamsUpdate + :: ShelleyBasedEra era + -> ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate (ShelleyLedgerEra era)) toLedgerPParamsUpdate ShelleyBasedEraShelley = toShelleyPParamsUpdate toLedgerPParamsUpdate ShelleyBasedEraAllegra = toShelleyPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraMary = toShelleyPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraAlonzo = toAlonzoPParamsUpdate +toLedgerPParamsUpdate ShelleyBasedEraMary = toShelleyPParamsUpdate +toLedgerPParamsUpdate ShelleyBasedEraAlonzo = toAlonzoPParamsUpdate toLedgerPParamsUpdate ShelleyBasedEraBabbage = toBabbagePParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraConway = toConwayPParamsUpdate - +toLedgerPParamsUpdate ShelleyBasedEraConway = toConwayPParamsUpdate -toShelleyCommonPParamsUpdate :: EraPParams ledgerera - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) toShelleyCommonPParamsUpdate - ProtocolParametersUpdate { - protocolUpdateMaxBlockHeaderSize + :: EraPParams ledgerera + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) +toShelleyCommonPParamsUpdate + ProtocolParametersUpdate + { protocolUpdateMaxBlockHeaderSize , protocolUpdateMaxBlockBodySize , protocolUpdateMaxTxSize , protocolUpdateTxFeeFixed @@ -1227,58 +1151,60 @@ toShelleyCommonPParamsUpdate , protocolUpdateMonetaryExpansion , protocolUpdateTreasuryCut } = do - a0 <- mapM (boundRationalEither "A0") protocolUpdatePoolPledgeInfluence - rho <- mapM (boundRationalEither "Rho") protocolUpdateMonetaryExpansion - tau <- mapM (boundRationalEither "Tau") protocolUpdateTreasuryCut - let ppuCommon = - emptyPParamsUpdate - & ppuMinFeeAL .~ noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte - & ppuMinFeeBL .~ noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed - & ppuMaxBBSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize - & ppuMaxTxSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize - & ppuMaxBHSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize - & ppuKeyDepositL .~ noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit - & ppuPoolDepositL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit - & ppuEMaxL .~ noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch - & ppuNOptL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum - & ppuA0L .~ noInlineMaybeToStrictMaybe a0 - & ppuRhoL .~ noInlineMaybeToStrictMaybe rho - & ppuTauL .~ noInlineMaybeToStrictMaybe tau - & ppuMinPoolCostL .~ noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost - pure ppuCommon - -toShelleyPParamsUpdate :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - , Ledger.AtMostEra Ledger.BabbageEra ledgerera - ) - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) + a0 <- mapM (boundRationalEither "A0") protocolUpdatePoolPledgeInfluence + rho <- mapM (boundRationalEither "Rho") protocolUpdateMonetaryExpansion + tau <- mapM (boundRationalEither "Tau") protocolUpdateTreasuryCut + let ppuCommon = + emptyPParamsUpdate + & ppuMinFeeAL .~ noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte + & ppuMinFeeBL .~ noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed + & ppuMaxBBSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize + & ppuMaxTxSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize + & ppuMaxBHSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize + & ppuKeyDepositL .~ noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit + & ppuPoolDepositL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit + & ppuEMaxL .~ noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch + & ppuNOptL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum + & ppuA0L .~ noInlineMaybeToStrictMaybe a0 + & ppuRhoL .~ noInlineMaybeToStrictMaybe rho + & ppuTauL .~ noInlineMaybeToStrictMaybe tau + & ppuMinPoolCostL .~ noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost + pure ppuCommon + +toShelleyPParamsUpdate + :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + , Ledger.AtMostEra Ledger.BabbageEra ledgerera + ) + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) toShelleyPParamsUpdate - protocolParametersUpdate@ProtocolParametersUpdate { - protocolUpdateProtocolVersion + protocolParametersUpdate@ProtocolParametersUpdate + { protocolUpdateProtocolVersion , protocolUpdateDecentralization , protocolUpdateExtraPraosEntropy , protocolUpdateMinUTxOValue } = do - ppuCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate - d <- mapM (boundRationalEither "D") protocolUpdateDecentralization - protVer <- mapM mkProtVer protocolUpdateProtocolVersion - let ppuShelley = - ppuCommon - & ppuDL .~ noInlineMaybeToStrictMaybe d - & ppuExtraEntropyL .~ (toLedgerNonce <$> noInlineMaybeToStrictMaybe protocolUpdateExtraPraosEntropy) - & ppuMinUTxOValueL .~ noInlineMaybeToStrictMaybe protocolUpdateMinUTxOValue - & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer - pure ppuShelley - - -toAlonzoCommonPParamsUpdate :: AlonzoEraPParams ledgerera - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) + ppuCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate + d <- mapM (boundRationalEither "D") protocolUpdateDecentralization + protVer <- mapM mkProtVer protocolUpdateProtocolVersion + let ppuShelley = + ppuCommon + & ppuDL .~ noInlineMaybeToStrictMaybe d + & ppuExtraEntropyL + .~ (toLedgerNonce <$> noInlineMaybeToStrictMaybe protocolUpdateExtraPraosEntropy) + & ppuMinUTxOValueL .~ noInlineMaybeToStrictMaybe protocolUpdateMinUTxOValue + & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer + pure ppuShelley + +toAlonzoCommonPParamsUpdate + :: AlonzoEraPParams ledgerera + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) toAlonzoCommonPParamsUpdate - protocolParametersUpdate@ProtocolParametersUpdate { - protocolUpdateCostModels + protocolParametersUpdate@ProtocolParametersUpdate + { protocolUpdateCostModels , protocolUpdatePrices , protocolUpdateMaxTxExUnits , protocolUpdateMaxBlockExUnits @@ -1286,229 +1212,253 @@ toAlonzoCommonPParamsUpdate , protocolUpdateCollateralPercent , protocolUpdateMaxCollateralInputs } = do - ppuShelleyCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate - costModels <- - if Map.null protocolUpdateCostModels - then pure SNothing - else SJust <$> toAlonzoCostModels protocolUpdateCostModels - prices <- mapM toAlonzoPrices protocolUpdatePrices - let ppuAlonzoCommon = - ppuShelleyCommon - & ppuCostModelsL .~ costModels - & ppuPricesL .~ noInlineMaybeToStrictMaybe prices - & ppuMaxTxExUnitsL .~ - (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxTxExUnits) - & ppuMaxBlockExUnitsL .~ - (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxBlockExUnits) - & ppuMaxValSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxValueSize - & ppuCollateralPercentageL .~ noInlineMaybeToStrictMaybe protocolUpdateCollateralPercent - & ppuMaxCollateralInputsL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxCollateralInputs - pure ppuAlonzoCommon - - -toAlonzoPParamsUpdate :: Ledger.Crypto crypto - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate (Ledger.AlonzoEra crypto)) + ppuShelleyCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate + costModels <- + if Map.null protocolUpdateCostModels + then pure SNothing + else SJust <$> toAlonzoCostModels protocolUpdateCostModels + prices <- mapM toAlonzoPrices protocolUpdatePrices + let ppuAlonzoCommon = + ppuShelleyCommon + & ppuCostModelsL .~ costModels + & ppuPricesL .~ noInlineMaybeToStrictMaybe prices + & ppuMaxTxExUnitsL + .~ (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxTxExUnits) + & ppuMaxBlockExUnitsL + .~ (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxBlockExUnits) + & ppuMaxValSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxValueSize + & ppuCollateralPercentageL .~ noInlineMaybeToStrictMaybe protocolUpdateCollateralPercent + & ppuMaxCollateralInputsL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxCollateralInputs + pure ppuAlonzoCommon + +toAlonzoPParamsUpdate + :: Ledger.Crypto crypto + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate (Ledger.AlonzoEra crypto)) toAlonzoPParamsUpdate - protocolParametersUpdate@ProtocolParametersUpdate { - protocolUpdateProtocolVersion + protocolParametersUpdate@ProtocolParametersUpdate + { protocolUpdateProtocolVersion , protocolUpdateDecentralization } = do - ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate - d <- mapM (boundRationalEither "D") protocolUpdateDecentralization - protVer <- mapM mkProtVer protocolUpdateProtocolVersion - let ppuAlonzo = - ppuAlonzoCommon - & ppuDL .~ noInlineMaybeToStrictMaybe d - & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer - pure ppuAlonzo - -toBabbageCommonPParamsUpdate :: BabbageEraPParams ledgerera - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (Ledger.PParamsUpdate ledgerera) + ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate + d <- mapM (boundRationalEither "D") protocolUpdateDecentralization + protVer <- mapM mkProtVer protocolUpdateProtocolVersion + let ppuAlonzo = + ppuAlonzoCommon + & ppuDL .~ noInlineMaybeToStrictMaybe d + & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer + pure ppuAlonzo + toBabbageCommonPParamsUpdate - protocolParametersUpdate@ProtocolParametersUpdate { - protocolUpdateUTxOCostPerByte + :: BabbageEraPParams ledgerera + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (Ledger.PParamsUpdate ledgerera) +toBabbageCommonPParamsUpdate + protocolParametersUpdate@ProtocolParametersUpdate + { protocolUpdateUTxOCostPerByte } = do - ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate - let ppuBabbage = - ppuAlonzoCommon - & ppuCoinsPerUTxOByteL .~ fmap CoinPerByte (noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerByte) - pure ppuBabbage - -toBabbagePParamsUpdate :: Ledger.Crypto crypto - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (Ledger.PParamsUpdate (Ledger.BabbageEra crypto)) + ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate + let ppuBabbage = + ppuAlonzoCommon + & ppuCoinsPerUTxOByteL .~ fmap CoinPerByte (noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerByte) + pure ppuBabbage + toBabbagePParamsUpdate - protocolParametersUpdate@ProtocolParametersUpdate { - protocolUpdateProtocolVersion + :: Ledger.Crypto crypto + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (Ledger.PParamsUpdate (Ledger.BabbageEra crypto)) +toBabbagePParamsUpdate + protocolParametersUpdate@ProtocolParametersUpdate + { protocolUpdateProtocolVersion } = do - ppuBabbageCommon <- toBabbageCommonPParamsUpdate protocolParametersUpdate - protVer <- mapM mkProtVer protocolUpdateProtocolVersion - let ppuBabbage = - ppuBabbageCommon - & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer - pure ppuBabbage - -requireParam :: String -> (a -> Either ProtocolParametersConversionError b) -> Maybe a -> Either ProtocolParametersConversionError b + ppuBabbageCommon <- toBabbageCommonPParamsUpdate protocolParametersUpdate + protVer <- mapM mkProtVer protocolUpdateProtocolVersion + let ppuBabbage = + ppuBabbageCommon + & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer + pure ppuBabbage + +requireParam + :: String + -> (a -> Either ProtocolParametersConversionError b) + -> Maybe a + -> Either ProtocolParametersConversionError b requireParam paramName = maybe (Left $ PpceMissingParameter paramName) mkProtVer :: (Natural, Natural) -> Either ProtocolParametersConversionError Ledger.ProtVer -mkProtVer (majorProtVer, minorProtVer) = maybeToRight (PpceVersionInvalid majorProtVer) $ - (`Ledger.ProtVer` minorProtVer) <$> Ledger.mkVersion majorProtVer - -boundRationalEither :: Ledger.BoundedRational b - => String - -> Rational - -> Either ProtocolParametersConversionError b +mkProtVer (majorProtVer, minorProtVer) = + maybeToRight (PpceVersionInvalid majorProtVer) $ + (`Ledger.ProtVer` minorProtVer) <$> Ledger.mkVersion majorProtVer + +boundRationalEither + :: Ledger.BoundedRational b + => String + -> Rational + -> Either ProtocolParametersConversionError b boundRationalEither name r = maybeToRight (PpceOutOfBounds name r) $ Ledger.boundRational r -- Conway uses the same PParams as Babbage for now. -toConwayPParamsUpdate :: BabbageEraPParams ledgerera - => ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) +toConwayPParamsUpdate + :: BabbageEraPParams ledgerera + => ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (PParamsUpdate ledgerera) toConwayPParamsUpdate = toBabbageCommonPParamsUpdate -- ---------------------------------------------------------------------------- -- Conversion functions: updates from ledger types -- -fromLedgerUpdate :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => Ledger.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> Ledger.Update ledgerera - -> UpdateProposal +fromLedgerUpdate + :: forall era ledgerera + . ShelleyLedgerEra era ~ ledgerera + => Ledger.EraCrypto ledgerera ~ StandardCrypto + => ShelleyBasedEra era + -> Ledger.Update ledgerera + -> UpdateProposal fromLedgerUpdate sbe (Ledger.Update ppup epochno) = - UpdateProposal (fromLedgerProposedPPUpdates sbe ppup) epochno - + UpdateProposal (fromLedgerProposedPPUpdates sbe ppup) epochno -fromLedgerProposedPPUpdates :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => Ledger.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> Ledger.ProposedPPUpdates ledgerera - -> Map (Hash GenesisKey) ProtocolParametersUpdate +fromLedgerProposedPPUpdates + :: forall era ledgerera + . ShelleyLedgerEra era ~ ledgerera + => Ledger.EraCrypto ledgerera ~ StandardCrypto + => ShelleyBasedEra era + -> Ledger.ProposedPPUpdates ledgerera + -> Map (Hash GenesisKey) ProtocolParametersUpdate fromLedgerProposedPPUpdates sbe = - Map.map (fromLedgerPParamsUpdate sbe) - . Map.mapKeysMonotonic GenesisKeyHash - . (\(Ledger.ProposedPPUpdates ppup) -> ppup) + Map.map (fromLedgerPParamsUpdate sbe) + . Map.mapKeysMonotonic GenesisKeyHash + . (\(Ledger.ProposedPPUpdates ppup) -> ppup) - -fromLedgerPParamsUpdate :: ShelleyBasedEra era - -> Ledger.PParamsUpdate (ShelleyLedgerEra era) - -> ProtocolParametersUpdate +fromLedgerPParamsUpdate + :: ShelleyBasedEra era + -> Ledger.PParamsUpdate (ShelleyLedgerEra era) + -> ProtocolParametersUpdate fromLedgerPParamsUpdate ShelleyBasedEraShelley = fromShelleyPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraAllegra = fromShelleyPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraAlonzo = fromAlonzoPParamsUpdate +fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate +fromLedgerPParamsUpdate ShelleyBasedEraAlonzo = fromAlonzoPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraBabbage = fromBabbagePParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate - - +fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate -fromShelleyCommonPParamsUpdate :: EraPParams ledgerera - => PParamsUpdate ledgerera - -> ProtocolParametersUpdate +fromShelleyCommonPParamsUpdate + :: EraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromShelleyCommonPParamsUpdate ppu = - ProtocolParametersUpdate { - protocolUpdateProtocolVersion = Nothing - , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe (ppu ^. ppuMaxBHSizeL) - , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe (ppu ^. ppuMaxBBSizeL) - , protocolUpdateMaxTxSize = strictMaybeToMaybe (ppu ^. ppuMaxTxSizeL) - , protocolUpdateTxFeeFixed = strictMaybeToMaybe (ppu ^. ppuMinFeeBL) - , protocolUpdateTxFeePerByte = strictMaybeToMaybe (ppu ^. ppuMinFeeAL) + ProtocolParametersUpdate + { protocolUpdateProtocolVersion = Nothing + , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe (ppu ^. ppuMaxBHSizeL) + , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe (ppu ^. ppuMaxBBSizeL) + , protocolUpdateMaxTxSize = strictMaybeToMaybe (ppu ^. ppuMaxTxSizeL) + , protocolUpdateTxFeeFixed = strictMaybeToMaybe (ppu ^. ppuMinFeeBL) + , protocolUpdateTxFeePerByte = strictMaybeToMaybe (ppu ^. ppuMinFeeAL) , protocolUpdateStakeAddressDeposit = strictMaybeToMaybe (ppu ^. ppuKeyDepositL) - , protocolUpdateStakePoolDeposit = strictMaybeToMaybe (ppu ^. ppuPoolDepositL) - , protocolUpdateMinPoolCost = strictMaybeToMaybe (ppu ^. ppuMinPoolCostL) - , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe (ppu ^. ppuEMaxL) - , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe (ppu ^. ppuNOptL) + , protocolUpdateStakePoolDeposit = strictMaybeToMaybe (ppu ^. ppuPoolDepositL) + , protocolUpdateMinPoolCost = strictMaybeToMaybe (ppu ^. ppuMinPoolCostL) + , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe (ppu ^. ppuEMaxL) + , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe (ppu ^. ppuNOptL) , protocolUpdatePoolPledgeInfluence = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuA0L) - , protocolUpdateMonetaryExpansion = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuRhoL) - , protocolUpdateTreasuryCut = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuTauL) - , protocolUpdateCostModels = mempty - , protocolUpdatePrices = Nothing - , protocolUpdateMaxTxExUnits = Nothing - , protocolUpdateMaxBlockExUnits = Nothing - , protocolUpdateMaxValueSize = Nothing - , protocolUpdateCollateralPercent = Nothing + , protocolUpdateMonetaryExpansion = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuRhoL) + , protocolUpdateTreasuryCut = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuTauL) + , protocolUpdateCostModels = mempty + , protocolUpdatePrices = Nothing + , protocolUpdateMaxTxExUnits = Nothing + , protocolUpdateMaxBlockExUnits = Nothing + , protocolUpdateMaxValueSize = Nothing + , protocolUpdateCollateralPercent = Nothing , protocolUpdateMaxCollateralInputs = Nothing - , protocolUpdateUTxOCostPerByte = Nothing - , protocolUpdateDecentralization = Nothing - , protocolUpdateExtraPraosEntropy = Nothing - , protocolUpdateMinUTxOValue = Nothing + , protocolUpdateUTxOCostPerByte = Nothing + , protocolUpdateDecentralization = Nothing + , protocolUpdateExtraPraosEntropy = Nothing + , protocolUpdateMinUTxOValue = Nothing } -fromShelleyPParamsUpdate :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - , Ledger.AtMostEra Ledger.BabbageEra ledgerera - ) - => PParamsUpdate ledgerera - -> ProtocolParametersUpdate +fromShelleyPParamsUpdate + :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + , Ledger.AtMostEra Ledger.BabbageEra ledgerera + ) + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromShelleyPParamsUpdate ppu = - (fromShelleyCommonPParamsUpdate ppu) { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (Ledger.getVersion a,b)) <$> - strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) - , protocolUpdateDecentralization = Ledger.unboundRational <$> - strictMaybeToMaybe (ppu ^. ppuDL) - , protocolUpdateExtraPraosEntropy = fromLedgerNonce <$> - strictMaybeToMaybe (ppu ^. ppuExtraEntropyL) - , protocolUpdateMinUTxOValue = strictMaybeToMaybe (ppu ^. ppuMinUTxOValueL) + (fromShelleyCommonPParamsUpdate ppu) + { protocolUpdateProtocolVersion = + (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) + <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + , protocolUpdateDecentralization = + Ledger.unboundRational + <$> strictMaybeToMaybe (ppu ^. ppuDL) + , protocolUpdateExtraPraosEntropy = + fromLedgerNonce + <$> strictMaybeToMaybe (ppu ^. ppuExtraEntropyL) + , protocolUpdateMinUTxOValue = strictMaybeToMaybe (ppu ^. ppuMinUTxOValueL) } -fromAlonzoCommonPParamsUpdate :: AlonzoEraPParams ledgerera - => PParamsUpdate ledgerera - -> ProtocolParametersUpdate +fromAlonzoCommonPParamsUpdate + :: AlonzoEraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromAlonzoCommonPParamsUpdate ppu = - (fromShelleyCommonPParamsUpdate ppu) { - protocolUpdateCostModels = maybe mempty fromAlonzoCostModels - (strictMaybeToMaybe (ppu ^. ppuCostModelsL)) - , protocolUpdatePrices = fromAlonzoPrices <$> - strictMaybeToMaybe (ppu ^. ppuPricesL) - , protocolUpdateMaxTxExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL) - , protocolUpdateMaxBlockExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL) - , protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL) - , protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL) + (fromShelleyCommonPParamsUpdate ppu) + { protocolUpdateCostModels = + maybe + mempty + fromAlonzoCostModels + (strictMaybeToMaybe (ppu ^. ppuCostModelsL)) + , protocolUpdatePrices = + fromAlonzoPrices + <$> strictMaybeToMaybe (ppu ^. ppuPricesL) + , protocolUpdateMaxTxExUnits = + fromAlonzoExUnits + <$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL) + , protocolUpdateMaxBlockExUnits = + fromAlonzoExUnits + <$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL) + , protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL) + , protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL) , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL) - , protocolUpdateUTxOCostPerByte = Nothing + , protocolUpdateUTxOCostPerByte = Nothing } - -fromAlonzoPParamsUpdate :: Ledger.Crypto crypto - => PParamsUpdate (Ledger.AlonzoEra crypto) - -> ProtocolParametersUpdate +fromAlonzoPParamsUpdate + :: Ledger.Crypto crypto + => PParamsUpdate (Ledger.AlonzoEra crypto) + -> ProtocolParametersUpdate fromAlonzoPParamsUpdate ppu = - (fromAlonzoCommonPParamsUpdate ppu) { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (Ledger.getVersion a,b)) <$> - strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + (fromAlonzoCommonPParamsUpdate ppu) + { protocolUpdateProtocolVersion = + (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) + <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) } -fromBabbageCommonPParamsUpdate :: BabbageEraPParams ledgerera - => PParamsUpdate ledgerera - -> ProtocolParametersUpdate +fromBabbageCommonPParamsUpdate + :: BabbageEraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromBabbageCommonPParamsUpdate ppu = (fromAlonzoCommonPParamsUpdate ppu) { protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL) } -fromBabbagePParamsUpdate :: Ledger.Crypto crypto - => PParamsUpdate (Ledger.BabbageEra crypto) - -> ProtocolParametersUpdate +fromBabbagePParamsUpdate + :: Ledger.Crypto crypto + => PParamsUpdate (Ledger.BabbageEra crypto) + -> ProtocolParametersUpdate fromBabbagePParamsUpdate ppu = - (fromBabbageCommonPParamsUpdate ppu) { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (Ledger.getVersion a,b)) <$> - strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + (fromBabbageCommonPParamsUpdate ppu) + { protocolUpdateProtocolVersion = + (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) + <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) } -fromConwayPParamsUpdate :: BabbageEraPParams ledgerera - => PParamsUpdate ledgerera - -> ProtocolParametersUpdate +fromConwayPParamsUpdate + :: BabbageEraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate - -- ---------------------------------------------------------------------------- -- Conversion functions: protocol parameters to ledger types -- @@ -1519,18 +1469,18 @@ toLedgerPParams -> Either ProtocolParametersConversionError (Ledger.PParams (ShelleyLedgerEra era)) toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams -toLedgerPParams ShelleyBasedEraMary = toShelleyPParams -toLedgerPParams ShelleyBasedEraAlonzo = toAlonzoPParams +toLedgerPParams ShelleyBasedEraMary = toShelleyPParams +toLedgerPParams ShelleyBasedEraAlonzo = toAlonzoPParams toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParams -toLedgerPParams ShelleyBasedEraConway = toConwayPParams - +toLedgerPParams ShelleyBasedEraConway = toConwayPParams -toShelleyCommonPParams :: EraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) toShelleyCommonPParams - ProtocolParameters { - protocolParamProtocolVersion + :: EraPParams ledgerera + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams ledgerera) +toShelleyCommonPParams + ProtocolParameters + { protocolParamProtocolVersion , protocolParamMaxBlockHeaderSize , protocolParamMaxBlockBodySize , protocolParamMaxTxSize @@ -1545,57 +1495,61 @@ toShelleyCommonPParams , protocolParamMonetaryExpansion , protocolParamTreasuryCut } = do - a0 <- boundRationalEither "A0" protocolParamPoolPledgeInfluence - rho <- boundRationalEither "Rho" protocolParamMonetaryExpansion - tau <- boundRationalEither "Tau" protocolParamTreasuryCut - protVer <- mkProtVer protocolParamProtocolVersion - let ppCommon = - emptyPParams - & ppMinFeeAL .~ protocolParamTxFeePerByte - & ppMinFeeBL .~ protocolParamTxFeeFixed - & ppMaxBBSizeL .~ fromIntegral protocolParamMaxBlockBodySize - & ppMaxTxSizeL .~ fromIntegral protocolParamMaxTxSize - & ppMaxBHSizeL .~ fromIntegral protocolParamMaxBlockHeaderSize - & ppKeyDepositL .~ protocolParamStakeAddressDeposit - & ppPoolDepositL .~ protocolParamStakePoolDeposit - & ppEMaxL .~ protocolParamPoolRetireMaxEpoch - & ppNOptL .~ protocolParamStakePoolTargetNum - & ppA0L .~ a0 - & ppRhoL .~ rho - & ppTauL .~ tau - & ppProtocolVersionL .~ protVer - & ppMinPoolCostL .~ protocolParamMinPoolCost - pure ppCommon - -toShelleyPParams :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - ) - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) + a0 <- boundRationalEither "A0" protocolParamPoolPledgeInfluence + rho <- boundRationalEither "Rho" protocolParamMonetaryExpansion + tau <- boundRationalEither "Tau" protocolParamTreasuryCut + protVer <- mkProtVer protocolParamProtocolVersion + let ppCommon = + emptyPParams + & ppMinFeeAL .~ protocolParamTxFeePerByte + & ppMinFeeBL .~ protocolParamTxFeeFixed + & ppMaxBBSizeL .~ fromIntegral protocolParamMaxBlockBodySize + & ppMaxTxSizeL .~ fromIntegral protocolParamMaxTxSize + & ppMaxBHSizeL .~ fromIntegral protocolParamMaxBlockHeaderSize + & ppKeyDepositL .~ protocolParamStakeAddressDeposit + & ppPoolDepositL .~ protocolParamStakePoolDeposit + & ppEMaxL .~ protocolParamPoolRetireMaxEpoch + & ppNOptL .~ protocolParamStakePoolTargetNum + & ppA0L .~ a0 + & ppRhoL .~ rho + & ppTauL .~ tau + & ppProtocolVersionL .~ protVer + & ppMinPoolCostL .~ protocolParamMinPoolCost + pure ppCommon + +toShelleyPParams + :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams ledgerera) toShelleyPParams - protocolParameters@ProtocolParameters { - protocolParamDecentralization + protocolParameters@ProtocolParameters + { protocolParamDecentralization , protocolParamExtraPraosEntropy , protocolParamMinUTxOValue } = do - ppCommon <- toShelleyCommonPParams protocolParameters - d <- boundRationalEither "D" =<< maybeToRight (PpceMissingParameter "decentralization") protocolParamDecentralization - minUTxOValue <- maybeToRight (PpceMissingParameter "protocolParamMinUTxOValue") protocolParamMinUTxOValue - let ppShelley = - ppCommon - & ppDL .~ d - & ppExtraEntropyL .~ toLedgerNonce protocolParamExtraPraosEntropy - & ppMinUTxOValueL .~ minUTxOValue - pure ppShelley - - -toAlonzoCommonPParams :: AlonzoEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) + ppCommon <- toShelleyCommonPParams protocolParameters + d <- + boundRationalEither "D" + =<< maybeToRight (PpceMissingParameter "decentralization") protocolParamDecentralization + minUTxOValue <- + maybeToRight (PpceMissingParameter "protocolParamMinUTxOValue") protocolParamMinUTxOValue + let ppShelley = + ppCommon + & ppDL .~ d + & ppExtraEntropyL .~ toLedgerNonce protocolParamExtraPraosEntropy + & ppMinUTxOValueL .~ minUTxOValue + pure ppShelley + +toAlonzoCommonPParams + :: AlonzoEraPParams ledgerera + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams ledgerera) toAlonzoCommonPParams - protocolParameters@ProtocolParameters { - protocolParamCostModels + protocolParameters@ProtocolParameters + { protocolParamCostModels , protocolParamPrices , protocolParamMaxTxExUnits , protocolParamMaxBlockExUnits @@ -1603,181 +1557,214 @@ toAlonzoCommonPParams , protocolParamCollateralPercent , protocolParamMaxCollateralInputs } = do - ppShelleyCommon <- toShelleyCommonPParams protocolParameters - costModels <- toAlonzoCostModels protocolParamCostModels - prices <- - requireParam "protocolParamPrices" toAlonzoPrices protocolParamPrices - maxTxExUnits <- - requireParam "protocolParamMaxTxExUnits" Right protocolParamMaxTxExUnits - maxBlockExUnits <- - requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxBlockExUnits - maxValueSize <- - requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxValueSize - collateralPercent <- - requireParam "protocolParamCollateralPercent" Right protocolParamCollateralPercent - maxCollateralInputs <- - requireParam "protocolParamMaxCollateralInputs" Right protocolParamMaxCollateralInputs - let ppAlonzoCommon = - ppShelleyCommon - & ppCostModelsL .~ costModels - & ppPricesL .~ prices - & ppMaxTxExUnitsL .~ toAlonzoExUnits maxTxExUnits - & ppMaxBlockExUnitsL .~ toAlonzoExUnits maxBlockExUnits - & ppMaxValSizeL .~ maxValueSize - & ppCollateralPercentageL .~ collateralPercent - & ppMaxCollateralInputsL .~ maxCollateralInputs - pure ppAlonzoCommon - -toAlonzoPParams :: Ledger.Crypto crypto - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams (Ledger.AlonzoEra crypto)) + ppShelleyCommon <- toShelleyCommonPParams protocolParameters + costModels <- toAlonzoCostModels protocolParamCostModels + prices <- + requireParam "protocolParamPrices" toAlonzoPrices protocolParamPrices + maxTxExUnits <- + requireParam "protocolParamMaxTxExUnits" Right protocolParamMaxTxExUnits + maxBlockExUnits <- + requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxBlockExUnits + maxValueSize <- + requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxValueSize + collateralPercent <- + requireParam "protocolParamCollateralPercent" Right protocolParamCollateralPercent + maxCollateralInputs <- + requireParam "protocolParamMaxCollateralInputs" Right protocolParamMaxCollateralInputs + let ppAlonzoCommon = + ppShelleyCommon + & ppCostModelsL .~ costModels + & ppPricesL .~ prices + & ppMaxTxExUnitsL .~ toAlonzoExUnits maxTxExUnits + & ppMaxBlockExUnitsL .~ toAlonzoExUnits maxBlockExUnits + & ppMaxValSizeL .~ maxValueSize + & ppCollateralPercentageL .~ collateralPercent + & ppMaxCollateralInputsL .~ maxCollateralInputs + pure ppAlonzoCommon + toAlonzoPParams - protocolParameters@ProtocolParameters { - protocolParamDecentralization + :: Ledger.Crypto crypto + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams (Ledger.AlonzoEra crypto)) +toAlonzoPParams + protocolParameters@ProtocolParameters + { protocolParamDecentralization } = do - ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters - d <- requireParam "protocolParamDecentralization" - (boundRationalEither "D") - protocolParamDecentralization - let ppAlonzo = - ppAlonzoCommon - & ppDL .~ d - pure ppAlonzo - - -toBabbagePParams :: BabbageEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) + ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters + d <- + requireParam + "protocolParamDecentralization" + (boundRationalEither "D") + protocolParamDecentralization + let ppAlonzo = + ppAlonzoCommon + & ppDL .~ d + pure ppAlonzo + toBabbagePParams - protocolParameters@ProtocolParameters { - protocolParamUTxOCostPerByte + :: BabbageEraPParams ledgerera + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams ledgerera) +toBabbagePParams + protocolParameters@ProtocolParameters + { protocolParamUTxOCostPerByte } = do - ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters - utxoCostPerByte <- - requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte - let ppBabbage = - ppAlonzoCommon - & ppCoinsPerUTxOByteL .~ CoinPerByte utxoCostPerByte - pure ppBabbage - -toConwayPParams :: BabbageEraPParams ledgerera - => ProtocolParameters - -> Either ProtocolParametersConversionError (PParams ledgerera) + ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters + utxoCostPerByte <- + requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte + let ppBabbage = + ppAlonzoCommon + & ppCoinsPerUTxOByteL .~ CoinPerByte utxoCostPerByte + pure ppBabbage + +toConwayPParams + :: BabbageEraPParams ledgerera + => ProtocolParameters + -> Either ProtocolParametersConversionError (PParams ledgerera) toConwayPParams = toBabbagePParams -- ---------------------------------------------------------------------------- -- Conversion functions: protocol parameters from ledger types -- -{-# DEPRECATED fromLedgerPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} +{-# DEPRECATED + fromLedgerPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} fromLedgerPParams :: ShelleyBasedEra era -> Ledger.PParams (ShelleyLedgerEra era) -> ProtocolParameters fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams +fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams +fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams -fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams - - -{-# DEPRECATED fromShelleyCommonPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromShelleyCommonPParams :: EraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters +fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams + +{-# DEPRECATED + fromShelleyCommonPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromShelleyCommonPParams + :: EraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters fromShelleyCommonPParams pp = - ProtocolParameters { - protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of - Ledger.ProtVer a b -> (Ledger.getVersion a, b) - , protocolParamMaxBlockHeaderSize = fromIntegral $ pp ^. ppMaxBHSizeL - , protocolParamMaxBlockBodySize = fromIntegral $ pp ^. ppMaxBBSizeL - , protocolParamMaxTxSize = fromIntegral $ pp ^. ppMaxTxSizeL - , protocolParamTxFeeFixed = pp ^. ppMinFeeBL - , protocolParamTxFeePerByte = pp ^. ppMinFeeAL + ProtocolParameters + { protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of + Ledger.ProtVer a b -> (Ledger.getVersion a, b) + , protocolParamMaxBlockHeaderSize = fromIntegral $ pp ^. ppMaxBHSizeL + , protocolParamMaxBlockBodySize = fromIntegral $ pp ^. ppMaxBBSizeL + , protocolParamMaxTxSize = fromIntegral $ pp ^. ppMaxTxSizeL + , protocolParamTxFeeFixed = pp ^. ppMinFeeBL + , protocolParamTxFeePerByte = pp ^. ppMinFeeAL , protocolParamStakeAddressDeposit = pp ^. ppKeyDepositL - , protocolParamStakePoolDeposit = pp ^. ppPoolDepositL - , protocolParamMinPoolCost = pp ^. ppMinPoolCostL - , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL - , protocolParamStakePoolTargetNum = pp ^. ppNOptL + , protocolParamStakePoolDeposit = pp ^. ppPoolDepositL + , protocolParamMinPoolCost = pp ^. ppMinPoolCostL + , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL + , protocolParamStakePoolTargetNum = pp ^. ppNOptL , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L) - , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) - , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL) - , protocolParamCostModels = mempty -- Only from Alonzo onwards - , protocolParamPrices = Nothing -- Only from Alonzo onwards - , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxBlockExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards - , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards + , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) + , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL) + , protocolParamCostModels = mempty -- Only from Alonzo onwards + , protocolParamPrices = Nothing -- Only from Alonzo onwards + , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards + , protocolParamMaxBlockExUnits = Nothing -- Only from Alonzo onwards + , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards + , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards , protocolParamMaxCollateralInputs = Nothing -- Only from Alonzo onwards - , protocolParamUTxOCostPerByte = Nothing -- Only from Babbage onwards - , protocolParamDecentralization = Nothing -- Obsolete from Babbage onwards - , protocolParamExtraPraosEntropy = Nothing -- Obsolete from Alonzo onwards - , protocolParamMinUTxOValue = Nothing -- Obsolete from Alonzo onwards + , protocolParamUTxOCostPerByte = Nothing -- Only from Babbage onwards + , protocolParamDecentralization = Nothing -- Obsolete from Babbage onwards + , protocolParamExtraPraosEntropy = Nothing -- Obsolete from Alonzo onwards + , protocolParamMinUTxOValue = Nothing -- Obsolete from Alonzo onwards } -{-# DEPRECATED fromShelleyPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromShelleyPParams :: ( EraPParams ledgerera - , Ledger.AtMostEra Ledger.MaryEra ledgerera - , Ledger.AtMostEra Ledger.AlonzoEra ledgerera - ) - => PParams ledgerera - -> ProtocolParameters +{-# DEPRECATED + fromShelleyPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromShelleyPParams + :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => PParams ledgerera + -> ProtocolParameters fromShelleyPParams pp = - (fromShelleyCommonPParams pp) { - protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL - , protocolParamExtraPraosEntropy = fromLedgerNonce $ pp ^. ppExtraEntropyL - , protocolParamMinUTxOValue = Just $ pp ^. ppMinUTxOValueL + (fromShelleyCommonPParams pp) + { protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL + , protocolParamExtraPraosEntropy = fromLedgerNonce $ pp ^. ppExtraEntropyL + , protocolParamMinUTxOValue = Just $ pp ^. ppMinUTxOValueL } - -{-# DEPRECATED fromAlonzoPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromAlonzoPParams :: AlonzoEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters +{-# DEPRECATED + fromAlonzoPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromAlonzoPParams + :: AlonzoEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters fromAlonzoPParams pp = - (fromShelleyCommonPParams pp) { - protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL - , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG - , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL - , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL - , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL - , protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL - , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL + (fromShelleyCommonPParams pp) + { protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL + , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG + , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL + , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL + , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL + , protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL + , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL } -{-# DEPRECATED fromExactlyAlonzoPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromExactlyAlonzoPParams :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera) - => PParams ledgerera - -> ProtocolParameters +{-# DEPRECATED + fromExactlyAlonzoPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromExactlyAlonzoPParams + :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera) + => PParams ledgerera + -> ProtocolParameters fromExactlyAlonzoPParams pp = - (fromAlonzoPParams pp) { - protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL - } + (fromAlonzoPParams pp) + { protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL + } -{-# DEPRECATED fromBabbagePParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromBabbagePParams :: BabbageEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters +{-# DEPRECATED + fromBabbagePParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromBabbagePParams + :: BabbageEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters fromBabbagePParams pp = (fromAlonzoPParams pp) { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL - , protocolParamDecentralization = Nothing - } + , protocolParamDecentralization = Nothing + } -{-# DEPRECATED fromConwayPParams "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." #-} -fromConwayPParams :: BabbageEraPParams ledgerera - => PParams ledgerera - -> ProtocolParameters +{-# DEPRECATED + fromConwayPParams + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork." + #-} +fromConwayPParams + :: BabbageEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters fromConwayPParams = fromBabbagePParams -{-# DEPRECATED checkProtocolParameters "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork. PParams natively enforce these checks." #-} -checkProtocolParameters :: () +{-# DEPRECATED + checkProtocolParameters + "Use the ledger's PParams (from module Cardano.Api.Ledger) type instead of ProtocolParameters. The type will be removed after Chang hard fork. PParams natively enforce these checks." + #-} +checkProtocolParameters + :: () => ShelleyBasedEra era -> ProtocolParameters -> Either ProtocolParametersError () -checkProtocolParameters sbe ProtocolParameters{..} = +checkProtocolParameters sbe ProtocolParameters {..} = case sbe of ShelleyBasedEraShelley -> checkMinUTxOVal ShelleyBasedEraAllegra -> checkMinUTxOVal @@ -1786,63 +1773,62 @@ checkProtocolParameters sbe ProtocolParameters{..} = ShelleyBasedEraBabbage -> checkBabbageParams ShelleyBasedEraConway -> checkBabbageParams where - era = toCardanoEra sbe - - cModel = not $ Map.null protocolParamCostModels - prices = isJust protocolParamPrices - maxTxUnits = isJust protocolParamMaxTxExUnits - maxBlockExUnits = isJust protocolParamMaxBlockExUnits - maxValueSize = isJust protocolParamMaxValueSize - collateralPercent = isJust protocolParamCollateralPercent - maxCollateralInputs = isJust protocolParamMaxCollateralInputs - costPerByte = isJust protocolParamUTxOCostPerByte - decentralization = isJust protocolParamDecentralization - extraPraosEntropy = isJust protocolParamExtraPraosEntropy - - alonzoPParamFieldsRequirements :: [Bool] - alonzoPParamFieldsRequirements = - [ cModel - , prices - , maxTxUnits - , maxBlockExUnits - , maxValueSize - , collateralPercent - , maxCollateralInputs - , not costPerByte - ] - - babbagePParamFieldsRequirements :: [Bool] - babbagePParamFieldsRequirements = - [ cModel - , prices - , maxTxUnits - , maxBlockExUnits - , maxValueSize - , collateralPercent - , maxCollateralInputs - , costPerByte - , not decentralization - , not extraPraosEntropy - ] - - checkAlonzoParams :: Either ProtocolParametersError () - checkAlonzoParams = do - if all (== True) alonzoPParamFieldsRequirements - then return () - else Left PParamsErrorMissingAlonzoProtocolParameter - - checkBabbageParams :: Either ProtocolParametersError () - checkBabbageParams = - if all (== True) babbagePParamFieldsRequirements - then return () - else Left PParamsErrorMissingAlonzoProtocolParameter - - checkMinUTxOVal :: Either ProtocolParametersError () - checkMinUTxOVal = - if isJust protocolParamMinUTxOValue + era = toCardanoEra sbe + + cModel = not $ Map.null protocolParamCostModels + prices = isJust protocolParamPrices + maxTxUnits = isJust protocolParamMaxTxExUnits + maxBlockExUnits = isJust protocolParamMaxBlockExUnits + maxValueSize = isJust protocolParamMaxValueSize + collateralPercent = isJust protocolParamCollateralPercent + maxCollateralInputs = isJust protocolParamMaxCollateralInputs + costPerByte = isJust protocolParamUTxOCostPerByte + decentralization = isJust protocolParamDecentralization + extraPraosEntropy = isJust protocolParamExtraPraosEntropy + + alonzoPParamFieldsRequirements :: [Bool] + alonzoPParamFieldsRequirements = + [ cModel + , prices + , maxTxUnits + , maxBlockExUnits + , maxValueSize + , collateralPercent + , maxCollateralInputs + , not costPerByte + ] + + babbagePParamFieldsRequirements :: [Bool] + babbagePParamFieldsRequirements = + [ cModel + , prices + , maxTxUnits + , maxBlockExUnits + , maxValueSize + , collateralPercent + , maxCollateralInputs + , costPerByte + , not decentralization + , not extraPraosEntropy + ] + + checkAlonzoParams :: Either ProtocolParametersError () + checkAlonzoParams = do + if all (== True) alonzoPParamFieldsRequirements then return () - else Left . PParamsErrorMissingMinUTxoValue $ cardanoEraConstraints era $ AnyCardanoEra era + else Left PParamsErrorMissingAlonzoProtocolParameter + checkBabbageParams :: Either ProtocolParametersError () + checkBabbageParams = + if all (== True) babbagePParamFieldsRequirements + then return () + else Left PParamsErrorMissingAlonzoProtocolParameter + + checkMinUTxOVal :: Either ProtocolParametersError () + checkMinUTxOVal = + if isJust protocolParamMinUTxOValue + then return () + else Left . PParamsErrorMissingMinUTxoValue $ cardanoEraConstraints era $ AnyCardanoEra era data ProtocolParametersError = PParamsErrorMissingMinUTxoValue !AnyCardanoEra @@ -1872,8 +1858,8 @@ data ProtocolParametersConversionError | PpceMissingParameter !ProtocolParameterName deriving (Eq, Show, Data) - type ProtocolParameterName = String + type ProtocolParameterVersion = Natural instance Error ProtocolParametersConversionError where diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 58c6167079..1841d16341 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -11,111 +11,115 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - -- The Shelley ledger uses promoted data kinds which we have to use, but we do -- not export any from this API. We also use them unticked as nature intended. {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - -- | Queries from local clients to the node. --- -module Cardano.Api.Query ( - - -- * Queries - QueryInMode(..), - QueryInEra(..), - QueryInShelleyBasedEra(..), - QueryUTxOFilter(..), - UTxO(..), - UTxOInAnyEra(..), +module Cardano.Api.Query + ( -- * Queries + QueryInMode (..) + , QueryInEra (..) + , QueryInShelleyBasedEra (..) + , QueryUTxOFilter (..) + , UTxO (..) + , UTxOInAnyEra (..) -- * Internal conversion functions - toConsensusQuery, - fromConsensusQueryResult, + , toConsensusQuery + , fromConsensusQueryResult -- * Wrapper types used in queries - SerialisedDebugLedgerState(..), - ProtocolState(..), - decodeProtocolState, - - DebugLedgerState(..), - decodeDebugLedgerState, - - SerialisedCurrentEpochState(..), - CurrentEpochState(..), - decodeCurrentEpochState, - - SerialisedPoolState(..), - PoolState(..), - decodePoolState, - - SerialisedPoolDistribution(..), - PoolDistribution(..), - decodePoolDistribution, - - SerialisedStakeSnapshots(..), - StakeSnapshot(..), - decodeStakeSnapshot, - - EraHistory(..), - SystemStart(..), - - LedgerEpochInfo(..), - toLedgerEpochInfo, - - SlotsInEpoch(..), - SlotsToEpochEnd(..), - - slotToEpoch, - - LedgerState(..), - - getProgress, - getSlotForRelativeTime, + , SerialisedDebugLedgerState (..) + , ProtocolState (..) + , decodeProtocolState + , DebugLedgerState (..) + , decodeDebugLedgerState + , SerialisedCurrentEpochState (..) + , CurrentEpochState (..) + , decodeCurrentEpochState + , SerialisedPoolState (..) + , PoolState (..) + , decodePoolState + , SerialisedPoolDistribution (..) + , PoolDistribution (..) + , decodePoolDistribution + , SerialisedStakeSnapshots (..) + , StakeSnapshot (..) + , decodeStakeSnapshot + , EraHistory (..) + , SystemStart (..) + , LedgerEpochInfo (..) + , toLedgerEpochInfo + , SlotsInEpoch (..) + , SlotsToEpochEnd (..) + , slotToEpoch + , LedgerState (..) + , getProgress + , getSlotForRelativeTime -- * Internal conversion functions - toLedgerUTxO, - fromLedgerUTxO, - ) where - -import Cardano.Api.Address -import Cardano.Api.Block -import Cardano.Api.Certificate -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core -import Cardano.Api.GenesisParameters -import Cardano.Api.IPC.Version -import Cardano.Api.Keys.Shelley -import Cardano.Api.Modes -import Cardano.Api.NetworkId -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query.Types + , toLedgerUTxO + , fromLedgerUTxO + ) +where + +import Cardano.Api.Address +import Cardano.Api.Block +import Cardano.Api.Certificate +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core +import Cardano.Api.GenesisParameters +import Cardano.Api.IPC.Version +import Cardano.Api.Keys.Shelley +import Cardano.Api.Modes +import Cardano.Api.NetworkId +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query.Types import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.Tx.Body - +import Cardano.Api.Tx.Body import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Api.State.Query as L -import Cardano.Ledger.Binary +import Cardano.Ledger.Binary import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.CertState as L import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Credential as Shelley -import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Crypto (Crypto) import qualified Cardano.Ledger.Shelley.API as Shelley import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.LedgerState as L import qualified Cardano.Ledger.Shelley.LedgerState as Shelley -import Cardano.Slotting.EpochInfo (hoistEpochInfo) -import Cardano.Slotting.Slot (WithOrigin (..)) -import Cardano.Slotting.Time (SystemStart (..)) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, SlotLength) +import Cardano.Slotting.EpochInfo (hoistEpochInfo) +import Cardano.Slotting.Slot (WithOrigin (..)) +import Cardano.Slotting.Time (SystemStart (..)) +import Control.Monad.Trans.Except +import Data.Aeson (FromJSON (..), ToJSON (..), withObject) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (Parser) +import Data.Bifunctor (bimap, first) +import qualified Data.ByteString.Lazy as LBS +import Data.Either.Combinators (rightToMaybe) +import qualified Data.HashMap.Strict as HMS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.SOP.Constraint (SListI) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word64) +import GHC.Stack +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, SlotLength) import qualified Ouroboros.Consensus.Byron.Ledger as Consensus -import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto) +import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto) import qualified Ouroboros.Consensus.Cardano.Block as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus import qualified Ouroboros.Consensus.HardFork.History as Consensus import qualified Ouroboros.Consensus.HardFork.History as History @@ -124,30 +128,9 @@ import qualified Ouroboros.Consensus.Ledger.Query as Consensus import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger.Query.Types as Consensus -import Ouroboros.Network.Block (Serialised (..)) -import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) -import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..)) - -import Control.Monad.Trans.Except -import Data.Aeson (FromJSON (..), ToJSON (..), withObject) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Aeson.Types (Parser) -import Data.Bifunctor (bimap, first) -import qualified Data.ByteString.Lazy as LBS -import Data.Either.Combinators (rightToMaybe) -import qualified Data.HashMap.Strict as HMS -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.SOP.Constraint (SListI) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word64) -import GHC.Stack - +import Ouroboros.Network.Block (Serialised (..)) +import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..)) -- ---------------------------------------------------------------------------- -- Queries @@ -156,31 +139,26 @@ import GHC.Stack data QueryInMode result where QueryCurrentEra :: QueryInMode AnyCardanoEra - QueryInEra :: QueryInEra era result -> QueryInMode (Either EraMismatch result) - QueryEraHistory :: QueryInMode EraHistory - QuerySystemStart :: QueryInMode SystemStart - QueryChainBlockNo :: QueryInMode (WithOrigin BlockNo) - QueryChainPoint :: QueryInMode ChainPoint instance NodeToClientVersionOf (QueryInMode result) where nodeToClientVersionOf = \case - QueryCurrentEra -> NodeToClientV_9 - QueryInEra q -> nodeToClientVersionOf q - QueryEraHistory -> NodeToClientV_9 - QuerySystemStart -> NodeToClientV_9 + QueryCurrentEra -> NodeToClientV_9 + QueryInEra q -> nodeToClientVersionOf q + QueryEraHistory -> NodeToClientV_9 + QuerySystemStart -> NodeToClientV_9 QueryChainBlockNo -> NodeToClientV_10 - QueryChainPoint -> NodeToClientV_10 + QueryChainPoint -> NodeToClientV_10 data EraHistory where EraHistory @@ -188,14 +166,16 @@ data EraHistory where => History.Interpreter xs -> EraHistory -getProgress :: () +getProgress + :: () => SlotNo -> EraHistory -> Either Qry.PastHorizonException (RelativeTime, SlotLength) getProgress slotNo (EraHistory interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo) -- | Returns the slot number for provided relative time from 'SystemStart' -getSlotForRelativeTime :: () +getSlotForRelativeTime + :: () => RelativeTime -> EraHistory -> Either Qry.PastHorizonException SlotNo @@ -203,20 +183,23 @@ getSlotForRelativeTime relTime (EraHistory interpreter) = do (slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime pure slotNo -newtype LedgerEpochInfo = LedgerEpochInfo { unLedgerEpochInfo :: Consensus.EpochInfo (Either Text) } +newtype LedgerEpochInfo = LedgerEpochInfo {unLedgerEpochInfo :: Consensus.EpochInfo (Either Text)} -toLedgerEpochInfo :: () +toLedgerEpochInfo + :: () => EraHistory -> LedgerEpochInfo toLedgerEpochInfo (EraHistory interpreter) = - LedgerEpochInfo $ hoistEpochInfo (first (Text.pack . show) . runExcept) $ - Consensus.interpreterToEpochInfo interpreter + LedgerEpochInfo $ + hoistEpochInfo (first (Text.pack . show) . runExcept) $ + Consensus.interpreterToEpochInfo interpreter newtype SlotsInEpoch = SlotsInEpoch Word64 newtype SlotsToEpochEnd = SlotsToEpochEnd Word64 -slotToEpoch :: () +slotToEpoch + :: () => SlotNo -> EraHistory -> Either Qry.PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd) @@ -227,11 +210,11 @@ slotToEpoch slotNo (EraHistory interpreter) = case Qry.interpretQuery interprete deriving instance Show (QueryInMode result) data QueryInEra era result where - QueryByronUpdateState :: QueryInEra ByronEra ByronUpdateState - - QueryInShelleyBasedEra :: ShelleyBasedEra era - -> QueryInShelleyBasedEra era result - -> QueryInEra era result + QueryByronUpdateState :: QueryInEra ByronEra ByronUpdateState + QueryInShelleyBasedEra + :: ShelleyBasedEra era + -> QueryInShelleyBasedEra era result + -> QueryInEra era result instance NodeToClientVersionOf (QueryInEra era result) where nodeToClientVersionOf QueryByronUpdateState = NodeToClientV_9 @@ -239,97 +222,76 @@ instance NodeToClientVersionOf (QueryInEra era result) where deriving instance Show (QueryInEra era result) - data QueryInShelleyBasedEra era result where QueryEpoch :: QueryInShelleyBasedEra era EpochNo - QueryGenesisParameters :: QueryInShelleyBasedEra era (GenesisParameters ShelleyEra) - QueryProtocolParameters :: QueryInShelleyBasedEra era (Ledger.PParams (ShelleyLedgerEra era)) - QueryProtocolParametersUpdate - :: QueryInShelleyBasedEra era - (Map (Hash GenesisKey) ProtocolParametersUpdate) - + :: QueryInShelleyBasedEra + era + (Map (Hash GenesisKey) ProtocolParametersUpdate) QueryStakeDistribution :: QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational) - QueryUTxO :: QueryUTxOFilter -> QueryInShelleyBasedEra era (UTxO era) - QueryStakeAddresses :: Set StakeCredential -> NetworkId -> QueryInShelleyBasedEra era (Map StakeAddress L.Coin, Map StakeAddress PoolId) - QueryStakePools :: QueryInShelleyBasedEra era (Set PoolId) - QueryStakePoolParameters :: Set PoolId -> QueryInShelleyBasedEra era (Map PoolId StakePoolParameters) - - -- TODO: add support for RewardProvenance - -- QueryPoolRanking - -- :: QueryInShelleyBasedEra era RewardProvenance + -- TODO: add support for RewardProvenance + -- QueryPoolRanking + -- :: QueryInShelleyBasedEra era RewardProvenance QueryDebugLedgerState :: QueryInShelleyBasedEra era (SerialisedDebugLedgerState era) - QueryProtocolState :: QueryInShelleyBasedEra era (ProtocolState era) - QueryCurrentEpochState :: QueryInShelleyBasedEra era (SerialisedCurrentEpochState era) - QueryPoolState :: Maybe (Set PoolId) -> QueryInShelleyBasedEra era (SerialisedPoolState era) - QueryPoolDistribution :: Maybe (Set PoolId) -> QueryInShelleyBasedEra era (SerialisedPoolDistribution era) - QueryStakeSnapshot :: Maybe (Set PoolId) -> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era) - QueryStakeDelegDeposits :: Set StakeCredential -> QueryInShelleyBasedEra era (Map StakeCredential L.Coin) - QueryAccountState :: QueryInShelleyBasedEra era L.AccountState - QueryConstitution :: QueryInShelleyBasedEra era (L.Constitution (ShelleyLedgerEra era)) - QueryGovState :: QueryInShelleyBasedEra era (L.GovState (ShelleyLedgerEra era)) - QueryDRepState :: Set (Shelley.Credential Shelley.DRepRole StandardCrypto) - -> QueryInShelleyBasedEra era (Map (Shelley.Credential Shelley.DRepRole StandardCrypto) (L.DRepState StandardCrypto)) - + -> QueryInShelleyBasedEra + era + (Map (Shelley.Credential Shelley.DRepRole StandardCrypto) (L.DRepState StandardCrypto)) QueryDRepStakeDistr :: Set (Ledger.DRep StandardCrypto) -> QueryInShelleyBasedEra era (Map (Ledger.DRep StandardCrypto) L.Coin) - QueryCommitteeMembersState :: Set (Shelley.Credential Shelley.ColdCommitteeRole StandardCrypto) -> Set (Shelley.Credential Shelley.HotCommitteeRole StandardCrypto) -> Set L.MemberStatus -> QueryInShelleyBasedEra era (L.CommitteeMembersState StandardCrypto) - QueryStakeVoteDelegatees :: Set StakeCredential -> QueryInShelleyBasedEra era (Map StakeCredential (Ledger.DRep StandardCrypto)) - -- | Mapping for queries in Shelley-based eras returning minimal node-to-client protocol versions. More -- information about queries versioning can be found: -- * https://ouroboros-network.cardano.intersectmbo.org/ouroboros-network/Ouroboros-Network-NodeToClient.html#t:NodeToClientVersion @@ -356,14 +318,13 @@ instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where nodeToClientVersionOf QueryAccountState = NodeToClientV_16 nodeToClientVersionOf QueryConstitution = NodeToClientV_16 nodeToClientVersionOf QueryGovState = NodeToClientV_16 - nodeToClientVersionOf QueryDRepState{} = NodeToClientV_16 - nodeToClientVersionOf QueryDRepStakeDistr{} = NodeToClientV_16 - nodeToClientVersionOf QueryCommitteeMembersState{} = NodeToClientV_16 - nodeToClientVersionOf QueryStakeVoteDelegatees{} = NodeToClientV_16 + nodeToClientVersionOf QueryDRepState {} = NodeToClientV_16 + nodeToClientVersionOf QueryDRepStakeDistr {} = NodeToClientV_16 + nodeToClientVersionOf QueryCommitteeMembersState {} = NodeToClientV_16 + nodeToClientVersionOf QueryStakeVoteDelegatees {} = NodeToClientV_16 deriving instance Show (QueryInShelleyBasedEra era result) - -- ---------------------------------------------------------------------------- -- Wrapper types used in queries -- @@ -374,16 +335,13 @@ deriving instance Show (QueryInShelleyBasedEra era result) -- -- The 'QueryUTxOFilterByTxIn' is efficient since it fits with the structure of -- the UTxO (which is indexed by 'TxIn'). --- -data QueryUTxOFilter = - -- | /O(n) time and space/ for utxo size n - QueryUTxOWhole - - -- | /O(n) time, O(m) space/ for utxo size n, and address set size m - | QueryUTxOByAddress (Set AddressAny) - - -- | /O(m log n) time, O(m) space/ for utxo size n, and address set size m - | QueryUTxOByTxIn (Set TxIn) +data QueryUTxOFilter + = -- | /O(n) time and space/ for utxo size n + QueryUTxOWhole + | -- | /O(n) time, O(m) space/ for utxo size n, and address set size m + QueryUTxOByAddress (Set AddressAny) + | -- | /O(m log n) time, O(m) space/ for utxo size n, and address set size m + QueryUTxOByTxIn (Set TxIn) deriving (Eq, Show) instance NodeToClientVersionOf QueryUTxOFilter where @@ -392,15 +350,16 @@ instance NodeToClientVersionOf QueryUTxOFilter where nodeToClientVersionOf (QueryUTxOByTxIn _) = NodeToClientV_9 newtype ByronUpdateState = ByronUpdateState Byron.Update.State - deriving Show + deriving (Show) -newtype UTxO era = UTxO { unUTxO :: Map TxIn (TxOut CtxUTxO era) } +newtype UTxO era = UTxO {unUTxO :: Map TxIn (TxOut CtxUTxO era)} deriving (Eq, Show) data UTxOInAnyEra where - UTxOInAnyEra :: CardanoEra era - -> UTxO era - -> UTxOInAnyEra + UTxOInAnyEra + :: CardanoEra era + -> UTxO era + -> UTxOInAnyEra deriving instance Show UTxOInAnyEra @@ -408,22 +367,27 @@ instance IsCardanoEra era => ToJSON (UTxO era) where toJSON (UTxO m) = toJSON m toEncoding (UTxO m) = toEncoding m -instance (IsShelleyBasedEra era, FromJSON (TxOut CtxUTxO era)) - => FromJSON (UTxO era) where - parseJSON = withObject "UTxO" $ \hm -> do - let l = HMS.toList $ KeyMap.toHashMapText hm - res <- mapM toTxIn l - pure . UTxO $ Map.fromList res - where - toTxIn :: (Text, Aeson.Value) -> Parser (TxIn, TxOut CtxUTxO era) - toTxIn (txinText, txOutVal) = do - (,) <$> parseJSON (Aeson.String txinText) - <*> parseJSON txOutVal +instance + (IsShelleyBasedEra era, FromJSON (TxOut CtxUTxO era)) + => FromJSON (UTxO era) + where + parseJSON = withObject "UTxO" $ \hm -> do + let l = HMS.toList $ KeyMap.toHashMapText hm + res <- mapM toTxIn l + pure . UTxO $ Map.fromList res + where + toTxIn :: (Text, Aeson.Value) -> Parser (TxIn, TxOut CtxUTxO era) + toTxIn (txinText, txOutVal) = do + (,) + <$> parseJSON (Aeson.String txinText) + <*> parseJSON txOutVal newtype SerialisedDebugLedgerState era = SerialisedDebugLedgerState (Serialised (Shelley.NewEpochState (ShelleyLedgerEra era))) -decodeDebugLedgerState :: forall era. () +decodeDebugLedgerState + :: forall era + . () => FromCBOR (DebugLedgerState era) => SerialisedDebugLedgerState era -> Either (LBS.ByteString, DecoderError) (DebugLedgerState era) @@ -458,7 +422,8 @@ newtype SerialisedPoolState era newtype PoolState era = PoolState (Shelley.PState (ShelleyLedgerEra era)) decodePoolState - :: forall era. () + :: forall era + . () => Core.Era (ShelleyLedgerEra era) => DecCBOR (Shelley.PState (ShelleyLedgerEra era)) => SerialisedPoolState era @@ -467,14 +432,16 @@ decodePoolState (SerialisedPoolState (Serialised ls)) = PoolState <$> decodeFull (Core.eraProtVerLow @(ShelleyLedgerEra era)) ls newtype SerialisedPoolDistribution era - = SerialisedPoolDistribution (Serialised (Consensus.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era)))) + = SerialisedPoolDistribution + (Serialised (Consensus.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era)))) newtype PoolDistribution era = PoolDistribution { unPoolDistr :: Consensus.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era)) } decodePoolDistribution - :: forall era. (Crypto (Core.EraCrypto (ShelleyLedgerEra era))) + :: forall era + . Crypto (Core.EraCrypto (ShelleyLedgerEra era)) => ShelleyBasedEra era -> SerialisedPoolDistribution era -> Either DecoderError (PoolDistribution era) @@ -482,119 +449,127 @@ decodePoolDistribution sbe (SerialisedPoolDistribution (Serialised ls)) = PoolDistribution <$> decodeFull (eraProtVerLow sbe) ls newtype SerialisedStakeSnapshots era - = SerialisedStakeSnapshots (Serialised (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era)))) + = SerialisedStakeSnapshots + (Serialised (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era)))) newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era))) decodeStakeSnapshot - :: forall era. () + :: forall era + . () => FromCBOR (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era))) => SerialisedStakeSnapshots era -> Either DecoderError (StakeSnapshot era) decodeStakeSnapshot (SerialisedStakeSnapshots (Serialised ls)) = StakeSnapshot <$> Plain.decodeFull ls -toShelleyAddrSet :: CardanoEra era - -> Set AddressAny - -> Set (Shelley.Addr Consensus.StandardCrypto) +toShelleyAddrSet + :: CardanoEra era + -> Set AddressAny + -> Set (Shelley.Addr Consensus.StandardCrypto) toShelleyAddrSet era = - Set.fromList - . map toShelleyAddr + Set.fromList + . map toShelleyAddr -- Ignore any addresses that are not appropriate for the era, -- e.g. Shelley addresses in the Byron era, as these would not -- appear in the UTxO anyway. - . mapMaybe (rightToMaybe . anyAddressInEra era) - . Set.toList - + . mapMaybe (rightToMaybe . anyAddressInEra era) + . Set.toList -toLedgerUTxO :: () +toLedgerUTxO + :: () => ShelleyBasedEra era -> UTxO era -> Shelley.UTxO (ShelleyLedgerEra era) toLedgerUTxO sbe (UTxO utxo) = shelleyBasedEraConstraints sbe $ Shelley.UTxO - . Map.fromList - . map (bimap toShelleyTxIn (toShelleyTxOut sbe)) - . Map.toList + . Map.fromList + . map (bimap toShelleyTxIn (toShelleyTxOut sbe)) + . Map.toList $ utxo -fromLedgerUTxO :: () +fromLedgerUTxO + :: () => ShelleyBasedEra era -> Shelley.UTxO (ShelleyLedgerEra era) -> UTxO era fromLedgerUTxO sbe (Shelley.UTxO utxo) = shelleyBasedEraConstraints sbe $ UTxO - . Map.fromList - . map (bimap fromShelleyTxIn (fromShelleyTxOut sbe)) - . Map.toList + . Map.fromList + . map (bimap fromShelleyTxIn (fromShelleyTxOut sbe)) + . Map.toList $ utxo -fromShelleyPoolDistr :: Consensus.PoolDistr StandardCrypto - -> Map (Hash StakePoolKey) Rational +fromShelleyPoolDistr + :: Consensus.PoolDistr StandardCrypto + -> Map (Hash StakePoolKey) Rational fromShelleyPoolDistr = - --TODO: write an appropriate property to show it is safe to use - -- Map.fromListAsc or to use Map.mapKeysMonotonic - Map.fromList - . map (bimap StakePoolKeyHash Consensus.individualPoolStake) - . Map.toList - . Consensus.unPoolDistr - -fromShelleyDelegations :: Map (Shelley.Credential Shelley.Staking StandardCrypto) - (Shelley.KeyHash Shelley.StakePool StandardCrypto) - -> Map StakeCredential PoolId + -- TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + Map.fromList + . map (bimap StakePoolKeyHash Consensus.individualPoolStake) + . Map.toList + . Consensus.unPoolDistr + +fromShelleyDelegations + :: Map + (Shelley.Credential Shelley.Staking StandardCrypto) + (Shelley.KeyHash Shelley.StakePool StandardCrypto) + -> Map StakeCredential PoolId fromShelleyDelegations = - --TODO: write an appropriate property to show it is safe to use - -- Map.fromListAsc or to use Map.mapKeysMonotonic - -- In this case it may not be: the Ord instances for Shelley.Credential - -- do not match the one for StakeCredential - Map.fromList - . map (bimap fromShelleyStakeCredential StakePoolKeyHash) - . Map.toList - -fromShelleyRewardAccounts :: Shelley.RewardAccounts Consensus.StandardCrypto - -> Map StakeCredential L.Coin -fromShelleyRewardAccounts = - --TODO: write an appropriate property to show it is safe to use - -- Map.fromListAsc or to use Map.mapKeysMonotonic - Map.fromList - . map (first fromShelleyStakeCredential) - . Map.toList + -- TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + -- In this case it may not be: the Ord instances for Shelley.Credential + -- do not match the one for StakeCredential + Map.fromList + . map (bimap fromShelleyStakeCredential StakePoolKeyHash) + . Map.toList +fromShelleyRewardAccounts + :: Shelley.RewardAccounts Consensus.StandardCrypto + -> Map StakeCredential L.Coin +fromShelleyRewardAccounts = + -- TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + Map.fromList + . map (first fromShelleyStakeCredential) + . Map.toList -- ---------------------------------------------------------------------------- -- Conversions of queries into the consensus types. -- -toConsensusQuery :: forall block result. () +toConsensusQuery + :: forall block result + . () => Consensus.CardanoBlock L.StandardCrypto ~ block => QueryInMode result -> Some (Consensus.Query block) toConsensusQuery QueryCurrentEra = - Some $ Consensus.BlockQuery $ + Some $ + Consensus.BlockQuery $ Consensus.QueryHardFork Consensus.GetCurrentEra - toConsensusQuery QueryEraHistory = - Some $ Consensus.BlockQuery $ + Some $ + Consensus.BlockQuery $ Consensus.QueryHardFork Consensus.GetInterpreter - toConsensusQuery QuerySystemStart = Some Consensus.GetSystemStart - toConsensusQuery QueryChainBlockNo = Some Consensus.GetChainBlockNo - toConsensusQuery QueryChainPoint = Some Consensus.GetChainPoint - toConsensusQuery (QueryInEra QueryByronUpdateState) = - Some $ Consensus.BlockQuery $ - Consensus.QueryIfCurrentByron - Consensus.GetUpdateInterfaceState - + Some $ + Consensus.BlockQuery $ + Consensus.QueryIfCurrentByron + Consensus.GetUpdateInterfaceState toConsensusQuery (QueryInEra (QueryInShelleyBasedEra sbe q)) = shelleyBasedEraConstraints sbe $ toConsensusQueryShelleyBased sbe q -toConsensusQueryShelleyBased :: forall era protocol block result. () +toConsensusQueryShelleyBased + :: forall era protocol block result + . () => ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol (ShelleyLedgerEra era) => Core.EraCrypto (ShelleyLedgerEra era) ~ Consensus.StandardCrypto => Consensus.CardanoBlock L.StandardCrypto ~ block @@ -604,144 +579,147 @@ toConsensusQueryShelleyBased :: forall era protocol block result. () toConsensusQueryShelleyBased sbe = \case QueryEpoch -> Some (consensusQueryInEraInMode era Consensus.GetEpochNo) - QueryConstitution -> caseShelleyToBabbageOrConwayEraOnwards - (const $ error "toConsensusQueryShelleyBased: QueryConstitution is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era Consensus.GetConstitution)) - sbe - + (const $ error "toConsensusQueryShelleyBased: QueryConstitution is only available in the Conway era") + (const $ Some (consensusQueryInEraInMode era Consensus.GetConstitution)) + sbe QueryGenesisParameters -> Some (consensusQueryInEraInMode era Consensus.GetGenesisConfig) - QueryProtocolParameters -> Some (consensusQueryInEraInMode era Consensus.GetCurrentPParams) - QueryProtocolParametersUpdate -> Some (consensusQueryInEraInMode era Consensus.GetProposedPParamsUpdates) - QueryStakeDistribution -> Some (consensusQueryInEraInMode era Consensus.GetStakeDistribution) - QueryUTxO QueryUTxOWhole -> Some (consensusQueryInEraInMode era Consensus.GetUTxOWhole) - QueryUTxO (QueryUTxOByAddress addrs) -> Some (consensusQueryInEraInMode era (Consensus.GetUTxOByAddress addrs')) - where - addrs' :: Set (Shelley.Addr Consensus.StandardCrypto) - addrs' = toShelleyAddrSet era addrs - + where + addrs' :: Set (Shelley.Addr Consensus.StandardCrypto) + addrs' = toShelleyAddrSet era addrs QueryUTxO (QueryUTxOByTxIn txins) -> Some (consensusQueryInEraInMode era (Consensus.GetUTxOByTxIn txins')) - where - txins' :: Set (Shelley.TxIn Consensus.StandardCrypto) - txins' = Set.map toShelleyTxIn txins - + where + txins' :: Set (Shelley.TxIn Consensus.StandardCrypto) + txins' = Set.map toShelleyTxIn txins QueryStakeAddresses creds _nId -> - Some (consensusQueryInEraInMode era - (Consensus.GetFilteredDelegationsAndRewardAccounts creds')) - where - creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) - creds' = Set.map toShelleyStakeCredential creds - + Some + ( consensusQueryInEraInMode + era + (Consensus.GetFilteredDelegationsAndRewardAccounts creds') + ) + where + creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) + creds' = Set.map toShelleyStakeCredential creds QueryStakePools -> Some (consensusQueryInEraInMode era Consensus.GetStakePools) - QueryStakePoolParameters poolids -> Some (consensusQueryInEraInMode era (Consensus.GetStakePoolParams poolids')) - where - poolids' :: Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - poolids' = Set.map unStakePoolKeyHash poolids - + where + poolids' :: Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) + poolids' = Set.map unStakePoolKeyHash poolids QueryDebugLedgerState -> Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugNewEpochState)) - QueryProtocolState -> Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugChainDepState)) - QueryCurrentEpochState -> Some (consensusQueryInEraInMode era (Consensus.GetCBOR Consensus.DebugEpochState)) - QueryPoolState poolIds -> - Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds)))) - + Some + ( consensusQueryInEraInMode + era + (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds))) + ) QueryStakeSnapshot mPoolIds -> - Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetStakeSnapshots (fmap (Set.map unStakePoolKeyHash) mPoolIds)))) - + Some + ( consensusQueryInEraInMode + era + (Consensus.GetCBOR (Consensus.GetStakeSnapshots (fmap (Set.map unStakePoolKeyHash) mPoolIds))) + ) QueryPoolDistribution poolIds -> - Some (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolDistr (getPoolIds <$> poolIds)))) - where - getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) - + Some + (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolDistr (getPoolIds <$> poolIds)))) + where + getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) + getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) QueryStakeDelegDeposits creds -> Some (consensusQueryInEraInMode era (Consensus.GetStakeDelegDeposits creds')) - where - creds' = Set.map toShelleyStakeCredential creds - + where + creds' = Set.map toShelleyStakeCredential creds QueryAccountState -> Some (consensusQueryInEraInMode era Consensus.GetAccountState) - QueryGovState -> Some (consensusQueryInEraInMode era Consensus.GetGovState) - QueryDRepState creds -> caseShelleyToBabbageOrConwayEraOnwards - (const $ error "toConsensusQueryShelleyBased: QueryDRepState is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds))) - sbe - + (const $ error "toConsensusQueryShelleyBased: QueryDRepState is only available in the Conway era") + (const $ Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds))) + sbe QueryDRepStakeDistr dreps -> caseShelleyToBabbageOrConwayEraOnwards - (const $ error "toConsensusQueryShelleyBased: QueryDRepStakeDistr is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era (Consensus.GetDRepStakeDistr dreps))) - sbe - + ( const $ + error "toConsensusQueryShelleyBased: QueryDRepStakeDistr is only available in the Conway era" + ) + (const $ Some (consensusQueryInEraInMode era (Consensus.GetDRepStakeDistr dreps))) + sbe QueryCommitteeMembersState coldCreds hotCreds statuses -> caseShelleyToBabbageOrConwayEraOnwards - (const $ error "toConsensusQueryShelleyBased: QueryCommitteeMembersState is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses))) - sbe - + ( const $ + error "toConsensusQueryShelleyBased: QueryCommitteeMembersState is only available in the Conway era" + ) + ( const $ + Some + (consensusQueryInEraInMode era (Consensus.GetCommitteeMembersState coldCreds hotCreds statuses)) + ) + sbe QueryStakeVoteDelegatees creds -> caseShelleyToBabbageOrConwayEraOnwards - (const $ error "toConsensusQueryShelleyBased: QueryStakeVoteDelegatees is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era - (Consensus.GetFilteredVoteDelegatees creds'))) - sbe - where - creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) - creds' = Set.map toShelleyStakeCredential creds - - where - era = toCardanoEra sbe + ( const $ + error "toConsensusQueryShelleyBased: QueryStakeVoteDelegatees is only available in the Conway era" + ) + ( const $ + Some + ( consensusQueryInEraInMode + era + (Consensus.GetFilteredVoteDelegatees creds') + ) + ) + sbe + where + creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) + creds' = Set.map toShelleyStakeCredential creds + where + era = toCardanoEra sbe consensusQueryInEraInMode - :: forall era erablock modeblock result result' xs. - ConsensusBlockForEra era ~ erablock + :: forall era erablock modeblock result result' xs + . ConsensusBlockForEra era ~ erablock => Consensus.CardanoBlock L.StandardCrypto ~ modeblock => modeblock ~ Consensus.HardForkBlock xs => Consensus.HardForkQueryResult xs result ~ result' => CardanoEra era - -> Consensus.BlockQuery erablock result + -> Consensus.BlockQuery erablock result -> Consensus.Query modeblock result' consensusQueryInEraInMode era = - Consensus.BlockQuery - . case era of - ByronEra -> Consensus.QueryIfCurrentByron - ShelleyEra -> Consensus.QueryIfCurrentShelley - AllegraEra -> Consensus.QueryIfCurrentAllegra - MaryEra -> Consensus.QueryIfCurrentMary - AlonzoEra -> Consensus.QueryIfCurrentAlonzo - BabbageEra -> Consensus.QueryIfCurrentBabbage - ConwayEra -> Consensus.QueryIfCurrentConway + Consensus.BlockQuery + . case era of + ByronEra -> Consensus.QueryIfCurrentByron + ShelleyEra -> Consensus.QueryIfCurrentShelley + AllegraEra -> Consensus.QueryIfCurrentAllegra + MaryEra -> Consensus.QueryIfCurrentMary + AlonzoEra -> Consensus.QueryIfCurrentAlonzo + BabbageEra -> Consensus.QueryIfCurrentBabbage + ConwayEra -> Consensus.QueryIfCurrentConway -- ---------------------------------------------------------------------------- -- Conversions of query results from the consensus types. -- -fromConsensusQueryResult :: forall block result result'. () +fromConsensusQueryResult + :: forall block result result' + . () => HasCallStack => Consensus.CardanoBlock L.StandardCrypto ~ block => QueryInMode result @@ -749,102 +727,115 @@ fromConsensusQueryResult :: forall block result result'. () -> result' -> result fromConsensusQueryResult QueryEraHistory q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetInterpreter) - -> EraHistory r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetInterpreter) -> + EraHistory r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QuerySystemStart q' r' = - case q' of - Consensus.GetSystemStart - -> r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.GetSystemStart -> + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QueryChainBlockNo q' r' = - case q' of - Consensus.GetChainBlockNo - -> r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.GetChainBlockNo -> + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QueryChainPoint q' r' = - case q' of - Consensus.GetChainPoint - -> fromConsensusPointHF r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.GetChainPoint -> + fromConsensusPointHF r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult QueryCurrentEra q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra) - -> fromConsensusEraIndex r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryHardFork Consensus.GetCurrentEra) -> + fromConsensusEraIndex r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra QueryByronUpdateState) q' r' = - case q' of - Consensus.BlockQuery - (Consensus.QueryIfCurrentByron Consensus.GetUpdateInterfaceState) - -> bimap fromConsensusEraMismatch ByronUpdateState r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery + (Consensus.QueryIfCurrentByron Consensus.GetUpdateInterfaceState) -> + bimap fromConsensusEraMismatch ByronUpdateState r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraShelley q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentShelley q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraShelley q q'') - r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentShelley q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraShelley + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraAllegra q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentAllegra q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraAllegra q q'') - r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentAllegra q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraAllegra + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraMary q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentMary q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraMary q q'') - r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentMary q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraMary + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraAlonzo q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentAlonzo q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraAlonzo q q'') - r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentAlonzo q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraAlonzo + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraBabbage q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentBabbage q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraBabbage q q'') - r' - _ -> fromConsensusQueryResultMismatch - + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentBabbage q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraBabbage + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraConway q)) q' r' = - case q' of - Consensus.BlockQuery (Consensus.QueryIfCurrentConway q'') - -> bimap fromConsensusEraMismatch - (fromConsensusQueryResultShelleyBased - ShelleyBasedEraConway q q'') - r' - _ -> fromConsensusQueryResultMismatch + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentConway q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraConway + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch -- This function is written like this so that we have exhaustive pattern checking -- on the @QueryInShelleyBasedEra era result@ value. Don't change the top-level -- @case sbeQuery of ...@! fromConsensusQueryResultShelleyBased - :: forall era ledgerera protocol result result'. - HasCallStack + :: forall era ledgerera protocol result result' + . HasCallStack => ShelleyLedgerEra era ~ ledgerera => Core.EraCrypto ledgerera ~ Consensus.StandardCrypto => ConsensusProtocol era ~ protocol @@ -883,34 +874,34 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = case q' of Consensus.GetUTxOWhole -> fromLedgerUTxO sbe r' _ -> fromConsensusQueryResultMismatch - QueryUTxO QueryUTxOByAddress{} -> + QueryUTxO QueryUTxOByAddress {} -> case q' of - Consensus.GetUTxOByAddress{} -> fromLedgerUTxO sbe r' + Consensus.GetUTxOByAddress {} -> fromLedgerUTxO sbe r' _ -> fromConsensusQueryResultMismatch - QueryUTxO QueryUTxOByTxIn{} -> + QueryUTxO QueryUTxOByTxIn {} -> case q' of - Consensus.GetUTxOByTxIn{} -> fromLedgerUTxO sbe r' + Consensus.GetUTxOByTxIn {} -> fromLedgerUTxO sbe r' _ -> fromConsensusQueryResultMismatch QueryStakeAddresses _ nId -> case q' of - Consensus.GetFilteredDelegationsAndRewardAccounts{} -> + Consensus.GetFilteredDelegationsAndRewardAccounts {} -> let (delegs, rwaccs) = r' - in ( Map.mapKeys (makeStakeAddress nId) $ fromShelleyRewardAccounts rwaccs - , Map.mapKeys (makeStakeAddress nId) $ fromShelleyDelegations delegs - ) + in ( Map.mapKeys (makeStakeAddress nId) $ fromShelleyRewardAccounts rwaccs + , Map.mapKeys (makeStakeAddress nId) $ fromShelleyDelegations delegs + ) _ -> fromConsensusQueryResultMismatch QueryStakePools -> case q' of Consensus.GetStakePools -> Set.map StakePoolKeyHash r' _ -> fromConsensusQueryResultMismatch - QueryStakePoolParameters{} -> + QueryStakePoolParameters {} -> case q' of - Consensus.GetStakePoolParams{} -> + Consensus.GetStakePoolParams {} -> Map.map fromShelleyPoolParams - . Map.mapKeysMonotonic StakePoolKeyHash - $ r' + . Map.mapKeysMonotonic StakePoolKeyHash + $ r' _ -> fromConsensusQueryResultMismatch - QueryDebugLedgerState{} -> + QueryDebugLedgerState {} -> case q' of Consensus.GetCBOR Consensus.DebugNewEpochState -> SerialisedDebugLedgerState r' @@ -925,52 +916,52 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = Consensus.GetCBOR Consensus.DebugEpochState -> SerialisedCurrentEpochState r' _ -> fromConsensusQueryResultMismatch - QueryPoolState{} -> + QueryPoolState {} -> case q' of Consensus.GetCBOR Consensus.GetPoolState {} -> SerialisedPoolState r' _ -> fromConsensusQueryResultMismatch - QueryPoolDistribution{} -> + QueryPoolDistribution {} -> case q' of Consensus.GetCBOR Consensus.GetPoolDistr {} -> SerialisedPoolDistribution r' _ -> fromConsensusQueryResultMismatch - QueryStakeSnapshot{} -> + QueryStakeSnapshot {} -> case q' of Consensus.GetCBOR Consensus.GetStakeSnapshots {} -> SerialisedStakeSnapshots r' _ -> fromConsensusQueryResultMismatch - QueryStakeDelegDeposits{} -> + QueryStakeDelegDeposits {} -> case q' of - Consensus.GetStakeDelegDeposits{} -> + Consensus.GetStakeDelegDeposits {} -> Map.mapKeysMonotonic fromShelleyStakeCredential r' _ -> fromConsensusQueryResultMismatch - QueryAccountState{} -> + QueryAccountState {} -> case q' of - Consensus.GetAccountState{} -> + Consensus.GetAccountState {} -> r' _ -> fromConsensusQueryResultMismatch - QueryGovState{} -> + QueryGovState {} -> case q' of - Consensus.GetGovState{} -> + Consensus.GetGovState {} -> r' _ -> fromConsensusQueryResultMismatch - QueryDRepState{} -> + QueryDRepState {} -> case q' of - Consensus.GetDRepState{} -> + Consensus.GetDRepState {} -> r' _ -> fromConsensusQueryResultMismatch - QueryDRepStakeDistr{} -> + QueryDRepStakeDistr {} -> case q' of - Consensus.GetDRepStakeDistr{} -> + Consensus.GetDRepStakeDistr {} -> r' _ -> fromConsensusQueryResultMismatch - QueryCommitteeMembersState{} -> + QueryCommitteeMembersState {} -> case q' of - Consensus.GetCommitteeMembersState{} -> + Consensus.GetCommitteeMembersState {} -> r' _ -> fromConsensusQueryResultMismatch - QueryStakeVoteDelegatees{} -> + QueryStakeVoteDelegatees {} -> case q' of Consensus.GetFilteredVoteDelegatees {} -> Map.mapKeys fromShelleyStakeCredential r' @@ -989,13 +980,12 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = -- trigger this error. -- -- Such mismatches should be preventable with an appropriate property test. --- fromConsensusQueryResultMismatch :: HasCallStack => a fromConsensusQueryResultMismatch = withFrozenCallStack $ error "fromConsensusQueryResult: internal query mismatch" - -fromConsensusEraMismatch :: SListI xs - => Consensus.MismatchEraInfo xs -> EraMismatch +fromConsensusEraMismatch + :: SListI xs + => Consensus.MismatchEraInfo xs -> EraMismatch fromConsensusEraMismatch = Consensus.mkEraMismatch diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index da84fef678..917668721a 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -33,237 +33,437 @@ module Cardano.Api.Query.Expr , queryDRepState , queryGovState , queryStakeVoteDelegatees - ) where - -import Cardano.Api.Address -import Cardano.Api.Block -import Cardano.Api.Certificate -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.GenesisParameters -import Cardano.Api.IPC -import Cardano.Api.IPC.Monad -import Cardano.Api.Keys.Shelley -import Cardano.Api.NetworkId -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query + ) +where + +import Cardano.Api.Address +import Cardano.Api.Block +import Cardano.Api.Certificate +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.GenesisParameters +import Cardano.Api.IPC +import Cardano.Api.IPC.Monad +import Cardano.Api.Keys.Shelley +import Cardano.Api.NetworkId +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query import qualified Cardano.Api.ReexposeLedger as Ledger - import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Api.State.Query as L import qualified Cardano.Ledger.CertState as L import qualified Cardano.Ledger.Coin as L -import Cardano.Ledger.Core (EraCrypto) +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Credential as L import qualified Cardano.Ledger.Keys as L -import Cardano.Ledger.SafeHash +import Cardano.Ledger.SafeHash import qualified Cardano.Ledger.Shelley.LedgerState as L -import Cardano.Slotting.Slot -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus - -import Data.Map (Map) -import Data.Set (Set) +import Cardano.Slotting.Slot +import Data.Map (Map) +import Data.Set (Set) import qualified Data.Set as S - -queryChainBlockNo :: () - => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus + +queryChainBlockNo + :: () + => LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (WithOrigin BlockNo)) queryChainBlockNo = queryExpr QueryChainBlockNo -queryChainPoint :: () +queryChainPoint + :: () => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError ChainPoint) queryChainPoint = queryExpr QueryChainPoint -queryCurrentEra :: () +queryCurrentEra + :: () => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError AnyCardanoEra) queryCurrentEra = queryExpr QueryCurrentEra -queryCurrentEpochState :: () +queryCurrentEpochState + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era))) queryCurrentEpochState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryCurrentEpochState -queryEpoch :: () +queryEpoch + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch EpochNo)) queryEpoch sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryEpoch -queryDebugLedgerState :: () +queryDebugLedgerState + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era))) queryDebugLedgerState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryDebugLedgerState -queryEraHistory :: () - => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError EraHistory) +queryEraHistory + :: () + => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError EraHistory) queryEraHistory = queryExpr QueryEraHistory -queryGenesisParameters :: () +queryGenesisParameters + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra))) queryGenesisParameters sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters -queryPoolDistribution :: () +queryPoolDistribution + :: () => BabbageEraOnwards era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era))) queryPoolDistribution era mPoolIds = do let sbe = babbageEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds -queryPoolState :: () +queryPoolState + :: () => BabbageEraOnwards era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era))) queryPoolState era mPoolIds = do let sbe = babbageEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds -queryProtocolParameters :: () +queryProtocolParameters + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era)))) queryProtocolParameters sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParameters -queryConstitutionHash :: () +queryConstitutionHash + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + ( Either + UnsupportedNtcVersionError + (Either EraMismatch (SafeHash (EraCrypto (ShelleyLedgerEra era)) L.AnchorData)) + ) queryConstitutionHash sbe = - (fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) - $ queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution + (fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) $ + queryExpr $ + QueryInEra $ + QueryInShelleyBasedEra sbe QueryConstitution -queryProtocolParametersUpdate :: () +queryProtocolParametersUpdate + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + ( Either + UnsupportedNtcVersionError + (Either EraMismatch (Map (Hash GenesisKey) ProtocolParametersUpdate)) + ) queryProtocolParametersUpdate sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParametersUpdate -queryProtocolState :: () +queryProtocolState + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era))) queryProtocolState sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolState -queryStakeAddresses :: () +queryStakeAddresses + :: () => ShelleyBasedEra era -> Set StakeCredential -> NetworkId - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeAddress L.Coin, Map StakeAddress PoolId))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + ( Either + UnsupportedNtcVersionError + (Either EraMismatch (Map StakeAddress L.Coin, Map StakeAddress PoolId)) + ) queryStakeAddresses sbe stakeCredentials networkId = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId -queryStakeDelegDeposits :: () +queryStakeDelegDeposits + :: () => BabbageEraOnwards era -> Set StakeCredential - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential L.Coin))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential L.Coin))) queryStakeDelegDeposits era stakeCreds | S.null stakeCreds = pure . pure $ pure mempty - | otherwise = do - let sbe = babbageEraOnwardsToShelleyBasedEra era - queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds + | otherwise = do + let sbe = babbageEraOnwardsToShelleyBasedEra era + queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds -queryStakeDistribution :: () +queryStakeDistribution + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational))) queryStakeDistribution sbe = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryStakeDistribution -queryStakePoolParameters :: () +queryStakePoolParameters + :: () => ShelleyBasedEra era -> Set PoolId - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters))) queryStakePoolParameters sbe poolIds - | S.null poolIds = pure . pure $ pure mempty - | otherwise = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds + | S.null poolIds = pure . pure $ pure mempty + | otherwise = + queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds -queryStakePools :: () +queryStakePools + :: () => ShelleyBasedEra era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId))) queryStakePools sbe = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools -queryStakeSnapshot :: () +queryStakeSnapshot + :: () => BabbageEraOnwards era -> Maybe (Set PoolId) - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era))) queryStakeSnapshot era mPoolIds = do let sbe = babbageEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds -querySystemStart :: () +querySystemStart + :: () => LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError SystemStart) querySystemStart = queryExpr QuerySystemStart -queryUtxo :: () +queryUtxo + :: () => ShelleyBasedEra era -> QueryUTxOFilter - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era))) queryUtxo sbe utxoFilter = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter -queryConstitution :: () +queryConstitution + :: () => ConwayEraOnwards era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.Constitution (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (L.Constitution (ShelleyLedgerEra era)))) queryConstitution era = do let sbe = conwayEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution -queryGovState :: () +queryGovState + :: () => ConwayEraOnwards era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era)))) queryGovState era = do let sbe = conwayEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState -queryDRepState :: () +queryDRepState + :: () => ConwayEraOnwards era -> Set (L.Credential L.DRepRole L.StandardCrypto) -- ^ An empty credentials set means that states for all DReps will be returned - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + ( Either + UnsupportedNtcVersionError + (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto))) + ) queryDRepState era drepCreds = do let sbe = conwayEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds -queryDRepStakeDistribution :: () +queryDRepStakeDistribution + :: () => ConwayEraOnwards era -> Set (L.DRep L.StandardCrypto) -- ^ An empty DRep set means that distributions for all DReps will be returned - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) L.Coin))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) L.Coin))) queryDRepStakeDistribution era dreps = do let sbe = conwayEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses. -- If empty sets are passed as filters, then no filtering is done. -queryCommitteeMembersState :: () +queryCommitteeMembersState + :: () => ConwayEraOnwards era -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto) -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto) -> Set L.MemberStatus - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.CommitteeMembersState L.StandardCrypto))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch (L.CommitteeMembersState L.StandardCrypto))) queryCommitteeMembersState era coldCreds hotCreds statuses = do let sbe = conwayEraOnwardsToShelleyBasedEra era - queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) + queryExpr $ + QueryInEra $ + QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses) -queryStakeVoteDelegatees :: () +queryStakeVoteDelegatees + :: () => ConwayEraOnwards era -> Set StakeCredential - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeCredential (L.DRep L.StandardCrypto)))) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + ( Either + UnsupportedNtcVersionError + (Either EraMismatch (Map StakeCredential (L.DRep L.StandardCrypto))) + ) queryStakeVoteDelegatees era stakeCredentials = do let sbe = conwayEraOnwardsToShelleyBasedEra era queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeVoteDelegatees stakeCredentials -queryAccountState :: () +queryAccountState + :: () => ConwayEraOnwards era - -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch L.AccountState)) + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either UnsupportedNtcVersionError (Either EraMismatch L.AccountState)) queryAccountState cOnwards = - queryExpr $ QueryInEra . QueryInShelleyBasedEra (conwayEraOnwardsToShelleyBasedEra cOnwards) $ QueryAccountState + queryExpr $ + QueryInEra . QueryInShelleyBasedEra (conwayEraOnwardsToShelleyBasedEra cOnwards) $ + QueryAccountState diff --git a/cardano-api/internal/Cardano/Api/Query/Types.hs b/cardano-api/internal/Cardano/Api/Query/Types.hs index 148706d94b..91c186ad1b 100644 --- a/cardano-api/internal/Cardano/Api/Query/Types.hs +++ b/cardano-api/internal/Cardano/Api/Query/Types.hs @@ -3,18 +3,17 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Api.Query.Types - ( DebugLedgerState(..) + ( DebugLedgerState (..) , toDebugLedgerStatePair - ) where + ) +where -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Orphans () - -import Cardano.Binary +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Orphans () +import Cardano.Binary import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Shelley.API as Shelley - -import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson (ToJSON (..), object, (.=)) import qualified Data.Aeson as Aeson newtype DebugLedgerState era = DebugLedgerState @@ -24,18 +23,19 @@ newtype DebugLedgerState era = DebugLedgerState instance IsShelleyBasedEra era => FromCBOR (DebugLedgerState era) where fromCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) $ - DebugLedgerState <$> - (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era))) + DebugLedgerState + <$> (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era))) instance IsShelleyBasedEra era => ToJSON (DebugLedgerState era) where toJSON = - let sbe = shelleyBasedEra @era in - object . toDebugLedgerStatePair sbe + let sbe = shelleyBasedEra @era + in object . toDebugLedgerStatePair sbe toEncoding = - let sbe = shelleyBasedEra @era in - Aeson.pairs . mconcat . toDebugLedgerStatePair sbe + let sbe = shelleyBasedEra @era + in Aeson.pairs . mconcat . toDebugLedgerStatePair sbe -toDebugLedgerStatePair :: () +toDebugLedgerStatePair + :: () => Aeson.KeyValue e a => ShelleyBasedEra era -> DebugLedgerState era @@ -48,7 +48,7 @@ toDebugLedgerStatePair sbe (DebugLedgerState newEpochS) = !nesEs = Shelley.nesEs newEpochS !nesRu = Shelley.nesRu newEpochS !nesPd = Shelley.nesPd newEpochS - in [ "lastEpoch" .= nesEL + in [ "lastEpoch" .= nesEL , "blocksBefore" .= nesBprev , "blocksCurrent" .= nesBcur , "stateBefore" .= nesEs diff --git a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs index 89a8c56ced..f11a3bc38c 100644 --- a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs +++ b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs @@ -3,15 +3,15 @@ module Cardano.Api.ReexposeLedger ( Credential (..) , credToText - , KeyHash(..) - , KeyRole(..) + , KeyHash (..) + , KeyRole (..) , VKey (..) - , ShelleyTxCert(..) - , ShelleyDelegCert(..) - , ShelleyEraTxCert(..) + , ShelleyTxCert (..) + , ShelleyDelegCert (..) + , ShelleyEraTxCert (..) , PState (..) - , GenesisDelegCert(..) - , GenDelegPair(..) + , GenesisDelegCert (..) + , GenDelegPair (..) , StakeReference (..) , WitVKey (..) , hashKey @@ -19,13 +19,13 @@ module Cardano.Api.ReexposeLedger , hashWithSerialiser , PoolParams (..) , HasKeyRole - , MIRPot(..) - , MIRTarget(..) - , MIRCert(..) - , StakePoolRelay(..) - , PoolMetadata(..) - , EraTxCert(..) - , StrictMaybe(..) + , MIRPot (..) + , MIRTarget (..) + , MIRCert (..) + , StakePoolRelay (..) + , PoolMetadata (..) + , EraTxCert (..) + , StrictMaybe (..) , pattern DelegTxCert , pattern RegPoolTxCert , pattern RetirePoolTxCert @@ -42,14 +42,13 @@ module Cardano.Api.ReexposeLedger , pattern MirTxCert , pattern GenesisDelegTxCert , pattern UpdateDRepTxCert - -- Core , Coin (..) , EraPParams (..) , Era (..) - , Network(..) - , PoolCert(..) - , PParams(..) + , Network (..) + , PoolCert (..) + , PParams (..) , PParamsUpdate , Value , addDeltaCoin @@ -57,27 +56,26 @@ module Cardano.Api.ReexposeLedger , toEraCBOR , fromEraCBOR , ppMinUTxOValueL - -- Conway - , Anchor(..) - , Delegatee(..) - , DRep(..) - , DRepState(..) - , ConwayTxCert(..) - , ConwayDelegCert(..) - , ConwayEraTxCert(..) - , ConwayGovCert(..) - , ConwayGenesis(..) - , UpgradeConwayPParams(..) + , Anchor (..) + , Delegatee (..) + , DRep (..) + , DRepState (..) + , ConwayTxCert (..) + , ConwayDelegCert (..) + , ConwayEraTxCert (..) + , ConwayGovCert (..) + , ConwayGenesis (..) + , UpgradeConwayPParams (..) , GovState - , GovActionId(..) + , GovActionId (..) , Vote (..) , Voter (..) - , VotingProcedure(..) - , ProposalProcedure(..) - , VotingProcedures(..) - , PoolVotingThresholds(..) - , DRepVotingThresholds(..) + , VotingProcedure (..) + , ProposalProcedure (..) + , VotingProcedures (..) + , PoolVotingThresholds (..) + , DRepVotingThresholds (..) , dvtPPNetworkGroupL , dvtPPGovGroupL , dvtPPTechnicalGroupL @@ -87,10 +85,9 @@ module Cardano.Api.ReexposeLedger , drepAnchorL , drepDepositL , csCommitteeCredsL - -- Byron - , Annotated(..) - , Byron.Tx(..) + , Annotated (..) + , Byron.Tx (..) , byronProtVer , serialize' , toPlainDecoder @@ -99,102 +96,176 @@ module Cardano.Api.ReexposeLedger , ByteSpan (..) , slice , Decoder - -- Shelley , secondsToNominalDiffTimeMicro - -- Babbage , CoinPerByte (..) - -- Alonzo , CoinPerWord (..) - , Prices(..) + , Prices (..) , CostModels , AlonzoGenesis , ppPricesL - -- Base , boundRational , unboundRational , DnsName , dnsToText - , EpochInterval(..) + , EpochInterval (..) , textToDns , Url , urlToText , textToUrl , portToWord16 - , ProtVer(..) + , ProtVer (..) , strictMaybeToMaybe , maybeToStrictMaybe - , AnchorData(..) + , AnchorData (..) , hashAnchorData , UnitInterval , mkVersion , NonNegativeInterval - -- Crypto , hashToBytes , hashFromBytes , Crypto , StandardCrypto , ADDRHASH - -- Slotting - , EpochNo(..) - + , EpochNo (..) -- SafeHash , SafeHash , unsafeMakeSafeHash , extractHash - ) where + ) +where import qualified Cardano.Chain.UTxO as Byron -import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) -import Cardano.Ledger.Alonzo.Core (CoinPerWord (..), PParamsUpdate (..), ppPricesL) -import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis) -import Cardano.Ledger.Alonzo.Scripts (CostModels, Prices (..)) -import Cardano.Ledger.Api.Tx.Cert (pattern AuthCommitteeHotKeyTxCert, - pattern DelegStakeTxCert, pattern DelegTxCert, pattern GenesisDelegTxCert, - pattern MirTxCert, pattern RegDRepTxCert, pattern RegDepositDelegTxCert, - pattern RegDepositTxCert, pattern RegPoolTxCert, pattern RegTxCert, - pattern ResignCommitteeColdTxCert, pattern RetirePoolTxCert, - pattern UnRegDRepTxCert, pattern UnRegDepositTxCert, pattern UnRegTxCert) -import Cardano.Ledger.Babbage.Core (CoinPerByte (..)) -import Cardano.Ledger.BaseTypes (AnchorData (..), DnsName, EpochInterval (..), - Network (..), NonNegativeInterval, ProtVer (..), StrictMaybe (..), UnitInterval, - Url, boundRational, dnsToText, hashAnchorData, maybeToStrictMaybe, mkVersion, - portToWord16, strictMaybeToMaybe, textToDns, textToUrl, unboundRational, - urlToText) -import Cardano.Ledger.Binary (Annotated (..), ByteSpan (..), byronProtVer, fromCBOR, - serialize', slice, toCBOR, toPlainDecoder) -import Cardano.Ledger.Binary.Plain (Decoder) -import Cardano.Ledger.CertState (DRepState (..), csCommitteeCredsL) -import Cardano.Ledger.Coin (Coin (..), addDeltaCoin, toDeltaCoin) -import Cardano.Ledger.Conway.Core (DRepVotingThresholds (..), PoolVotingThresholds (..), - dvtPPEconomicGroupL, dvtPPGovGroupL, dvtPPNetworkGroupL, dvtPPTechnicalGroupL, - dvtUpdateToConstitutionL) -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) -import Cardano.Ledger.Conway.Governance (Anchor (..), GovActionId (..), GovState, - ProposalProcedure (..), Vote (..), Voter (..), VotingProcedure (..), - VotingProcedures (..)) -import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..)) -import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayEraTxCert (..), - ConwayGovCert (..), ConwayTxCert (..), Delegatee (..), pattern UpdateDRepTxCert) -import Cardano.Ledger.Core (Era (..), EraPParams (..), PParams (..), PoolCert (..), Value, - fromEraCBOR, ppMinUTxOValueL, toEraCBOR) -import Cardano.Ledger.Credential (Credential (..), credToText) -import Cardano.Ledger.Crypto (ADDRHASH, Crypto, StandardCrypto) -import Cardano.Ledger.DRep (DRep (..), drepAnchorL, drepDepositL, drepExpiryL) -import Cardano.Ledger.Keys (HasKeyRole, KeyHash (..), KeyRole (..), VKey (..), - hashWithSerialiser) -import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..)) -import Cardano.Ledger.SafeHash (SafeHash, extractHash, unsafeMakeSafeHash) -import Cardano.Ledger.Shelley.API (GenDelegPair (..), StakeReference (..), WitVKey (..), - hashKey, hashVerKeyVRF) -import Cardano.Ledger.Shelley.Genesis (secondsToNominalDiffTimeMicro) -import Cardano.Ledger.Shelley.LedgerState (PState (..)) -import Cardano.Ledger.Shelley.TxCert (EraTxCert (..), GenesisDelegCert (..), MIRCert (..), - MIRPot (..), MIRTarget (..), ShelleyDelegCert (..), ShelleyEraTxCert (..), - ShelleyTxCert (..)) -import Cardano.Slotting.Slot (EpochNo (..)) +import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) +import Cardano.Ledger.Alonzo.Core (CoinPerWord (..), PParamsUpdate (..), ppPricesL) +import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis) +import Cardano.Ledger.Alonzo.Scripts (CostModels, Prices (..)) +import Cardano.Ledger.Api.Tx.Cert + ( pattern AuthCommitteeHotKeyTxCert + , pattern DelegStakeTxCert + , pattern DelegTxCert + , pattern GenesisDelegTxCert + , pattern MirTxCert + , pattern RegDRepTxCert + , pattern RegDepositDelegTxCert + , pattern RegDepositTxCert + , pattern RegPoolTxCert + , pattern RegTxCert + , pattern ResignCommitteeColdTxCert + , pattern RetirePoolTxCert + , pattern UnRegDRepTxCert + , pattern UnRegDepositTxCert + , pattern UnRegTxCert + ) +import Cardano.Ledger.Babbage.Core (CoinPerByte (..)) +import Cardano.Ledger.BaseTypes + ( AnchorData (..) + , DnsName + , EpochInterval (..) + , Network (..) + , NonNegativeInterval + , ProtVer (..) + , StrictMaybe (..) + , UnitInterval + , Url + , boundRational + , dnsToText + , hashAnchorData + , maybeToStrictMaybe + , mkVersion + , portToWord16 + , strictMaybeToMaybe + , textToDns + , textToUrl + , unboundRational + , urlToText + ) +import Cardano.Ledger.Binary + ( Annotated (..) + , ByteSpan (..) + , byronProtVer + , fromCBOR + , serialize' + , slice + , toCBOR + , toPlainDecoder + ) +import Cardano.Ledger.Binary.Plain (Decoder) +import Cardano.Ledger.CertState (DRepState (..), csCommitteeCredsL) +import Cardano.Ledger.Coin (Coin (..), addDeltaCoin, toDeltaCoin) +import Cardano.Ledger.Conway.Core + ( DRepVotingThresholds (..) + , PoolVotingThresholds (..) + , dvtPPEconomicGroupL + , dvtPPGovGroupL + , dvtPPNetworkGroupL + , dvtPPTechnicalGroupL + , dvtUpdateToConstitutionL + ) +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.Governance + ( Anchor (..) + , GovActionId (..) + , GovState + , ProposalProcedure (..) + , Vote (..) + , Voter (..) + , VotingProcedure (..) + , VotingProcedures (..) + ) +import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..)) +import Cardano.Ledger.Conway.TxCert + ( ConwayDelegCert (..) + , ConwayEraTxCert (..) + , ConwayGovCert (..) + , ConwayTxCert (..) + , Delegatee (..) + , pattern UpdateDRepTxCert + ) +import Cardano.Ledger.Core + ( Era (..) + , EraPParams (..) + , PParams (..) + , PoolCert (..) + , Value + , fromEraCBOR + , ppMinUTxOValueL + , toEraCBOR + ) +import Cardano.Ledger.Credential (Credential (..), credToText) +import Cardano.Ledger.Crypto (ADDRHASH, Crypto, StandardCrypto) +import Cardano.Ledger.DRep (DRep (..), drepAnchorL, drepDepositL, drepExpiryL) +import Cardano.Ledger.Keys + ( HasKeyRole + , KeyHash (..) + , KeyRole (..) + , VKey (..) + , hashWithSerialiser + ) +import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..)) +import Cardano.Ledger.SafeHash (SafeHash, extractHash, unsafeMakeSafeHash) +import Cardano.Ledger.Shelley.API + ( GenDelegPair (..) + , StakeReference (..) + , WitVKey (..) + , hashKey + , hashVerKeyVRF + ) +import Cardano.Ledger.Shelley.Genesis (secondsToNominalDiffTimeMicro) +import Cardano.Ledger.Shelley.LedgerState (PState (..)) +import Cardano.Ledger.Shelley.TxCert + ( EraTxCert (..) + , GenesisDelegCert (..) + , MIRCert (..) + , MIRPot (..) + , MIRTarget (..) + , ShelleyDelegCert (..) + , ShelleyEraTxCert (..) + , ShelleyTxCert (..) + ) +import Cardano.Slotting.Slot (EpochNo (..)) diff --git a/cardano-api/internal/Cardano/Api/ReexposeNetwork.hs b/cardano-api/internal/Cardano/Api/ReexposeNetwork.hs index 140071c917..6ef494d742 100644 --- a/cardano-api/internal/Cardano/Api/ReexposeNetwork.hs +++ b/cardano-api/internal/Cardano/Api/ReexposeNetwork.hs @@ -1,4 +1,3 @@ -module Cardano.Api.ReexposeNetwork - (Target(..)) where +module Cardano.Api.ReexposeNetwork (Target (..)) where -import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) diff --git a/cardano-api/internal/Cardano/Api/Rewards.hs b/cardano-api/internal/Cardano/Api/Rewards.hs index b9c75979bd..9fe2cc4128 100644 --- a/cardano-api/internal/Cardano/Api/Rewards.hs +++ b/cardano-api/internal/Cardano/Api/Rewards.hs @@ -1,17 +1,16 @@ module Cardano.Api.Rewards - ( DelegationsAndRewards(..) + ( DelegationsAndRewards (..) , mergeDelegsAndRewards - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate + ) +where +import Cardano.Api.Address +import Cardano.Api.Certificate import qualified Cardano.Ledger.Coin as L - -import Data.Aeson as Aeson +import Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.List (nub) -import Data.Map.Strict (Map) +import Data.List (nub) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Vector as Vector @@ -20,53 +19,56 @@ import qualified Data.Vector as Vector -- TODO: Move to cardano-api newtype DelegationsAndRewards = DelegationsAndRewards (Map StakeAddress L.Coin, Map StakeAddress PoolId) - deriving (Eq, Show) - + deriving (Eq, Show) instance ToJSON DelegationsAndRewards where toJSON delegsAndRwds = - Aeson.Array . Vector.fromList - . map delegAndRwdToJson $ mergeDelegsAndRewards delegsAndRwds - where - delegAndRwdToJson :: (StakeAddress, Maybe L.Coin, Maybe PoolId) -> Aeson.Value - delegAndRwdToJson (addr, mRewards, mPoolId) = - Aeson.object - [ "address" .= addr - , "delegation" .= mPoolId - , "rewardAccountBalance" .= mRewards - ] + Aeson.Array + . Vector.fromList + . map delegAndRwdToJson + $ mergeDelegsAndRewards delegsAndRwds + where + delegAndRwdToJson :: (StakeAddress, Maybe L.Coin, Maybe PoolId) -> Aeson.Value + delegAndRwdToJson (addr, mRewards, mPoolId) = + Aeson.object + [ "address" .= addr + , "delegation" .= mPoolId + , "rewardAccountBalance" .= mRewards + ] instance FromJSON DelegationsAndRewards where parseJSON = withArray "DelegationsAndRewards" $ \arr -> do let vals = Vector.toList arr decoded <- mapM decodeObject vals pure $ zipper decoded - where - zipper :: [(StakeAddress, Maybe L.Coin, Maybe PoolId)] - -> DelegationsAndRewards - zipper l = do - let maps = [ ( maybe mempty (Map.singleton sa) delegAmt - , maybe mempty (Map.singleton sa) mPool - ) - | (sa, delegAmt, mPool) <- l - ] - DelegationsAndRewards - $ foldl - (\(amtA, delegA) (amtB, delegB) -> (amtA <> amtB, delegA <> delegB)) - (mempty, mempty) - maps - - decodeObject :: Aeson.Value - -> Aeson.Parser (StakeAddress, Maybe L.Coin, Maybe PoolId) - decodeObject = withObject "DelegationsAndRewards" $ \o -> do - address <- o .: "address" - delegation <- o .:? "delegation" - rewardAccountBalance <- o .:? "rewardAccountBalance" - pure (address, rewardAccountBalance, delegation) + where + zipper + :: [(StakeAddress, Maybe L.Coin, Maybe PoolId)] + -> DelegationsAndRewards + zipper l = do + let maps = + [ ( maybe mempty (Map.singleton sa) delegAmt + , maybe mempty (Map.singleton sa) mPool + ) + | (sa, delegAmt, mPool) <- l + ] + DelegationsAndRewards $ + foldl + (\(amtA, delegA) (amtB, delegB) -> (amtA <> amtB, delegA <> delegB)) + (mempty, mempty) + maps + decodeObject + :: Aeson.Value + -> Aeson.Parser (StakeAddress, Maybe L.Coin, Maybe PoolId) + decodeObject = withObject "DelegationsAndRewards" $ \o -> do + address <- o .: "address" + delegation <- o .:? "delegation" + rewardAccountBalance <- o .:? "rewardAccountBalance" + pure (address, rewardAccountBalance, delegation) mergeDelegsAndRewards :: DelegationsAndRewards -> [(StakeAddress, Maybe L.Coin, Maybe PoolId)] mergeDelegsAndRewards (DelegationsAndRewards (rewardsMap, delegMap)) = - [ (stakeAddr, Map.lookup stakeAddr rewardsMap, Map.lookup stakeAddr delegMap) - | stakeAddr <- nub $ Map.keys rewardsMap ++ Map.keys delegMap - ] + [ (stakeAddr, Map.lookup stakeAddr rewardsMap, Map.lookup stakeAddr delegMap) + | stakeAddr <- nub $ Map.keys rewardsMap ++ Map.keys delegMap + ] diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 64503b23f7..93768dbfc4 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -16,155 +16,156 @@ {- HLINT ignore "Avoid lambda using `infix`" -} {- HLINT ignore "Use section" -} -module Cardano.Api.Script ( - -- * Languages - SimpleScript', - PlutusScriptV1, - PlutusScriptV2, - PlutusScriptV3, - ScriptLanguage(..), - PlutusScriptVersion(..), - AnyScriptLanguage(..), - AnyPlutusScriptVersion(..), - IsPlutusScriptLanguage(..), - IsScriptLanguage(..), +module Cardano.Api.Script + ( -- * Languages + SimpleScript' + , PlutusScriptV1 + , PlutusScriptV2 + , PlutusScriptV3 + , ScriptLanguage (..) + , PlutusScriptVersion (..) + , AnyScriptLanguage (..) + , AnyPlutusScriptVersion (..) + , IsPlutusScriptLanguage (..) + , IsScriptLanguage (..) -- * Scripts in a specific language - Script(..), + , Script (..) -- * Scripts in any language - ScriptInAnyLang(..), - toScriptInAnyLang, + , ScriptInAnyLang (..) + , toScriptInAnyLang -- * Scripts in an era - ScriptInEra(..), - toScriptInEra, - eraOfScriptInEra, + , ScriptInEra (..) + , toScriptInEra + , eraOfScriptInEra -- * Reference scripts - ReferenceScript(..), - refScriptToShelleyScript, + , ReferenceScript (..) + , refScriptToShelleyScript -- * Use of a script in an era as a witness - WitCtxTxIn, WitCtxMint, WitCtxStake, - WitCtx(..), - ScriptWitness(..), - Witness(..), - KeyWitnessInCtx(..), - ScriptWitnessInCtx(..), - IsScriptWitnessInCtx(..), - ScriptDatum(..), - ScriptRedeemer, - scriptWitnessScript, + , WitCtxTxIn + , WitCtxMint + , WitCtxStake + , WitCtx (..) + , ScriptWitness (..) + , Witness (..) + , KeyWitnessInCtx (..) + , ScriptWitnessInCtx (..) + , IsScriptWitnessInCtx (..) + , ScriptDatum (..) + , ScriptRedeemer + , scriptWitnessScript -- ** Languages supported in each era - ScriptLanguageInEra(..), - scriptLanguageSupportedInEra, - languageOfScriptLanguageInEra, - eraOfScriptLanguageInEra, + , ScriptLanguageInEra (..) + , scriptLanguageSupportedInEra + , languageOfScriptLanguageInEra + , eraOfScriptLanguageInEra -- * The simple script language - SimpleScript(..), - SimpleScriptOrReferenceInput(..), + , SimpleScript (..) + , SimpleScriptOrReferenceInput (..) -- * The Plutus script language - PlutusScript(..), - PlutusScriptOrReferenceInput(..), - examplePlutusScriptAlwaysSucceeds, - examplePlutusScriptAlwaysFails, + , PlutusScript (..) + , PlutusScriptOrReferenceInput (..) + , examplePlutusScriptAlwaysSucceeds + , examplePlutusScriptAlwaysFails -- * Script data - ScriptData(..), + , ScriptData (..) -- * Script execution units - ExecutionUnits(..), + , ExecutionUnits (..) -- * Script hashes - ScriptHash(..), - hashScript, + , ScriptHash (..) + , hashScript -- * Internal conversion functions - toShelleyScript, - fromShelleyBasedScript, - toShelleyMultiSig, - fromShelleyMultiSig, - toAllegraTimelock, - fromAllegraTimelock, - toAlonzoExUnits, - fromAlonzoExUnits, - toShelleyScriptHash, - fromShelleyScriptHash, - toPlutusData, - fromPlutusData, - toAlonzoData, - fromAlonzoData, - toAlonzoLanguage, - fromAlonzoLanguage, - fromShelleyScriptToReferenceScript, - scriptInEraToRefScript, + , toShelleyScript + , fromShelleyBasedScript + , toShelleyMultiSig + , fromShelleyMultiSig + , toAllegraTimelock + , fromAllegraTimelock + , toAlonzoExUnits + , fromAlonzoExUnits + , toShelleyScriptHash + , fromShelleyScriptHash + , toPlutusData + , fromPlutusData + , toAlonzoData + , fromAlonzoData + , toAlonzoLanguage + , fromAlonzoLanguage + , fromShelleyScriptToReferenceScript + , scriptInEraToRefScript -- * Data family instances - AsType(..), - Hash(..), - ) where - -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core -import Cardano.Api.Error -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Shelley -import Cardano.Api.ScriptData -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Api.TxIn -import Cardano.Api.Utils (failEitherWith) - + , AsType (..) + , Hash (..) + ) +where + +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Shelley +import Cardano.Api.ScriptData +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Api.TxIn +import Cardano.Api.Utils (failEitherWith) import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Ledger.Allegra.Scripts as Allegra import qualified Cardano.Ledger.Allegra.Scripts as Timelock import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Babbage.Scripts as Babbage -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator) import qualified Cardano.Ledger.Conway.Scripts as Conway -import Cardano.Ledger.Core (Era (EraCrypto)) +import Cardano.Ledger.Core (Era (EraCrypto)) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.Plutus.Language as Plutus import qualified Cardano.Ledger.Shelley.Scripts as Shelley -import Cardano.Slotting.Slot (SlotNo) -import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) -import qualified PlutusLedgerApi.Test.Examples as Plutus - -import Control.Applicative -import Control.Monad -import Data.Aeson (Value (..), object, (.:), (.=)) +import Cardano.Slotting.Slot (SlotNo) +import Control.Applicative +import Control.Monad +import Data.Aeson (Value (..), object, (.:), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Short (ShortByteString) +import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as SBS -import Data.Either.Combinators (maybeToRight) -import Data.Foldable (toList) -import Data.Functor -import Data.Scientific (toBoundedInteger) +import Data.Either.Combinators (maybeToRight) +import Data.Foldable (toList) +import Data.Functor +import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq -import Data.String (IsString) -import Data.Text (Text) +import Data.String (IsString) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) -import Data.Typeable (Typeable) -import Data.Vector (Vector) +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Typeable (Typeable) +import Data.Vector (Vector) import qualified Data.Vector as Vector -import Numeric.Natural (Natural) +import Numeric.Natural (Natural) +import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) +import qualified PlutusLedgerApi.Test.Examples as Plutus -- ---------------------------------------------------------------------------- -- Types for script language and version @@ -180,7 +181,6 @@ data SimpleScript' -- * m-of-n combinator -- -- This version of the language was introduced in the 'ShelleyEra'. --- -- | The second version of the simple script language. It has all the features -- of the original simple script language plus new atomic predicates: @@ -196,136 +196,134 @@ data SimpleScript' -- | Place holder type to show what the pattern is to extend to multiple -- languages, not just multiple versions of a single language. --- data PlutusScriptV1 + data PlutusScriptV2 + data PlutusScriptV3 instance HasTypeProxy SimpleScript' where - data AsType SimpleScript' = AsSimpleScript - proxyToAsType _ = AsSimpleScript + data AsType SimpleScript' = AsSimpleScript + proxyToAsType _ = AsSimpleScript instance HasTypeProxy PlutusScriptV1 where - data AsType PlutusScriptV1 = AsPlutusScriptV1 - proxyToAsType :: Proxy PlutusScriptV1 -> AsType PlutusScriptV1 - proxyToAsType _ = AsPlutusScriptV1 + data AsType PlutusScriptV1 = AsPlutusScriptV1 + proxyToAsType :: Proxy PlutusScriptV1 -> AsType PlutusScriptV1 + proxyToAsType _ = AsPlutusScriptV1 instance HasTypeProxy PlutusScriptV2 where - data AsType PlutusScriptV2 = AsPlutusScriptV2 - proxyToAsType _ = AsPlutusScriptV2 + data AsType PlutusScriptV2 = AsPlutusScriptV2 + proxyToAsType _ = AsPlutusScriptV2 instance HasTypeProxy PlutusScriptV3 where - data AsType PlutusScriptV3 = AsPlutusScriptV3 - proxyToAsType _ = AsPlutusScriptV3 + data AsType PlutusScriptV3 = AsPlutusScriptV3 + proxyToAsType _ = AsPlutusScriptV3 -- ---------------------------------------------------------------------------- -- Value level representation for script languages -- data ScriptLanguage lang where + SimpleScriptLanguage :: ScriptLanguage SimpleScript' + PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang - SimpleScriptLanguage :: ScriptLanguage SimpleScript' +deriving instance (Eq (ScriptLanguage lang)) - PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang - -deriving instance (Eq (ScriptLanguage lang)) deriving instance (Show (ScriptLanguage lang)) instance TestEquality ScriptLanguage where - testEquality SimpleScriptLanguage SimpleScriptLanguage = Just Refl - - testEquality (PlutusScriptLanguage lang) - (PlutusScriptLanguage lang') = testEquality lang lang' - - testEquality _ _ = Nothing - + testEquality SimpleScriptLanguage SimpleScriptLanguage = Just Refl + testEquality + (PlutusScriptLanguage lang) + (PlutusScriptLanguage lang') = testEquality lang lang' + testEquality _ _ = Nothing data PlutusScriptVersion lang where - PlutusScriptV1 :: PlutusScriptVersion PlutusScriptV1 - PlutusScriptV2 :: PlutusScriptVersion PlutusScriptV2 - PlutusScriptV3 :: PlutusScriptVersion PlutusScriptV3 + PlutusScriptV1 :: PlutusScriptVersion PlutusScriptV1 + PlutusScriptV2 :: PlutusScriptVersion PlutusScriptV2 + PlutusScriptV3 :: PlutusScriptVersion PlutusScriptV3 + +deriving instance (Eq (PlutusScriptVersion lang)) -deriving instance (Eq (PlutusScriptVersion lang)) deriving instance (Show (PlutusScriptVersion lang)) instance TestEquality PlutusScriptVersion where - testEquality PlutusScriptV1 PlutusScriptV1 = Just Refl - testEquality PlutusScriptV2 PlutusScriptV2 = Just Refl - testEquality PlutusScriptV3 PlutusScriptV3 = Just Refl - testEquality _ _ = Nothing - + testEquality PlutusScriptV1 PlutusScriptV1 = Just Refl + testEquality PlutusScriptV2 PlutusScriptV2 = Just Refl + testEquality PlutusScriptV3 PlutusScriptV3 = Just Refl + testEquality _ _ = Nothing data AnyScriptLanguage where - AnyScriptLanguage :: ScriptLanguage lang -> AnyScriptLanguage + AnyScriptLanguage :: ScriptLanguage lang -> AnyScriptLanguage deriving instance (Show AnyScriptLanguage) instance Eq AnyScriptLanguage where - a == b = fromEnum a == fromEnum b + a == b = fromEnum a == fromEnum b instance Ord AnyScriptLanguage where - compare a b = compare (fromEnum a) (fromEnum b) + compare a b = compare (fromEnum a) (fromEnum b) instance Enum AnyScriptLanguage where - toEnum 0 = AnyScriptLanguage SimpleScriptLanguage - toEnum 1 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1) - toEnum 2 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2) - toEnum 3 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3) - toEnum err = error $ "AnyScriptLanguage.toEnum: bad argument: " <> show err + toEnum 0 = AnyScriptLanguage SimpleScriptLanguage + toEnum 1 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1) + toEnum 2 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2) + toEnum 3 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3) + toEnum err = error $ "AnyScriptLanguage.toEnum: bad argument: " <> show err - fromEnum (AnyScriptLanguage SimpleScriptLanguage) = 0 - fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1)) = 1 - fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2)) = 2 - fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)) = 3 + fromEnum (AnyScriptLanguage SimpleScriptLanguage) = 0 + fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1)) = 1 + fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2)) = 2 + fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)) = 3 instance Bounded AnyScriptLanguage where - minBound = AnyScriptLanguage SimpleScriptLanguage - maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3) - + minBound = AnyScriptLanguage SimpleScriptLanguage + maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3) data AnyPlutusScriptVersion where - AnyPlutusScriptVersion :: PlutusScriptVersion lang - -> AnyPlutusScriptVersion + AnyPlutusScriptVersion + :: PlutusScriptVersion lang + -> AnyPlutusScriptVersion deriving instance (Show AnyPlutusScriptVersion) instance Eq AnyPlutusScriptVersion where - a == b = fromEnum a == fromEnum b + a == b = fromEnum a == fromEnum b instance Ord AnyPlutusScriptVersion where - compare a b = compare (fromEnum a) (fromEnum b) + compare a b = compare (fromEnum a) (fromEnum b) instance Enum AnyPlutusScriptVersion where - toEnum 0 = AnyPlutusScriptVersion PlutusScriptV1 - toEnum 1 = AnyPlutusScriptVersion PlutusScriptV2 - toEnum 2 = AnyPlutusScriptVersion PlutusScriptV3 - toEnum err = error $ "AnyPlutusScriptVersion.toEnum: bad argument: " <> show err + toEnum 0 = AnyPlutusScriptVersion PlutusScriptV1 + toEnum 1 = AnyPlutusScriptVersion PlutusScriptV2 + toEnum 2 = AnyPlutusScriptVersion PlutusScriptV3 + toEnum err = error $ "AnyPlutusScriptVersion.toEnum: bad argument: " <> show err - fromEnum (AnyPlutusScriptVersion PlutusScriptV1) = 0 - fromEnum (AnyPlutusScriptVersion PlutusScriptV2) = 1 - fromEnum (AnyPlutusScriptVersion PlutusScriptV3) = 2 + fromEnum (AnyPlutusScriptVersion PlutusScriptV1) = 0 + fromEnum (AnyPlutusScriptVersion PlutusScriptV2) = 1 + fromEnum (AnyPlutusScriptVersion PlutusScriptV3) = 2 instance Bounded AnyPlutusScriptVersion where - minBound = AnyPlutusScriptVersion PlutusScriptV1 - maxBound = AnyPlutusScriptVersion PlutusScriptV3 + minBound = AnyPlutusScriptVersion PlutusScriptV1 + maxBound = AnyPlutusScriptVersion PlutusScriptV3 instance ToCBOR AnyPlutusScriptVersion where - toCBOR = toCBOR . fromEnum + toCBOR = toCBOR . fromEnum instance FromCBOR AnyPlutusScriptVersion where - fromCBOR = do - n <- fromCBOR - if n >= fromEnum (minBound :: AnyPlutusScriptVersion) && - n <= fromEnum (maxBound :: AnyPlutusScriptVersion) - then return $! toEnum n - else fail "plutus script version out of bounds" + fromCBOR = do + n <- fromCBOR + if n >= fromEnum (minBound :: AnyPlutusScriptVersion) + && n <= fromEnum (maxBound :: AnyPlutusScriptVersion) + then return $! toEnum n + else fail "plutus script version out of bounds" instance ToJSON AnyPlutusScriptVersion where - toJSON (AnyPlutusScriptVersion PlutusScriptV1) = - Aeson.String "PlutusScriptV1" - toJSON (AnyPlutusScriptVersion PlutusScriptV2) = - Aeson.String "PlutusScriptV2" - toJSON (AnyPlutusScriptVersion PlutusScriptV3) = - Aeson.String "PlutusScriptV3" + toJSON (AnyPlutusScriptVersion PlutusScriptV1) = + Aeson.String "PlutusScriptV1" + toJSON (AnyPlutusScriptVersion PlutusScriptV2) = + Aeson.String "PlutusScriptV2" + toJSON (AnyPlutusScriptVersion PlutusScriptV3) = + Aeson.String "PlutusScriptV3" parsePlutusScriptVersion :: Text -> Aeson.Parser AnyPlutusScriptVersion parsePlutusScriptVersion t = @@ -333,21 +331,21 @@ parsePlutusScriptVersion t = "PlutusScriptV1" -> return (AnyPlutusScriptVersion PlutusScriptV1) "PlutusScriptV2" -> return (AnyPlutusScriptVersion PlutusScriptV2) "PlutusScriptV3" -> return (AnyPlutusScriptVersion PlutusScriptV3) - _ -> fail "Expected PlutusScriptVX, for X = 1, 2, or 3" + _ -> fail "Expected PlutusScriptVX, for X = 1, 2, or 3" instance FromJSON AnyPlutusScriptVersion where - parseJSON = Aeson.withText "PlutusScriptVersion" parsePlutusScriptVersion + parseJSON = Aeson.withText "PlutusScriptVersion" parsePlutusScriptVersion instance Aeson.FromJSONKey AnyPlutusScriptVersion where - fromJSONKey = Aeson.FromJSONKeyTextParser parsePlutusScriptVersion + fromJSONKey = Aeson.FromJSONKeyTextParser parsePlutusScriptVersion instance Aeson.ToJSONKey AnyPlutusScriptVersion where - toJSONKey = Aeson.toJSONKeyText toText - where - toText :: AnyPlutusScriptVersion -> Text - toText (AnyPlutusScriptVersion PlutusScriptV1) = "PlutusScriptV1" - toText (AnyPlutusScriptVersion PlutusScriptV2) = "PlutusScriptV2" - toText (AnyPlutusScriptVersion PlutusScriptV3) = "PlutusScriptV3" + toJSONKey = Aeson.toJSONKeyText toText + where + toText :: AnyPlutusScriptVersion -> Text + toText (AnyPlutusScriptVersion PlutusScriptV1) = "PlutusScriptV1" + toText (AnyPlutusScriptVersion PlutusScriptV2) = "PlutusScriptV2" + toText (AnyPlutusScriptVersion PlutusScriptV3) = "PlutusScriptV3" toAlonzoLanguage :: AnyPlutusScriptVersion -> Plutus.Language toAlonzoLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1 @@ -359,33 +357,32 @@ fromAlonzoLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1 fromAlonzoLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2 fromAlonzoLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3 - class HasTypeProxy lang => IsScriptLanguage lang where - scriptLanguage :: ScriptLanguage lang + scriptLanguage :: ScriptLanguage lang instance IsScriptLanguage SimpleScript' where - scriptLanguage = SimpleScriptLanguage + scriptLanguage = SimpleScriptLanguage instance IsScriptLanguage PlutusScriptV1 where - scriptLanguage = PlutusScriptLanguage PlutusScriptV1 + scriptLanguage = PlutusScriptLanguage PlutusScriptV1 instance IsScriptLanguage PlutusScriptV2 where - scriptLanguage = PlutusScriptLanguage PlutusScriptV2 + scriptLanguage = PlutusScriptLanguage PlutusScriptV2 instance IsScriptLanguage PlutusScriptV3 where - scriptLanguage = PlutusScriptLanguage PlutusScriptV3 + scriptLanguage = PlutusScriptLanguage PlutusScriptV3 class IsScriptLanguage lang => IsPlutusScriptLanguage lang where - plutusScriptVersion :: PlutusScriptVersion lang + plutusScriptVersion :: PlutusScriptVersion lang instance IsPlutusScriptLanguage PlutusScriptV1 where - plutusScriptVersion = PlutusScriptV1 + plutusScriptVersion = PlutusScriptV1 instance IsPlutusScriptLanguage PlutusScriptV2 where - plutusScriptVersion = PlutusScriptV2 + plutusScriptVersion = PlutusScriptV2 instance IsPlutusScriptLanguage PlutusScriptV3 where - plutusScriptVersion = PlutusScriptV3 + plutusScriptVersion = PlutusScriptV3 -- ---------------------------------------------------------------------------- -- Script type: covering all script languages @@ -401,63 +398,56 @@ instance IsPlutusScriptLanguage PlutusScriptV3 where -- Note that some but not all scripts have an external JSON syntax, hence this -- type has no JSON serialisation instances. The 'SimpleScript' family of -- languages do have a JSON syntax and thus have 'ToJSON'\/'FromJSON' instances. --- data Script lang where + SimpleScript + :: !SimpleScript + -> Script SimpleScript' + PlutusScript + :: !(PlutusScriptVersion lang) + -> !(PlutusScript lang) + -> Script lang - SimpleScript :: !SimpleScript - -> Script SimpleScript' +deriving instance (Eq (Script lang)) - PlutusScript :: !(PlutusScriptVersion lang) - -> !(PlutusScript lang) - -> Script lang - -deriving instance (Eq (Script lang)) deriving instance (Show (Script lang)) instance HasTypeProxy lang => HasTypeProxy (Script lang) where - data AsType (Script lang) = AsScript (AsType lang) - proxyToAsType _ = AsScript (proxyToAsType (Proxy :: Proxy lang)) + data AsType (Script lang) = AsScript (AsType lang) + proxyToAsType _ = AsScript (proxyToAsType (Proxy :: Proxy lang)) instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where - serialiseToCBOR (SimpleScript s) = - CBOR.serialize' (toAllegraTimelock s :: Timelock.Timelock (ShelleyLedgerEra AllegraEra)) - - serialiseToCBOR (PlutusScript PlutusScriptV1 s) = - CBOR.serialize' s - - serialiseToCBOR (PlutusScript PlutusScriptV2 s) = - CBOR.serialize' s - - serialiseToCBOR (PlutusScript PlutusScriptV3 s) = - CBOR.serialize' s - - deserialiseFromCBOR _ bs = - case scriptLanguage :: ScriptLanguage lang of - SimpleScriptLanguage -> - let version = Ledger.eraProtVerLow @(ShelleyLedgerEra AllegraEra) - in SimpleScript . fromAllegraTimelock @(ShelleyLedgerEra AllegraEra) - <$> Binary.decodeFullAnnotator version "Script" Binary.decCBOR (LBS.fromStrict bs) - - PlutusScriptLanguage PlutusScriptV1 -> - PlutusScript PlutusScriptV1 + serialiseToCBOR (SimpleScript s) = + CBOR.serialize' (toAllegraTimelock s :: Timelock.Timelock (ShelleyLedgerEra AllegraEra)) + serialiseToCBOR (PlutusScript PlutusScriptV1 s) = + CBOR.serialize' s + serialiseToCBOR (PlutusScript PlutusScriptV2 s) = + CBOR.serialize' s + serialiseToCBOR (PlutusScript PlutusScriptV3 s) = + CBOR.serialize' s + + deserialiseFromCBOR _ bs = + case scriptLanguage :: ScriptLanguage lang of + SimpleScriptLanguage -> + let version = Ledger.eraProtVerLow @(ShelleyLedgerEra AllegraEra) + in SimpleScript . fromAllegraTimelock @(ShelleyLedgerEra AllegraEra) + <$> Binary.decodeFullAnnotator version "Script" Binary.decCBOR (LBS.fromStrict bs) + PlutusScriptLanguage PlutusScriptV1 -> + PlutusScript PlutusScriptV1 <$> CBOR.decodeFull' bs - - PlutusScriptLanguage PlutusScriptV2 -> - PlutusScript PlutusScriptV2 + PlutusScriptLanguage PlutusScriptV2 -> + PlutusScript PlutusScriptV2 <$> CBOR.decodeFull' bs - - PlutusScriptLanguage PlutusScriptV3 -> - PlutusScript PlutusScriptV3 + PlutusScriptLanguage PlutusScriptV3 -> + PlutusScript PlutusScriptV3 <$> CBOR.decodeFull' bs instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where - textEnvelopeType _ = - case scriptLanguage :: ScriptLanguage lang of - SimpleScriptLanguage -> "SimpleScript" - PlutusScriptLanguage PlutusScriptV1 -> "PlutusScriptV1" - PlutusScriptLanguage PlutusScriptV2 -> "PlutusScriptV2" - PlutusScriptLanguage PlutusScriptV3 -> "PlutusScriptV3" - + textEnvelopeType _ = + case scriptLanguage :: ScriptLanguage lang of + SimpleScriptLanguage -> "SimpleScript" + PlutusScriptLanguage PlutusScriptV1 -> "PlutusScriptV1" + PlutusScriptLanguage PlutusScriptV2 -> "PlutusScriptV2" + PlutusScriptLanguage PlutusScriptV3 -> "PlutusScriptV3" -- ---------------------------------------------------------------------------- -- Scripts in any language @@ -468,37 +458,41 @@ instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where -- input, or before the era context is known. -- -- Use 'toScriptInEra' to convert to a script in the context of an era. --- data ScriptInAnyLang where - ScriptInAnyLang :: ScriptLanguage lang - -> Script lang - -> ScriptInAnyLang + ScriptInAnyLang + :: ScriptLanguage lang + -> Script lang + -> ScriptInAnyLang deriving instance Show ScriptInAnyLang -- The GADT in the ScriptInAnyLang constructor requires a custom Eq instance instance Eq ScriptInAnyLang where - (==) (ScriptInAnyLang lang script) - (ScriptInAnyLang lang' script') = + (==) + (ScriptInAnyLang lang script) + (ScriptInAnyLang lang' script') = case testEquality lang lang' of - Nothing -> False + Nothing -> False Just Refl -> script == script' instance ToJSON ScriptInAnyLang where toJSON (ScriptInAnyLang l s) = - object [ "scriptLanguage" .= show l - , "script" .= obtainScriptLangConstraint l - (serialiseToTextEnvelope Nothing s) - ] - where - obtainScriptLangConstraint - :: ScriptLanguage lang - -> (IsScriptLanguage lang => a) - -> a - obtainScriptLangConstraint SimpleScriptLanguage f = f - obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV1) f = f - obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV2) f = f - obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV3) f = f + object + [ "scriptLanguage" .= show l + , "script" + .= obtainScriptLangConstraint + l + (serialiseToTextEnvelope Nothing s) + ] + where + obtainScriptLangConstraint + :: ScriptLanguage lang + -> (IsScriptLanguage lang => a) + -> a + obtainScriptLangConstraint SimpleScriptLanguage f = f + obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV1) f = f + obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV2) f = f + obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV3) f = f instance FromJSON ScriptInAnyLang where parseJSON = Aeson.withObject "ScriptInAnyLang" $ \o -> do @@ -512,164 +506,140 @@ instance FromJSON ScriptInAnyLang where -- -- No inverse to this is provided, just do case analysis on the 'ScriptLanguage' -- field within the 'ScriptInAnyLang' constructor. --- toScriptInAnyLang :: Script lang -> ScriptInAnyLang toScriptInAnyLang s@(SimpleScript _) = - ScriptInAnyLang SimpleScriptLanguage s + ScriptInAnyLang SimpleScriptLanguage s toScriptInAnyLang s@(PlutusScript v _) = - ScriptInAnyLang (PlutusScriptLanguage v) s + ScriptInAnyLang (PlutusScriptLanguage v) s instance HasTypeProxy ScriptInAnyLang where - data AsType ScriptInAnyLang = AsScriptInAnyLang - proxyToAsType _ = AsScriptInAnyLang - + data AsType ScriptInAnyLang = AsScriptInAnyLang + proxyToAsType _ = AsScriptInAnyLang -- ---------------------------------------------------------------------------- -- Scripts in the context of a ledger era -- data ScriptInEra era where - ScriptInEra :: ScriptLanguageInEra lang era - -> Script lang - -> ScriptInEra era + ScriptInEra + :: ScriptLanguageInEra lang era + -> Script lang + -> ScriptInEra era deriving instance Show (ScriptInEra era) -- The GADT in the ScriptInEra constructor requires a custom instance instance Eq (ScriptInEra era) where - (==) (ScriptInEra langInEra script) - (ScriptInEra langInEra' script') = - case testEquality (languageOfScriptLanguageInEra langInEra) - (languageOfScriptLanguageInEra langInEra') of - Nothing -> False + (==) + (ScriptInEra langInEra script) + (ScriptInEra langInEra' script') = + case testEquality + (languageOfScriptLanguageInEra langInEra) + (languageOfScriptLanguageInEra langInEra') of + Nothing -> False Just Refl -> script == script' - data ScriptLanguageInEra lang era where + SimpleScriptInShelley :: ScriptLanguageInEra SimpleScript' ShelleyEra + SimpleScriptInAllegra :: ScriptLanguageInEra SimpleScript' AllegraEra + SimpleScriptInMary :: ScriptLanguageInEra SimpleScript' MaryEra + SimpleScriptInAlonzo :: ScriptLanguageInEra SimpleScript' AlonzoEra + SimpleScriptInBabbage :: ScriptLanguageInEra SimpleScript' BabbageEra + SimpleScriptInConway :: ScriptLanguageInEra SimpleScript' ConwayEra + PlutusScriptV1InAlonzo :: ScriptLanguageInEra PlutusScriptV1 AlonzoEra + PlutusScriptV1InBabbage :: ScriptLanguageInEra PlutusScriptV1 BabbageEra + PlutusScriptV1InConway :: ScriptLanguageInEra PlutusScriptV1 ConwayEra + PlutusScriptV2InBabbage :: ScriptLanguageInEra PlutusScriptV2 BabbageEra + PlutusScriptV2InConway :: ScriptLanguageInEra PlutusScriptV2 ConwayEra + PlutusScriptV3InConway :: ScriptLanguageInEra PlutusScriptV3 ConwayEra + +deriving instance Eq (ScriptLanguageInEra lang era) - SimpleScriptInShelley :: ScriptLanguageInEra SimpleScript' ShelleyEra - SimpleScriptInAllegra :: ScriptLanguageInEra SimpleScript' AllegraEra - SimpleScriptInMary :: ScriptLanguageInEra SimpleScript' MaryEra - SimpleScriptInAlonzo :: ScriptLanguageInEra SimpleScript' AlonzoEra - SimpleScriptInBabbage :: ScriptLanguageInEra SimpleScript' BabbageEra - SimpleScriptInConway :: ScriptLanguageInEra SimpleScript' ConwayEra - - PlutusScriptV1InAlonzo :: ScriptLanguageInEra PlutusScriptV1 AlonzoEra - PlutusScriptV1InBabbage :: ScriptLanguageInEra PlutusScriptV1 BabbageEra - PlutusScriptV1InConway :: ScriptLanguageInEra PlutusScriptV1 ConwayEra - - PlutusScriptV2InBabbage :: ScriptLanguageInEra PlutusScriptV2 BabbageEra - PlutusScriptV2InConway :: ScriptLanguageInEra PlutusScriptV2 ConwayEra - - PlutusScriptV3InConway :: ScriptLanguageInEra PlutusScriptV3 ConwayEra - - - -deriving instance Eq (ScriptLanguageInEra lang era) deriving instance Show (ScriptLanguageInEra lang era) instance ToJSON (ScriptLanguageInEra lang era) where toJSON sLangInEra = Aeson.String . Text.pack $ show sLangInEra - instance HasTypeProxy era => HasTypeProxy (ScriptInEra era) where - data AsType (ScriptInEra era) = AsScriptInEra (AsType era) - proxyToAsType _ = AsScriptInEra (proxyToAsType (Proxy :: Proxy era)) - + data AsType (ScriptInEra era) = AsScriptInEra (AsType era) + proxyToAsType _ = AsScriptInEra (proxyToAsType (Proxy :: Proxy era)) -- | Check if a given script language is supported in a given era, and if so -- return the evidence. --- -scriptLanguageSupportedInEra :: ShelleyBasedEra era - -> ScriptLanguage lang - -> Maybe (ScriptLanguageInEra lang era) +scriptLanguageSupportedInEra + :: ShelleyBasedEra era + -> ScriptLanguage lang + -> Maybe (ScriptLanguageInEra lang era) scriptLanguageSupportedInEra era lang = - case (era, lang) of - (ShelleyBasedEraShelley, SimpleScriptLanguage) -> - Just SimpleScriptInShelley - - (ShelleyBasedEraAllegra, SimpleScriptLanguage) -> - Just SimpleScriptInAllegra - - (ShelleyBasedEraMary, SimpleScriptLanguage) -> - Just SimpleScriptInMary - - (ShelleyBasedEraAlonzo, SimpleScriptLanguage) -> - Just SimpleScriptInAlonzo - - (ShelleyBasedEraBabbage, SimpleScriptLanguage) -> - Just SimpleScriptInBabbage - - (ShelleyBasedEraConway, SimpleScriptLanguage) -> - Just SimpleScriptInConway - - (ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) -> - Just PlutusScriptV1InAlonzo - - (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) -> - Just PlutusScriptV1InBabbage - - (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV2) -> - Just PlutusScriptV2InBabbage - - (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV1) -> - Just PlutusScriptV1InConway - - (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV2) -> - Just PlutusScriptV2InConway - - (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV3) -> - Just PlutusScriptV3InConway - - _ -> Nothing - -languageOfScriptLanguageInEra :: ScriptLanguageInEra lang era - -> ScriptLanguage lang + case (era, lang) of + (ShelleyBasedEraShelley, SimpleScriptLanguage) -> + Just SimpleScriptInShelley + (ShelleyBasedEraAllegra, SimpleScriptLanguage) -> + Just SimpleScriptInAllegra + (ShelleyBasedEraMary, SimpleScriptLanguage) -> + Just SimpleScriptInMary + (ShelleyBasedEraAlonzo, SimpleScriptLanguage) -> + Just SimpleScriptInAlonzo + (ShelleyBasedEraBabbage, SimpleScriptLanguage) -> + Just SimpleScriptInBabbage + (ShelleyBasedEraConway, SimpleScriptLanguage) -> + Just SimpleScriptInConway + (ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) -> + Just PlutusScriptV1InAlonzo + (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) -> + Just PlutusScriptV1InBabbage + (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV2) -> + Just PlutusScriptV2InBabbage + (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV1) -> + Just PlutusScriptV1InConway + (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV2) -> + Just PlutusScriptV2InConway + (ShelleyBasedEraConway, PlutusScriptLanguage PlutusScriptV3) -> + Just PlutusScriptV3InConway + _ -> Nothing + +languageOfScriptLanguageInEra + :: ScriptLanguageInEra lang era + -> ScriptLanguage lang languageOfScriptLanguageInEra langInEra = - case langInEra of - SimpleScriptInShelley -> SimpleScriptLanguage - SimpleScriptInAllegra -> SimpleScriptLanguage - SimpleScriptInMary -> SimpleScriptLanguage - SimpleScriptInAlonzo -> SimpleScriptLanguage - SimpleScriptInBabbage -> SimpleScriptLanguage - SimpleScriptInConway -> SimpleScriptLanguage - - PlutusScriptV1InAlonzo -> PlutusScriptLanguage PlutusScriptV1 - PlutusScriptV1InBabbage -> PlutusScriptLanguage PlutusScriptV1 - PlutusScriptV1InConway -> PlutusScriptLanguage PlutusScriptV1 - - PlutusScriptV2InBabbage -> PlutusScriptLanguage PlutusScriptV2 - PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2 - - PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3 - -eraOfScriptLanguageInEra :: ScriptLanguageInEra lang era - -> ShelleyBasedEra era + case langInEra of + SimpleScriptInShelley -> SimpleScriptLanguage + SimpleScriptInAllegra -> SimpleScriptLanguage + SimpleScriptInMary -> SimpleScriptLanguage + SimpleScriptInAlonzo -> SimpleScriptLanguage + SimpleScriptInBabbage -> SimpleScriptLanguage + SimpleScriptInConway -> SimpleScriptLanguage + PlutusScriptV1InAlonzo -> PlutusScriptLanguage PlutusScriptV1 + PlutusScriptV1InBabbage -> PlutusScriptLanguage PlutusScriptV1 + PlutusScriptV1InConway -> PlutusScriptLanguage PlutusScriptV1 + PlutusScriptV2InBabbage -> PlutusScriptLanguage PlutusScriptV2 + PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2 + PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3 + +eraOfScriptLanguageInEra + :: ScriptLanguageInEra lang era + -> ShelleyBasedEra era eraOfScriptLanguageInEra langInEra = - case langInEra of - SimpleScriptInShelley -> ShelleyBasedEraShelley - SimpleScriptInAllegra -> ShelleyBasedEraAllegra - SimpleScriptInMary -> ShelleyBasedEraMary - SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo - SimpleScriptInBabbage -> ShelleyBasedEraBabbage - SimpleScriptInConway -> ShelleyBasedEraConway - - PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo - PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage - PlutusScriptV1InConway -> ShelleyBasedEraConway - - PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage - PlutusScriptV2InConway -> ShelleyBasedEraConway - - PlutusScriptV3InConway -> ShelleyBasedEraConway + case langInEra of + SimpleScriptInShelley -> ShelleyBasedEraShelley + SimpleScriptInAllegra -> ShelleyBasedEraAllegra + SimpleScriptInMary -> ShelleyBasedEraMary + SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo + SimpleScriptInBabbage -> ShelleyBasedEraBabbage + SimpleScriptInConway -> ShelleyBasedEraConway + PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo + PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage + PlutusScriptV1InConway -> ShelleyBasedEraConway + PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage + PlutusScriptV2InConway -> ShelleyBasedEraConway + PlutusScriptV3InConway -> ShelleyBasedEraConway -- | Given a target era and a script in some language, check if the language is -- supported in that era, and if so return a 'ScriptInEra'. --- toScriptInEra :: ShelleyBasedEra era -> ScriptInAnyLang -> Maybe (ScriptInEra era) toScriptInEra era (ScriptInAnyLang lang s) = do - lang' <- scriptLanguageSupportedInEra era lang - return (ScriptInEra lang' s) + lang' <- scriptLanguageSupportedInEra era lang + return (ScriptInEra lang' s) eraOfScriptInEra :: ScriptInEra era -> ShelleyBasedEra era eraOfScriptInEra (ScriptInEra langInEra _) = eraOfScriptLanguageInEra langInEra @@ -681,31 +651,26 @@ eraOfScriptInEra (ScriptInEra langInEra _) = eraOfScriptLanguageInEra langInEra -- | A tag type for the context in which a script is used in a transaction. -- -- This type tags the context as being to witness a transaction input. --- data WitCtxTxIn -- | A tag type for the context in which a script is used in a transaction. -- -- This type tags the context as being to witness minting. --- data WitCtxMint -- | A tag type for the context in which a script is used in a transaction. -- -- This type tags the context as being to witness the use of stake addresses in -- certificates, withdrawals, voting and proposals. --- data WitCtxStake - -- | This GADT provides a value-level representation of all the witness -- contexts. This enables pattern matching on the context to allow them to be -- treated in a non-uniform way. --- data WitCtx witctx where - WitCtxTxIn :: WitCtx WitCtxTxIn - WitCtxMint :: WitCtx WitCtxMint - WitCtxStake :: WitCtx WitCtxStake + WitCtxTxIn :: WitCtx WitCtxTxIn + WitCtxMint :: WitCtx WitCtxMint + WitCtxStake :: WitCtx WitCtxStake -- | Scripts can now exist in the UTxO at a transaction output. We can -- reference these scripts via specification of a reference transaction input @@ -713,14 +678,14 @@ data WitCtx witctx where -- or to mint tokens. This datatype encapsulates this concept. data PlutusScriptOrReferenceInput lang = PScript (PlutusScript lang) - | PReferenceScript + | -- | Needed to construct the redeemer pointer map + -- in the case of minting reference scripts where we don't + -- have direct access to the script + PReferenceScript TxIn - (Maybe ScriptHash) -- ^ Needed to construct the redeemer pointer map - -- in the case of minting reference scripts where we don't - -- have direct access to the script + (Maybe ScriptHash) deriving (Eq, Show) - data SimpleScriptOrReferenceInput lang = SScript SimpleScript | SReferenceScript TxIn (Maybe ScriptHash) @@ -738,56 +703,71 @@ data SimpleScriptOrReferenceInput lang -- contexts. For Plutus scripts, using a script involves supplying a redeemer. -- In addition, Plutus scripts used for spending inputs must also supply the -- datum value used when originally creating the TxOut that is now being spent. --- data ScriptWitness witctx era where - - SimpleScriptWitness :: ScriptLanguageInEra SimpleScript' era - -> SimpleScriptOrReferenceInput SimpleScript' - -> ScriptWitness witctx era - - PlutusScriptWitness :: ScriptLanguageInEra lang era - -> PlutusScriptVersion lang - -> PlutusScriptOrReferenceInput lang - -> ScriptDatum witctx - -> ScriptRedeemer - -> ExecutionUnits - -> ScriptWitness witctx era + SimpleScriptWitness + :: ScriptLanguageInEra SimpleScript' era + -> SimpleScriptOrReferenceInput SimpleScript' + -> ScriptWitness witctx era + PlutusScriptWitness + :: ScriptLanguageInEra lang era + -> PlutusScriptVersion lang + -> PlutusScriptOrReferenceInput lang + -> ScriptDatum witctx + -> ScriptRedeemer + -> ExecutionUnits + -> ScriptWitness witctx era deriving instance Show (ScriptWitness witctx era) -- The GADT in the SimpleScriptWitness constructor requires a custom instance instance Eq (ScriptWitness witctx era) where - (==) (SimpleScriptWitness langInEra script) - (SimpleScriptWitness langInEra' script') = - case testEquality (languageOfScriptLanguageInEra langInEra) - (languageOfScriptLanguageInEra langInEra') of - Nothing -> False + (==) + (SimpleScriptWitness langInEra script) + (SimpleScriptWitness langInEra' script') = + case testEquality + (languageOfScriptLanguageInEra langInEra) + (languageOfScriptLanguageInEra langInEra') of + Nothing -> False Just Refl -> script == script' - - (==) (PlutusScriptWitness langInEra version script - datum redeemer execUnits) - (PlutusScriptWitness langInEra' version' script' - datum' redeemer' execUnits') = - case testEquality (languageOfScriptLanguageInEra langInEra) - (languageOfScriptLanguageInEra langInEra') of - Nothing -> False - Just Refl -> version == version' - && script == script' - && datum == datum' - && redeemer == redeemer' - && execUnits == execUnits' - - (==) _ _ = False + (==) + ( PlutusScriptWitness + langInEra + version + script + datum + redeemer + execUnits + ) + ( PlutusScriptWitness + langInEra' + version' + script' + datum' + redeemer' + execUnits' + ) = + case testEquality + (languageOfScriptLanguageInEra langInEra) + (languageOfScriptLanguageInEra langInEra') of + Nothing -> False + Just Refl -> + version == version' + && script == script' + && datum == datum' + && redeemer == redeemer' + && execUnits == execUnits' + (==) _ _ = False type ScriptRedeemer = HashableScriptData data ScriptDatum witctx where - ScriptDatumForTxIn :: HashableScriptData -> ScriptDatum WitCtxTxIn - InlineScriptDatum :: ScriptDatum WitCtxTxIn - NoScriptDatumForMint :: ScriptDatum WitCtxMint - NoScriptDatumForStake :: ScriptDatum WitCtxStake + ScriptDatumForTxIn :: HashableScriptData -> ScriptDatum WitCtxTxIn + InlineScriptDatum :: ScriptDatum WitCtxTxIn + NoScriptDatumForMint :: ScriptDatum WitCtxMint + NoScriptDatumForStake :: ScriptDatum WitCtxStake + +deriving instance Eq (ScriptDatum witctx) -deriving instance Eq (ScriptDatum witctx) deriving instance Show (ScriptDatum witctx) -- We cannot always extract a script from a script witness due to reference scripts. @@ -795,63 +775,56 @@ deriving instance Show (ScriptDatum witctx) -- retrieve the script. scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era) scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) = - Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script) scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) = - Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script) scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) = - Just $ ScriptInEra SimpleScriptInMary (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInMary (SimpleScript script) scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) = - Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script) scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) = - Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script) scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) = - Just $ ScriptInEra SimpleScriptInConway (SimpleScript script) - + Just $ ScriptInEra SimpleScriptInConway (SimpleScript script) scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) = - Just $ ScriptInEra langInEra (PlutusScript version script) - + Just $ ScriptInEra langInEra (PlutusScript version script) scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) = - Nothing - + Nothing scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) = - Nothing + Nothing -- ---------------------------------------------------------------------------- -- The kind of witness to use, key (signature) or script -- data Witness witctx era where + KeyWitness + :: KeyWitnessInCtx witctx + -> Witness witctx era + ScriptWitness + :: ScriptWitnessInCtx witctx + -> ScriptWitness witctx era + -> Witness witctx era - KeyWitness :: KeyWitnessInCtx witctx - -> Witness witctx era - - ScriptWitness :: ScriptWitnessInCtx witctx - -> ScriptWitness witctx era - -> Witness witctx era +deriving instance Eq (Witness witctx era) -deriving instance Eq (Witness witctx era) deriving instance Show (Witness witctx era) data KeyWitnessInCtx witctx where - - KeyWitnessForSpending :: KeyWitnessInCtx WitCtxTxIn - KeyWitnessForStakeAddr :: KeyWitnessInCtx WitCtxStake + KeyWitnessForSpending :: KeyWitnessInCtx WitCtxTxIn + KeyWitnessForStakeAddr :: KeyWitnessInCtx WitCtxStake data ScriptWitnessInCtx witctx where + ScriptWitnessForSpending :: ScriptWitnessInCtx WitCtxTxIn + ScriptWitnessForMinting :: ScriptWitnessInCtx WitCtxMint + ScriptWitnessForStakeAddr :: ScriptWitnessInCtx WitCtxStake - ScriptWitnessForSpending :: ScriptWitnessInCtx WitCtxTxIn - ScriptWitnessForMinting :: ScriptWitnessInCtx WitCtxMint - ScriptWitnessForStakeAddr :: ScriptWitnessInCtx WitCtxStake +deriving instance Eq (KeyWitnessInCtx witctx) -deriving instance Eq (KeyWitnessInCtx witctx) deriving instance Show (KeyWitnessInCtx witctx) -deriving instance Eq (ScriptWitnessInCtx witctx) +deriving instance Eq (ScriptWitnessInCtx witctx) + deriving instance Show (ScriptWitnessInCtx witctx) class IsScriptWitnessInCtx ctx where @@ -875,23 +848,21 @@ instance IsScriptWitnessInCtx WitCtxStake where -- -- This type is also used to describe the limits for the maximum overall -- execution units per transaction or per block. --- -data ExecutionUnits = - ExecutionUnits { - -- | This corresponds roughly to the time to execute a script. - executionSteps :: Natural, - - -- | This corresponds roughly to the peak memory used during script - -- execution. - executionMemory :: Natural - } +data ExecutionUnits + = ExecutionUnits + { executionSteps :: Natural + -- ^ This corresponds roughly to the time to execute a script. + , executionMemory :: Natural + -- ^ This corresponds roughly to the peak memory used during script + -- execution. + } deriving (Eq, Show) instance ToCBOR ExecutionUnits where - toCBOR ExecutionUnits{executionSteps, executionMemory} = - CBOR.encodeListLen 2 - <> toCBOR executionSteps - <> toCBOR executionMemory + toCBOR ExecutionUnits {executionSteps, executionMemory} = + CBOR.encodeListLen 2 + <> toCBOR executionSteps + <> toCBOR executionMemory instance FromCBOR ExecutionUnits where fromCBOR = do @@ -901,9 +872,11 @@ instance FromCBOR ExecutionUnits where <*> fromCBOR instance ToJSON ExecutionUnits where - toJSON ExecutionUnits{executionSteps, executionMemory} = - object [ "steps" .= executionSteps - , "memory" .= executionMemory ] + toJSON ExecutionUnits {executionSteps, executionMemory} = + object + [ "steps" .= executionSteps + , "memory" .= executionMemory + ] instance FromJSON ExecutionUnits where parseJSON = @@ -913,19 +886,18 @@ instance FromJSON ExecutionUnits where <*> o .: "memory" toAlonzoExUnits :: ExecutionUnits -> Alonzo.ExUnits -toAlonzoExUnits ExecutionUnits{executionSteps, executionMemory} = - Alonzo.ExUnits { - Alonzo.exUnitsSteps = executionSteps, - Alonzo.exUnitsMem = executionMemory - } +toAlonzoExUnits ExecutionUnits {executionSteps, executionMemory} = + Alonzo.ExUnits + { Alonzo.exUnitsSteps = executionSteps + , Alonzo.exUnitsMem = executionMemory + } fromAlonzoExUnits :: Alonzo.ExUnits -> ExecutionUnits -fromAlonzoExUnits Alonzo.ExUnits{Alonzo.exUnitsSteps, Alonzo.exUnitsMem} = - ExecutionUnits { - executionSteps = exUnitsSteps, - executionMemory = exUnitsMem - } - +fromAlonzoExUnits Alonzo.ExUnits {Alonzo.exUnitsSteps, Alonzo.exUnitsMem} = + ExecutionUnits + { executionSteps = exUnitsSteps + , executionMemory = exUnitsMem + } -- ---------------------------------------------------------------------------- -- Alonzo mediator pattern @@ -944,61 +916,61 @@ pattern PlutusScriptBinary script = Plutus.Plutus (Plutus.PlutusBinary script) -- hash type being parametrised by the era. The representation is era -- independent, and there are many places where we want to use a script -- hash where we don't want things to be era-parametrised. --- newtype ScriptHash = ScriptHash (Shelley.ScriptHash StandardCrypto) deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex ScriptHash + deriving (Show, IsString) via UsingRawBytesHex ScriptHash deriving (ToJSON, FromJSON) via UsingRawBytesHex ScriptHash instance HasTypeProxy ScriptHash where - data AsType ScriptHash = AsScriptHash - proxyToAsType _ = AsScriptHash + data AsType ScriptHash = AsScriptHash + proxyToAsType _ = AsScriptHash instance SerialiseAsRawBytes ScriptHash where - serialiseToRawBytes (ScriptHash (Shelley.ScriptHash h)) = - Crypto.hashToBytes h - - deserialiseFromRawBytes AsScriptHash bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise ScriptHash") $ - ScriptHash . Shelley.ScriptHash <$> Crypto.hashFromBytes bs + serialiseToRawBytes (ScriptHash (Shelley.ScriptHash h)) = + Crypto.hashToBytes h + deserialiseFromRawBytes AsScriptHash bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise ScriptHash") $ + ScriptHash . Shelley.ScriptHash <$> Crypto.hashFromBytes bs hashScript :: Script lang -> ScriptHash hashScript (SimpleScript s) = - -- We convert to the Allegra-era version specifically and hash that. - -- Later ledger eras have to be compatible anyway. - ScriptHash - . Ledger.hashScript @(ShelleyLedgerEra AllegraEra) - . (toAllegraTimelock :: SimpleScript -> Timelock.Timelock (ShelleyLedgerEra AllegraEra)) - $ s - + -- We convert to the Allegra-era version specifically and hash that. + -- Later ledger eras have to be compatible anyway. + ScriptHash + . Ledger.hashScript @(ShelleyLedgerEra AllegraEra) + . (toAllegraTimelock :: SimpleScript -> Timelock.Timelock (ShelleyLedgerEra AllegraEra)) + $ s hashScript (PlutusScript PlutusScriptV1 (PlutusScriptSerialised script)) = - -- For Plutus V1, we convert to the Alonzo-era version specifically and - -- hash that. Later ledger eras have to be compatible anyway. - ScriptHash - . Ledger.hashScript @(ShelleyLedgerEra AlonzoEra) - . Alonzo.PlutusScript . Alonzo.AlonzoPlutusV1 . Plutus.Plutus - $ Plutus.PlutusBinary script - + -- For Plutus V1, we convert to the Alonzo-era version specifically and + -- hash that. Later ledger eras have to be compatible anyway. + ScriptHash + . Ledger.hashScript @(ShelleyLedgerEra AlonzoEra) + . Alonzo.PlutusScript + . Alonzo.AlonzoPlutusV1 + . Plutus.Plutus + $ Plutus.PlutusBinary script hashScript (PlutusScript PlutusScriptV2 (PlutusScriptSerialised script)) = - ScriptHash - . Ledger.hashScript @(ShelleyLedgerEra BabbageEra) - . Alonzo.PlutusScript . Babbage.BabbagePlutusV2 . Plutus.Plutus - $ Plutus.PlutusBinary script - + ScriptHash + . Ledger.hashScript @(ShelleyLedgerEra BabbageEra) + . Alonzo.PlutusScript + . Babbage.BabbagePlutusV2 + . Plutus.Plutus + $ Plutus.PlutusBinary script hashScript (PlutusScript PlutusScriptV3 (PlutusScriptSerialised script)) = - ScriptHash - . Ledger.hashScript @(ShelleyLedgerEra ConwayEra) - . Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus - $ Plutus.PlutusBinary script + ScriptHash + . Ledger.hashScript @(ShelleyLedgerEra ConwayEra) + . Alonzo.PlutusScript + . Conway.ConwayPlutusV3 + . Plutus.Plutus + $ Plutus.PlutusBinary script toShelleyScriptHash :: ScriptHash -> Shelley.ScriptHash StandardCrypto -toShelleyScriptHash (ScriptHash h) = h +toShelleyScriptHash (ScriptHash h) = h fromShelleyScriptHash :: Shelley.ScriptHash StandardCrypto -> ScriptHash fromShelleyScriptHash = ScriptHash - -- ---------------------------------------------------------------------------- -- The simple script language -- @@ -1020,34 +992,32 @@ data SimpleScript -- -- Note that Plutus scripts have a binary serialisation but no JSON -- serialisation. --- data PlutusScript lang where - PlutusScriptSerialised :: ShortByteString -> PlutusScript lang + PlutusScriptSerialised :: ShortByteString -> PlutusScript lang deriving stock (Eq, Ord) deriving stock (Show) -- TODO: would be nice to use via UsingRawBytesHex - -- however that adds an awkward HasTypeProxy lang => - -- constraint to other Show instances elsewhere + -- however that adds an awkward HasTypeProxy lang => + -- constraint to other Show instances elsewhere deriving (ToCBOR, FromCBOR) via (UsingRawBytes (PlutusScript lang)) - deriving anyclass SerialiseAsCBOR + deriving anyclass (SerialiseAsCBOR) instance HasTypeProxy lang => HasTypeProxy (PlutusScript lang) where - data AsType (PlutusScript lang) = AsPlutusScript (AsType lang) - proxyToAsType _ = AsPlutusScript (proxyToAsType (Proxy :: Proxy lang)) + data AsType (PlutusScript lang) = AsPlutusScript (AsType lang) + proxyToAsType _ = AsPlutusScript (proxyToAsType (Proxy :: Proxy lang)) instance HasTypeProxy lang => SerialiseAsRawBytes (PlutusScript lang) where - serialiseToRawBytes (PlutusScriptSerialised sbs) = SBS.fromShort sbs + serialiseToRawBytes (PlutusScriptSerialised sbs) = SBS.fromShort sbs - deserialiseFromRawBytes (AsPlutusScript _) bs = - -- TODO alonzo: validate the script syntax and fail decoding if invalid - Right (PlutusScriptSerialised (SBS.toShort bs)) + deserialiseFromRawBytes (AsPlutusScript _) bs = + -- TODO alonzo: validate the script syntax and fail decoding if invalid + Right (PlutusScriptSerialised (SBS.toShort bs)) instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) where - textEnvelopeType _ = - case plutusScriptVersion :: PlutusScriptVersion lang of - PlutusScriptV1 -> "PlutusScriptV1" - PlutusScriptV2 -> "PlutusScriptV2" - PlutusScriptV3 -> "PlutusScriptV3" - + textEnvelopeType _ = + case plutusScriptVersion :: PlutusScriptVersion lang of + PlutusScriptV1 -> "PlutusScriptV1" + PlutusScriptV2 -> "PlutusScriptV2" + PlutusScriptV3 -> "PlutusScriptV3" -- | An example Plutus script that always succeeds, irrespective of inputs. -- @@ -1055,13 +1025,13 @@ instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) wher -- allow anyone to spend from it. -- -- The exact script depends on the context in which it is to be used. --- -examplePlutusScriptAlwaysSucceeds :: WitCtx witctx - -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysSucceeds + :: WitCtx witctx + -> PlutusScript PlutusScriptV1 examplePlutusScriptAlwaysSucceeds = - PlutusScriptSerialised - . Plutus.alwaysSucceedingNAryFunction - . scriptArityForWitCtx + PlutusScriptSerialised + . Plutus.alwaysSucceedingNAryFunction + . scriptArityForWitCtx -- | An example Plutus script that always fails, irrespective of inputs. -- @@ -1069,13 +1039,13 @@ examplePlutusScriptAlwaysSucceeds = -- be impossible for anyone to ever spend from it. -- -- The exact script depends on the context in which it is to be used. --- -examplePlutusScriptAlwaysFails :: WitCtx witctx - -> PlutusScript PlutusScriptV1 +examplePlutusScriptAlwaysFails + :: WitCtx witctx + -> PlutusScript PlutusScriptV1 examplePlutusScriptAlwaysFails = - PlutusScriptSerialised - . Plutus.alwaysFailingNAryFunction - . scriptArityForWitCtx + PlutusScriptSerialised + . Plutus.alwaysFailingNAryFunction + . scriptArityForWitCtx -- | The expected arity of the Plutus function, depending on the context in -- which it is used. @@ -1085,65 +1055,82 @@ examplePlutusScriptAlwaysFails = -- * the optional datum (for txins) -- * the redeemer -- * the Plutus representation of the tx and environment --- scriptArityForWitCtx :: WitCtx witctx -> Natural -scriptArityForWitCtx WitCtxTxIn = 3 -scriptArityForWitCtx WitCtxMint = 2 +scriptArityForWitCtx WitCtxTxIn = 3 +scriptArityForWitCtx WitCtxMint = 2 scriptArityForWitCtx WitCtxStake = 2 - -- ---------------------------------------------------------------------------- -- Conversion functions -- toShelleyScript :: ScriptInEra era -> Ledger.Script (ShelleyLedgerEra era) toShelleyScript (ScriptInEra langInEra (SimpleScript script)) = + case langInEra of + SimpleScriptInShelley -> either (error . show) id (toShelleyMultiSig script) + SimpleScriptInAllegra -> toAllegraTimelock script + SimpleScriptInMary -> toAllegraTimelock script + SimpleScriptInAlonzo -> Alonzo.TimelockScript (toAllegraTimelock script) + SimpleScriptInBabbage -> Alonzo.TimelockScript (toAllegraTimelock script) + SimpleScriptInConway -> Alonzo.TimelockScript (toAllegraTimelock script) +toShelleyScript + ( ScriptInEra + langInEra + ( PlutusScript + PlutusScriptV1 + (PlutusScriptSerialised script) + ) + ) = case langInEra of - SimpleScriptInShelley -> either (error . show) id (toShelleyMultiSig script) - SimpleScriptInAllegra -> toAllegraTimelock script - SimpleScriptInMary -> toAllegraTimelock script - SimpleScriptInAlonzo -> Alonzo.TimelockScript (toAllegraTimelock script) - SimpleScriptInBabbage -> Alonzo.TimelockScript (toAllegraTimelock script) - SimpleScriptInConway -> Alonzo.TimelockScript (toAllegraTimelock script) - -toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV1 - (PlutusScriptSerialised script))) = - case langInEra of - PlutusScriptV1InAlonzo -> + PlutusScriptV1InAlonzo -> Alonzo.PlutusScript . Alonzo.AlonzoPlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script PlutusScriptV1InBabbage -> Alonzo.PlutusScript . Babbage.BabbagePlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script - PlutusScriptV1InConway -> + PlutusScriptV1InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script - -toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV2 - (PlutusScriptSerialised script))) = +toShelleyScript + ( ScriptInEra + langInEra + ( PlutusScript + PlutusScriptV2 + (PlutusScriptSerialised script) + ) + ) = case langInEra of PlutusScriptV2InBabbage -> Alonzo.PlutusScript . Babbage.BabbagePlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script - PlutusScriptV2InConway -> + PlutusScriptV2InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script - -toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV3 - (PlutusScriptSerialised script))) = +toShelleyScript + ( ScriptInEra + langInEra + ( PlutusScript + PlutusScriptV3 + (PlutusScriptSerialised script) + ) + ) = case langInEra of - PlutusScriptV3InConway -> + PlutusScriptV3InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script -fromShelleyBasedScript :: ShelleyBasedEra era - -> Ledger.Script (ShelleyLedgerEra era) - -> ScriptInEra era +fromShelleyBasedScript + :: ShelleyBasedEra era + -> Ledger.Script (ShelleyLedgerEra era) + -> ScriptInEra era fromShelleyBasedScript sbe script = case sbe of ShelleyBasedEraShelley -> ScriptInEra SimpleScriptInShelley - . SimpleScript $ fromShelleyMultiSig script + . SimpleScript + $ fromShelleyMultiSig script ShelleyBasedEraAllegra -> ScriptInEra SimpleScriptInAllegra - . SimpleScript $ fromAllegraTimelock script + . SimpleScript + $ fromAllegraTimelock script ShelleyBasedEraMary -> ScriptInEra SimpleScriptInMary - . SimpleScript $ fromAllegraTimelock script + . SimpleScript + $ fromAllegraTimelock script ShelleyBasedEraAlonzo -> case script of Alonzo.PlutusScript (Alonzo.AlonzoPlutusV1 (PlutusScriptBinary s)) -> @@ -1152,7 +1139,8 @@ fromShelleyBasedScript sbe script = $ PlutusScriptSerialised s Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInAlonzo - . SimpleScript $ fromAllegraTimelock s + . SimpleScript + $ fromAllegraTimelock s ShelleyBasedEraBabbage -> case script of Alonzo.PlutusScript plutusV -> @@ -1167,8 +1155,8 @@ fromShelleyBasedScript sbe script = $ PlutusScriptSerialised s Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInBabbage - . SimpleScript $ fromAllegraTimelock s - + . SimpleScript + $ fromAllegraTimelock s ShelleyBasedEraConway -> case script of Alonzo.PlutusScript plutusV -> @@ -1187,73 +1175,70 @@ fromShelleyBasedScript sbe script = $ PlutusScriptSerialised s Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInConway - . SimpleScript $ fromAllegraTimelock s - + . SimpleScript + $ fromAllegraTimelock s -data MultiSigError = MultiSigErrorTimelockNotsupported deriving Show +data MultiSigError = MultiSigErrorTimelockNotsupported deriving (Show) -- | Conversion for the 'Shelley.MultiSig' language used by the Shelley era. --- toShelleyMultiSig :: SimpleScript -> Either MultiSigError (Shelley.MultiSig (ShelleyLedgerEra ShelleyEra)) toShelleyMultiSig = go - where - go :: SimpleScript -> Either MultiSigError (Shelley.MultiSig (ShelleyLedgerEra ShelleyEra)) - go (RequireSignature (PaymentKeyHash kh)) = - return $ Shelley.RequireSignature (Shelley.asWitness kh) - go (RequireAllOf s) = mapM go s <&> Shelley.RequireAllOf . Seq.fromList - go (RequireAnyOf s) = mapM go s <&> Shelley.RequireAnyOf . Seq.fromList - go (RequireMOf m s) = mapM go s <&> Shelley.RequireMOf m . Seq.fromList - go _ = Left MultiSigErrorTimelockNotsupported + where + go :: SimpleScript -> Either MultiSigError (Shelley.MultiSig (ShelleyLedgerEra ShelleyEra)) + go (RequireSignature (PaymentKeyHash kh)) = + return $ Shelley.RequireSignature (Shelley.asWitness kh) + go (RequireAllOf s) = mapM go s <&> Shelley.RequireAllOf . Seq.fromList + go (RequireAnyOf s) = mapM go s <&> Shelley.RequireAnyOf . Seq.fromList + go (RequireMOf m s) = mapM go s <&> Shelley.RequireMOf m . Seq.fromList + go _ = Left MultiSigErrorTimelockNotsupported -- | Conversion for the 'Shelley.MultiSig' language used by the Shelley era. --- fromShelleyMultiSig :: Shelley.MultiSig (ShelleyLedgerEra ShelleyEra) -> SimpleScript fromShelleyMultiSig = go - where - go (Shelley.RequireSignature kh) - = RequireSignature - (PaymentKeyHash (Shelley.coerceKeyRole kh)) - go (Shelley.RequireAllOf s) = RequireAllOf (map go $ toList s) - go (Shelley.RequireAnyOf s) = RequireAnyOf (map go $ toList s) - go (Shelley.RequireMOf m s) = RequireMOf m (map go $ toList s) - go _ = error "" + where + go (Shelley.RequireSignature kh) = + RequireSignature + (PaymentKeyHash (Shelley.coerceKeyRole kh)) + go (Shelley.RequireAllOf s) = RequireAllOf (map go $ toList s) + go (Shelley.RequireAnyOf s) = RequireAnyOf (map go $ toList s) + go (Shelley.RequireMOf m s) = RequireMOf m (map go $ toList s) + go _ = error "" -- | Conversion for the 'Timelock.Timelock' language that is shared between the -- Allegra and Mary eras. --- -toAllegraTimelock :: forall era. - ( Allegra.AllegraEraScript era - , EraCrypto era ~ StandardCrypto - , Ledger.NativeScript era ~ Allegra.Timelock era - ) - => SimpleScript -> Ledger.NativeScript era +toAllegraTimelock + :: forall era + . ( Allegra.AllegraEraScript era + , EraCrypto era ~ StandardCrypto + , Ledger.NativeScript era ~ Allegra.Timelock era + ) + => SimpleScript -> Ledger.NativeScript era toAllegraTimelock = go - where - go :: SimpleScript -> Timelock.Timelock era - go (RequireSignature (PaymentKeyHash kh)) - = Shelley.RequireSignature (Shelley.asWitness kh) - go (RequireAllOf s) = Shelley.RequireAllOf (Seq.fromList (map go s)) - go (RequireAnyOf s) = Shelley.RequireAnyOf (Seq.fromList (map go s)) - go (RequireMOf m s) = Shelley.RequireMOf m (Seq.fromList (map go s)) - go (RequireTimeBefore t) = Allegra.RequireTimeExpire t - go (RequireTimeAfter t) = Allegra.RequireTimeStart t + where + go :: SimpleScript -> Timelock.Timelock era + go (RequireSignature (PaymentKeyHash kh)) = + Shelley.RequireSignature (Shelley.asWitness kh) + go (RequireAllOf s) = Shelley.RequireAllOf (Seq.fromList (map go s)) + go (RequireAnyOf s) = Shelley.RequireAnyOf (Seq.fromList (map go s)) + go (RequireMOf m s) = Shelley.RequireMOf m (Seq.fromList (map go s)) + go (RequireTimeBefore t) = Allegra.RequireTimeExpire t + go (RequireTimeAfter t) = Allegra.RequireTimeStart t -- | Conversion for the 'Timelock.Timelock' language that is shared between the -- Allegra and Mary eras. --- -fromAllegraTimelock :: (Allegra.AllegraEraScript era, EraCrypto era ~ StandardCrypto) - => Ledger.NativeScript era -> SimpleScript +fromAllegraTimelock + :: (Allegra.AllegraEraScript era, EraCrypto era ~ StandardCrypto) + => Ledger.NativeScript era -> SimpleScript fromAllegraTimelock = go - where - go (Shelley.RequireSignature kh) = RequireSignature (PaymentKeyHash (Shelley.coerceKeyRole kh)) - go (Allegra.RequireTimeExpire t) = RequireTimeBefore t - go (Allegra.RequireTimeStart t) = RequireTimeAfter t - go (Shelley.RequireAllOf s) = RequireAllOf (map go (toList s)) - go (Shelley.RequireAnyOf s) = RequireAnyOf (map go (toList s)) - go (Shelley.RequireMOf i s) = RequireMOf i (map go (toList s)) - + where + go (Shelley.RequireSignature kh) = RequireSignature (PaymentKeyHash (Shelley.coerceKeyRole kh)) + go (Allegra.RequireTimeExpire t) = RequireTimeBefore t + go (Allegra.RequireTimeStart t) = RequireTimeAfter t + go (Shelley.RequireAllOf s) = RequireAllOf (map go (toList s)) + go (Shelley.RequireAnyOf s) = RequireAnyOf (map go (toList s)) + go (Shelley.RequireMOf i s) = RequireMOf i (map go (toList s)) -- ---------------------------------------------------------------------------- -- JSON serialisation @@ -1268,117 +1253,131 @@ fromAllegraTimelock = go instance ToJSON SimpleScript where toJSON (RequireSignature pKeyHash) = - object [ "type" .= String "sig" - , "keyHash" .= serialiseToRawBytesHexText pKeyHash - ] + object + [ "type" .= String "sig" + , "keyHash" .= serialiseToRawBytesHexText pKeyHash + ] toJSON (RequireTimeBefore slot) = - object [ "type" .= String "before" - , "slot" .= slot - ] + object + [ "type" .= String "before" + , "slot" .= slot + ] toJSON (RequireTimeAfter slot) = - object [ "type" .= String "after" - , "slot" .= slot - ] + object + [ "type" .= String "after" + , "slot" .= slot + ] toJSON (RequireAnyOf reqScripts) = - object [ "type" .= String "any", "scripts" .= map toJSON reqScripts ] + object ["type" .= String "any", "scripts" .= map toJSON reqScripts] toJSON (RequireAllOf reqScripts) = - object [ "type" .= String "all", "scripts" .= map toJSON reqScripts ] + object ["type" .= String "all", "scripts" .= map toJSON reqScripts] toJSON (RequireMOf reqNum reqScripts) = - object [ "type" .= String "atLeast" - , "required" .= reqNum - , "scripts" .= map toJSON reqScripts - ] - + object + [ "type" .= String "atLeast" + , "required" .= reqNum + , "scripts" .= map toJSON reqScripts + ] instance FromJSON SimpleScript where parseJSON = parseSimpleScript parseSimpleScript :: Value -> Aeson.Parser SimpleScript -parseSimpleScript v = parseScriptSig v <|> - parseScriptBefore v <|> - parseScriptAfter v <|> - parseScriptAny v <|> - parseScriptAll v <|> - parseScriptAtLeast v +parseSimpleScript v = + parseScriptSig v + <|> parseScriptBefore v + <|> parseScriptAfter v + <|> parseScriptAny v + <|> parseScriptAll v + <|> parseScriptAtLeast v parseScriptAny :: Value -> Aeson.Parser SimpleScript parseScriptAny = - Aeson.withObject "any" $ \obj -> do - t <- obj .: "type" - case t :: Text of - "any" -> do vs <- obj .: "scripts" - RequireAnyOf <$> gatherSimpleScriptTerms vs - _ -> fail "\"any\" script value not found" + Aeson.withObject "any" $ \obj -> do + t <- obj .: "type" + case t :: Text of + "any" -> do + vs <- obj .: "scripts" + RequireAnyOf <$> gatherSimpleScriptTerms vs + _ -> fail "\"any\" script value not found" parseScriptAll :: Value -> Aeson.Parser SimpleScript parseScriptAll = - Aeson.withObject "all" $ \obj -> do - t <- obj .: "type" - case t :: Text of - "all" -> do vs <- obj .: "scripts" - RequireAllOf <$> gatherSimpleScriptTerms vs - _ -> fail "\"all\" script value not found" + Aeson.withObject "all" $ \obj -> do + t <- obj .: "type" + case t :: Text of + "all" -> do + vs <- obj .: "scripts" + RequireAllOf <$> gatherSimpleScriptTerms vs + _ -> fail "\"all\" script value not found" parseScriptAtLeast :: Value -> Aeson.Parser SimpleScript parseScriptAtLeast = - Aeson.withObject "atLeast" $ \obj -> do - v <- obj .: "type" - case v :: Text of - "atLeast" -> do - r <- obj .: "required" - vs <- obj .: "scripts" - case r of - Number sci -> - case toBoundedInteger sci of - Just reqInt -> - do scripts <- gatherSimpleScriptTerms vs - let numScripts = length scripts - when - (reqInt > numScripts) - (fail $ "Required number of script signatures exceeds the number of scripts." - <> " Required number: " <> show reqInt - <> " Number of scripts: " <> show numScripts) - return $ RequireMOf reqInt scripts - Nothing -> fail $ "Error in \"required\" key: " - <> show sci <> " is not a valid Int" - _ -> fail "\"required\" value should be an integer" - _ -> fail "\"atLeast\" script value not found" + Aeson.withObject "atLeast" $ \obj -> do + v <- obj .: "type" + case v :: Text of + "atLeast" -> do + r <- obj .: "required" + vs <- obj .: "scripts" + case r of + Number sci -> + case toBoundedInteger sci of + Just reqInt -> + do + scripts <- gatherSimpleScriptTerms vs + let numScripts = length scripts + when + (reqInt > numScripts) + ( fail $ + "Required number of script signatures exceeds the number of scripts." + <> " Required number: " + <> show reqInt + <> " Number of scripts: " + <> show numScripts + ) + return $ RequireMOf reqInt scripts + Nothing -> + fail $ + "Error in \"required\" key: " + <> show sci + <> " is not a valid Int" + _ -> fail "\"required\" value should be an integer" + _ -> fail "\"atLeast\" script value not found" gatherSimpleScriptTerms :: Vector Value -> Aeson.Parser [SimpleScript] gatherSimpleScriptTerms = mapM parseSimpleScript . Vector.toList parseScriptSig :: Value -> Aeson.Parser SimpleScript parseScriptSig = - Aeson.withObject "sig" $ \obj -> do - v <- obj .: "type" - case v :: Text of - "sig" -> do k <- obj .: "keyHash" - RequireSignature <$> parsePaymentKeyHash k - _ -> fail "\"sig\" script value not found" + Aeson.withObject "sig" $ \obj -> do + v <- obj .: "type" + case v :: Text of + "sig" -> do + k <- obj .: "keyHash" + RequireSignature <$> parsePaymentKeyHash k + _ -> fail "\"sig\" script value not found" parseScriptBefore :: Value -> Aeson.Parser SimpleScript parseScriptBefore = - Aeson.withObject "before" $ \obj -> do - v <- obj .: "type" - case v :: Text of - "before" -> RequireTimeBefore <$> obj .: "slot" - _ -> fail "\"before\" script value not found" + Aeson.withObject "before" $ \obj -> do + v <- obj .: "type" + case v :: Text of + "before" -> RequireTimeBefore <$> obj .: "slot" + _ -> fail "\"before\" script value not found" parseScriptAfter :: Value -> Aeson.Parser SimpleScript parseScriptAfter = - Aeson.withObject "after" $ \obj -> do - v <- obj .: "type" - case v :: Text of - "after" -> RequireTimeAfter <$> obj .: "slot" - _ -> fail "\"after\" script value not found" + Aeson.withObject "after" $ \obj -> do + v <- obj .: "type" + case v :: Text of + "after" -> RequireTimeAfter <$> obj .: "slot" + _ -> fail "\"after\" script value not found" parsePaymentKeyHash :: Text -> Aeson.Parser (Hash PaymentKey) parsePaymentKeyHash = failEitherWith (\e -> "Error deserialising payment key hash: " ++ displayError e) - . deserialiseFromRawBytesHex (AsHash AsPaymentKey) - . Text.encodeUtf8 - + . deserialiseFromRawBytesHex (AsHash AsPaymentKey) + . Text.encodeUtf8 -- ---------------------------------------------------------------------------- -- Reference scripts @@ -1387,16 +1386,17 @@ parsePaymentKeyHash = -- | A reference scripts is a script that can exist at a transaction output. This greatly -- reduces the size of transactions that use scripts as the script no longer -- has to be added to the transaction, they can now be referenced via a transaction output. - data ReferenceScript era where - ReferenceScript :: BabbageEraOnwards era - -> ScriptInAnyLang - -> ReferenceScript era - - ReferenceScriptNone :: ReferenceScript era + ReferenceScript + :: BabbageEraOnwards era + -> ScriptInAnyLang + -> ReferenceScript era + ReferenceScriptNone :: ReferenceScript era deriving instance Eq (ReferenceScript era) + deriving instance Show (ReferenceScript era) + deriving instance Typeable (ReferenceScript era) instance IsCardanoEra era => ToJSON (ReferenceScript era) where @@ -1423,7 +1423,7 @@ refScriptToShelleyScript _ ReferenceScriptNone = SNothing fromShelleyScriptToReferenceScript :: ShelleyBasedEra era -> Ledger.Script (ShelleyLedgerEra era) -> ReferenceScript era fromShelleyScriptToReferenceScript sbe script = - scriptInEraToRefScript $ fromShelleyBasedScript sbe script + scriptInEraToRefScript $ fromShelleyBasedScript sbe script scriptInEraToRefScript :: ScriptInEra era -> ReferenceScript era scriptInEraToRefScript sIne@(ScriptInEra _ s) = @@ -1439,12 +1439,16 @@ textEnvelopeToScript = deserialiseFromTextEnvelopeAnyOf textEnvTypes where textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] textEnvTypes = - [ FromSomeType (AsScript AsSimpleScript) - (ScriptInAnyLang SimpleScriptLanguage) - , FromSomeType (AsScript AsPlutusScriptV1) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1)) - , FromSomeType (AsScript AsPlutusScriptV2) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2)) - , FromSomeType (AsScript AsPlutusScriptV3) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) + [ FromSomeType + (AsScript AsSimpleScript) + (ScriptInAnyLang SimpleScriptLanguage) + , FromSomeType + (AsScript AsPlutusScriptV1) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1)) + , FromSomeType + (AsScript AsPlutusScriptV2) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2)) + , FromSomeType + (AsScript AsPlutusScriptV3) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) ] diff --git a/cardano-api/internal/Cardano/Api/ScriptData.hs b/cardano-api/internal/Cardano/Api/ScriptData.hs index 6d033661dc..584e0588fb 100644 --- a/cardano-api/internal/Cardano/Api/ScriptData.hs +++ b/cardano-api/internal/Cardano/Api/ScriptData.hs @@ -7,106 +7,105 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Cardano.Api.ScriptData ( - -- * Script data - HashableScriptData, - hashScriptDataBytes, - getOriginalScriptDataBytes, - getScriptData, - unsafeHashableScriptData, - ScriptData(..), +module Cardano.Api.ScriptData + ( -- * Script data + HashableScriptData + , hashScriptDataBytes + , getOriginalScriptDataBytes + , getScriptData + , unsafeHashableScriptData + , ScriptData (..) -- * Validating metadata - validateScriptData, - ScriptDataRangeError (..), + , validateScriptData + , ScriptDataRangeError (..) -- * Conversion to\/from JSON - ScriptDataJsonSchema (..), - scriptDataFromJson, - scriptDataToJson, - ScriptDataJsonError (..), - ScriptDataJsonSchemaError (..), - scriptDataFromJsonDetailedSchema, - scriptDataToJsonDetailedSchema, - ScriptBytesError(..), - ScriptDataJsonBytesError(..), - scriptDataJsonToHashable, + , ScriptDataJsonSchema (..) + , scriptDataFromJson + , scriptDataToJson + , ScriptDataJsonError (..) + , ScriptDataJsonSchemaError (..) + , scriptDataFromJsonDetailedSchema + , scriptDataToJsonDetailedSchema + , ScriptBytesError (..) + , ScriptDataJsonBytesError (..) + , scriptDataJsonToHashable -- * Internal conversion functions - toPlutusData, - fromPlutusData, - toAlonzoData, - fromAlonzoData, + , toPlutusData + , fromPlutusData + , toAlonzoData + , fromAlonzoData -- * Data family instances - AsType(..), - Hash(..), - ) where - -import Cardano.Api.Eras -import Cardano.Api.Error -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Shelley -import Cardano.Api.Pretty -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseUsing -import Cardano.Api.TxMetadata (pBytes, pSigned, parseAll) - + , AsType (..) + , Hash (..) + ) +where + +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Shelley +import Cardano.Api.Pretty +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseUsing +import Cardano.Api.TxMetadata (pBytes, pSigned, parseAll) import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Core (Era) +import Cardano.Ledger.Core (Era) import qualified Cardano.Ledger.Plutus.Data as Plutus import qualified Cardano.Ledger.SafeHash as Ledger -import Ouroboros.Consensus.Shelley.Eras (StandardAlonzo, StandardCrypto) -import qualified PlutusLedgerApi.V1 as PlutusAPI - -import Codec.Serialise.Class (Serialise (..)) -import Control.Applicative (Alternative (..)) +import Codec.Serialise.Class (Serialise (..)) +import Control.Applicative (Alternative (..)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Text as Aeson.Text import qualified Data.Attoparsec.ByteString.Char8 as Atto -import Data.Bifunctor (first) +import Data.Bifunctor (first) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.Short as SB import qualified Data.Char as Char -import Data.Data (Data) -import Data.Either.Combinators +import Data.Data (Data) +import Data.Either.Combinators import qualified Data.List as List -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Scientific as Scientific -import Data.String (IsString) -import Data.Text (Text) +import Data.String (IsString) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector -import Data.Word +import Data.Word +import Ouroboros.Consensus.Shelley.Eras (StandardAlonzo, StandardCrypto) +import qualified PlutusLedgerApi.V1 as PlutusAPI -- Original script data bytes data HashableScriptData = HashableScriptData - !BS.ByteString -- ^ Original 'ScriptData' bytes + !BS.ByteString + -- ^ Original 'ScriptData' bytes !ScriptData - deriving (Eq, Show) + deriving (Eq, Show) instance HasTypeProxy HashableScriptData where - data AsType HashableScriptData = AsHashableScriptData - proxyToAsType _ = AsHashableScriptData + data AsType HashableScriptData = AsHashableScriptData + proxyToAsType _ = AsHashableScriptData instance SerialiseAsCBOR HashableScriptData where - serialiseToCBOR (HashableScriptData origBytes _) = origBytes - deserialiseFromCBOR AsHashableScriptData bs = - HashableScriptData bs - <$> CBOR.decodeFullDecoder "ScriptData" fromCBOR (LBS.fromStrict bs) - + serialiseToCBOR (HashableScriptData origBytes _) = origBytes + deserialiseFromCBOR AsHashableScriptData bs = + HashableScriptData bs + <$> CBOR.decodeFullDecoder "ScriptData" fromCBOR (LBS.fromStrict bs) getOriginalScriptDataBytes :: HashableScriptData -> BS.ByteString getOriginalScriptDataBytes (HashableScriptData bs _) = bs @@ -125,45 +124,52 @@ unsafeHashableScriptData sd = HashableScriptData (serialiseToCBOR sd) sd -- Script data - Allows us to represent script data as JSON -- -data ScriptData = ScriptDataConstructor - Integer -- ^ Tag for the constructor - [ScriptData] -- ^ Constructor arguments - | ScriptDataMap [(ScriptData, ScriptData)] -- ^ Key value pairs - | ScriptDataList [ScriptData] -- ^ Elements - | ScriptDataNumber Integer - | ScriptDataBytes BS.ByteString +data ScriptData + = ScriptDataConstructor + Integer + -- ^ Tag for the constructor + [ScriptData] + -- ^ Constructor arguments + | -- | Key value pairs + ScriptDataMap [(ScriptData, ScriptData)] + | -- | Elements + ScriptDataList [ScriptData] + | ScriptDataNumber Integer + | ScriptDataBytes BS.ByteString deriving (Eq, Ord, Show) - -- Note the order of constructors is the same as the Plutus definitions - -- so that the Ord instance is consistent with the Plutus one. - -- This is checked by prop_ord_distributive_ScriptData + +-- Note the order of constructors is the same as the Plutus definitions +-- so that the Ord instance is consistent with the Plutus one. +-- This is checked by prop_ord_distributive_ScriptData instance HasTypeProxy ScriptData where - data AsType ScriptData = AsScriptData - proxyToAsType _ = AsScriptData + data AsType ScriptData = AsScriptData + proxyToAsType _ = AsScriptData -- ---------------------------------------------------------------------------- -- Script data hash -- -newtype instance Hash ScriptData = - ScriptDataHash (Plutus.DataHash StandardCrypto) +newtype instance Hash ScriptData + = ScriptDataHash (Plutus.DataHash StandardCrypto) deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) - deriving (ToJSON, FromJSON) via UsingRawBytesHex (Hash ScriptData) + deriving (Show, IsString) via UsingRawBytesHex (Hash ScriptData) + deriving (ToJSON, FromJSON) via UsingRawBytesHex (Hash ScriptData) deriving (ToJSONKey, FromJSONKey) via UsingRawBytesHex (Hash ScriptData) instance SerialiseAsRawBytes (Hash ScriptData) where - serialiseToRawBytes (ScriptDataHash dh) = - Crypto.hashToBytes (Ledger.extractHash dh) + serialiseToRawBytes (ScriptDataHash dh) = + Crypto.hashToBytes (Ledger.extractHash dh) - deserialiseFromRawBytes (AsHash AsScriptData) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ScriptData") $ - ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsScriptData) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash ScriptData") $ + ScriptDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs instance SerialiseAsCBOR ScriptData where - serialiseToCBOR = CBOR.serialize' - deserialiseFromCBOR AsScriptData bs = CBOR.decodeFullDecoder "ScriptData" fromCBOR (LBS.fromStrict bs) :: Either CBOR.DecoderError ScriptData - + serialiseToCBOR = CBOR.serialize' + deserialiseFromCBOR AsScriptData bs = + CBOR.decodeFullDecoder "ScriptData" fromCBOR (LBS.fromStrict bs) + :: Either CBOR.DecoderError ScriptData instance ToCBOR ScriptData where toCBOR = encode @PlutusAPI.Data . toPlutusData @@ -173,14 +179,16 @@ instance FromCBOR ScriptData where fromCBOR = fromPlutusData <$> decode @PlutusAPI.Data hashScriptDataBytes :: HashableScriptData -> Hash ScriptData -hashScriptDataBytes = - ScriptDataHash . Plutus.hashData . (toAlonzoData :: HashableScriptData -> Plutus.Data StandardAlonzo) +hashScriptDataBytes = + ScriptDataHash + . Plutus.hashData + . (toAlonzoData :: HashableScriptData -> Plutus.Data StandardAlonzo) -- ---------------------------------------------------------------------------- -- Conversion functions -- -newtype ScriptBytesError = ScriptBytesError String deriving Show +newtype ScriptBytesError = ScriptBytesError String deriving (Show) -- There is a subtlety here. We must use the original bytes -- when converting to and from `HashableScriptData`/`Data`. This @@ -191,9 +199,12 @@ newtype ScriptBytesError = ScriptBytesError String deriving Show toAlonzoData :: Era ledgerera => HashableScriptData -> Plutus.Data ledgerera toAlonzoData = either - (\ e -> error $ "toAlonzoData: " <> show e) - Plutus.binaryDataToData - . first ScriptBytesError . Plutus.makeBinaryData . SB.toShort . getOriginalScriptDataBytes + (\e -> error $ "toAlonzoData: " <> show e) + Plutus.binaryDataToData + . first ScriptBytesError + . Plutus.makeBinaryData + . SB.toShort + . getOriginalScriptDataBytes fromAlonzoData :: Plutus.Data ledgerera -> HashableScriptData fromAlonzoData d = @@ -202,30 +213,36 @@ fromAlonzoData d = (fromPlutusData $ Plutus.getPlutusData d) toPlutusData :: ScriptData -> PlutusAPI.Data -toPlutusData (ScriptDataConstructor int xs) - = PlutusAPI.Constr int - [ toPlutusData x | x <- xs ] -toPlutusData (ScriptDataMap kvs) = PlutusAPI.Map - [ (toPlutusData k, toPlutusData v) - | (k,v) <- kvs ] -toPlutusData (ScriptDataList xs) = PlutusAPI.List - [ toPlutusData x | x <- xs ] +toPlutusData (ScriptDataConstructor int xs) = + PlutusAPI.Constr + int + [toPlutusData x | x <- xs] +toPlutusData (ScriptDataMap kvs) = + PlutusAPI.Map + [ (toPlutusData k, toPlutusData v) + | (k, v) <- kvs + ] +toPlutusData (ScriptDataList xs) = + PlutusAPI.List + [toPlutusData x | x <- xs] toPlutusData (ScriptDataNumber n) = PlutusAPI.I n toPlutusData (ScriptDataBytes bs) = PlutusAPI.B bs - fromPlutusData :: PlutusAPI.Data -> ScriptData -fromPlutusData (PlutusAPI.Constr int xs) - = ScriptDataConstructor int - [ fromPlutusData x | x <- xs ] -fromPlutusData (PlutusAPI.Map kvs) = ScriptDataMap - [ (fromPlutusData k, fromPlutusData v) - | (k,v) <- kvs ] -fromPlutusData (PlutusAPI.List xs) = ScriptDataList - [ fromPlutusData x | x <- xs ] -fromPlutusData (PlutusAPI.I n) = ScriptDataNumber n -fromPlutusData (PlutusAPI.B bs) = ScriptDataBytes bs - +fromPlutusData (PlutusAPI.Constr int xs) = + ScriptDataConstructor + int + [fromPlutusData x | x <- xs] +fromPlutusData (PlutusAPI.Map kvs) = + ScriptDataMap + [ (fromPlutusData k, fromPlutusData v) + | (k, v) <- kvs + ] +fromPlutusData (PlutusAPI.List xs) = + ScriptDataList + [fromPlutusData x | x <- xs] +fromPlutusData (PlutusAPI.I n) = ScriptDataNumber n +fromPlutusData (PlutusAPI.B bs) = ScriptDataBytes bs -- ---------------------------------------------------------------------------- -- Validate script data @@ -233,40 +250,36 @@ fromPlutusData (PlutusAPI.B bs) = ScriptDataBytes bs -- | Validate script data. This is for use with existing constructed script -- data values, e.g. constructed manually or decoded from CBOR directly. --- validateScriptData :: ScriptData -> Either ScriptDataRangeError () validateScriptData d = - case collect d of - [] -> Right () - err:_ -> Left err - where - -- Arbitrary size numbers are fine - collect (ScriptDataNumber _) = [] - - -- Arbitrary sized bytes are fine - collect (ScriptDataBytes _) = [] - - collect (ScriptDataList xs) = - foldMap collect xs - - collect (ScriptDataMap kvs) = - foldMap (\(k, v) -> collect k - <> collect v) - kvs - - -- Constr tags do need to be less than a Word64 - collect (ScriptDataConstructor n xs) = - [ ScriptDataConstructorOutOfRange n - | n > fromIntegral (maxBound :: Word64) || n < 0 ] - <> foldMap collect xs + case collect d of + [] -> Right () + err : _ -> Left err + where + -- Arbitrary size numbers are fine + collect (ScriptDataNumber _) = [] + -- Arbitrary sized bytes are fine + collect (ScriptDataBytes _) = [] + collect (ScriptDataList xs) = + foldMap collect xs + collect (ScriptDataMap kvs) = + foldMap + ( \(k, v) -> + collect k + <> collect v + ) + kvs + -- Constr tags do need to be less than a Word64 + collect (ScriptDataConstructor n xs) = + [ ScriptDataConstructorOutOfRange n + | n > fromIntegral (maxBound :: Word64) || n < 0 + ] + <> foldMap collect xs -- | An error in script data due to an out-of-range value. --- -newtype ScriptDataRangeError = - - -- | The constructor number is outside the maximum range of @-2^64-1 .. 2^64-1@. - -- - ScriptDataConstructorOutOfRange Integer +newtype ScriptDataRangeError + = -- | The constructor number is outside the maximum range of @-2^64-1 .. 2^64-1@. + ScriptDataConstructorOutOfRange Integer deriving (Eq, Show, Data) instance Error ScriptDataRangeError where @@ -329,54 +342,47 @@ instance Error ScriptDataRangeError where -- precisely. It also means any script data can be converted into the JSON and -- back without loss. That is we can round-trip the script data via the JSON and -- also round-trip schema-compliant JSON via script data. --- -data ScriptDataJsonSchema = - - -- | Use the \"no schema\" mapping between JSON and script data as - -- described above. - ScriptDataJsonNoSchema - - -- | Use the \"detailed schema\" mapping between JSON and script data as - -- described above. - | ScriptDataJsonDetailedSchema +data ScriptDataJsonSchema + = -- | Use the \"no schema\" mapping between JSON and script data as + -- described above. + ScriptDataJsonNoSchema + | -- | Use the \"detailed schema\" mapping between JSON and script data as + -- described above. + ScriptDataJsonDetailedSchema deriving (Eq, Show) - -- | Convert a value from JSON into script data, using the given choice of -- mapping between JSON and script data. -- -- This may fail with a conversion error if the JSON is outside the supported -- subset for the chosen mapping. See 'ScriptDataJsonSchema' for the details. --- -scriptDataFromJson :: ScriptDataJsonSchema - -> Aeson.Value - -> Either ScriptDataJsonError HashableScriptData +scriptDataFromJson + :: ScriptDataJsonSchema + -> Aeson.Value + -> Either ScriptDataJsonError HashableScriptData scriptDataFromJson schema v = do - d <- first (ScriptDataJsonSchemaError v) (scriptDataFromJson' v) - first (ScriptDataRangeError v) (validateScriptData $ getScriptData d) - return d - where - scriptDataFromJson' = - case schema of - ScriptDataJsonNoSchema -> scriptDataFromJsonNoSchema - ScriptDataJsonDetailedSchema -> scriptDataFromJsonDetailedSchema - - + d <- first (ScriptDataJsonSchemaError v) (scriptDataFromJson' v) + first (ScriptDataRangeError v) (validateScriptData $ getScriptData d) + return d + where + scriptDataFromJson' = + case schema of + ScriptDataJsonNoSchema -> scriptDataFromJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataFromJsonDetailedSchema -- | Convert a script data value into JSON , using the given choice of mapping -- between JSON and script data. -- -- This conversion is total but is not necessarily invertible. -- See 'ScriptDataJsonSchema' for the details. --- -scriptDataToJson :: ScriptDataJsonSchema - -> HashableScriptData - -> Aeson.Value +scriptDataToJson + :: ScriptDataJsonSchema + -> HashableScriptData + -> Aeson.Value scriptDataToJson schema = - case schema of - ScriptDataJsonNoSchema -> scriptDataToJsonNoSchema - ScriptDataJsonDetailedSchema -> scriptDataToJsonDetailedSchema - + case schema of + ScriptDataJsonNoSchema -> scriptDataToJsonNoSchema + ScriptDataJsonDetailedSchema -> scriptDataToJsonDetailedSchema -- ---------------------------------------------------------------------------- -- JSON conversion using the the "no schema" style @@ -384,85 +390,87 @@ scriptDataToJson schema = scriptDataToJsonNoSchema :: HashableScriptData -> Aeson.Value scriptDataToJsonNoSchema = conv . getScriptData - where - conv :: ScriptData -> Aeson.Value - conv (ScriptDataNumber n) = Aeson.Number (fromInteger n) - conv (ScriptDataBytes bs) - | Right s <- Text.decodeUtf8' bs - , Text.all Char.isPrint s - = Aeson.String s - - | otherwise - = Aeson.String (bytesPrefix <> Text.decodeLatin1 (Base16.encode bs)) - - conv (ScriptDataList vs) = Aeson.Array (Vector.fromList (map conv vs)) - conv (ScriptDataMap kvs) = Aeson.object - [ (convKey k, conv v) - | (k, v) <- kvs ] - - conv (ScriptDataConstructor n vs) = - Aeson.Array $ - Vector.fromList - [ Aeson.Number (fromInteger n) - , Aeson.Array (Vector.fromList (map conv vs)) - ] - - - -- Script data allows any value as a key, not just string as JSON does. - -- For simple types we just convert them to string directly. - -- For structured keys we render them as JSON and use that as the string. - convKey :: ScriptData -> Aeson.Key - convKey (ScriptDataNumber n) = Aeson.fromText $ Text.pack (show n) - convKey (ScriptDataBytes bs) = Aeson.fromText $ bytesPrefix - <> Text.decodeLatin1 (Base16.encode bs) - convKey v = Aeson.fromText - . Text.Lazy.toStrict - . Aeson.Text.encodeToLazyText - . conv - $ v - -scriptDataFromJsonNoSchema :: Aeson.Value - -> Either ScriptDataJsonSchemaError - HashableScriptData + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = Aeson.Number (fromInteger n) + conv (ScriptDataBytes bs) + | Right s <- Text.decodeUtf8' bs + , Text.all Char.isPrint s = + Aeson.String s + | otherwise = + Aeson.String (bytesPrefix <> Text.decodeLatin1 (Base16.encode bs)) + conv (ScriptDataList vs) = Aeson.Array (Vector.fromList (map conv vs)) + conv (ScriptDataMap kvs) = + Aeson.object + [ (convKey k, conv v) + | (k, v) <- kvs + ] + conv (ScriptDataConstructor n vs) = + Aeson.Array $ + Vector.fromList + [ Aeson.Number (fromInteger n) + , Aeson.Array (Vector.fromList (map conv vs)) + ] + + -- Script data allows any value as a key, not just string as JSON does. + -- For simple types we just convert them to string directly. + -- For structured keys we render them as JSON and use that as the string. + convKey :: ScriptData -> Aeson.Key + convKey (ScriptDataNumber n) = Aeson.fromText $ Text.pack (show n) + convKey (ScriptDataBytes bs) = + Aeson.fromText $ + bytesPrefix + <> Text.decodeLatin1 (Base16.encode bs) + convKey v = + Aeson.fromText + . Text.Lazy.toStrict + . Aeson.Text.encodeToLazyText + . conv + $ v + +scriptDataFromJsonNoSchema + :: Aeson.Value + -> Either + ScriptDataJsonSchemaError + HashableScriptData scriptDataFromJsonNoSchema = fmap (\sd -> HashableScriptData (serialiseToCBOR sd) sd) . conv - where - conv :: Aeson.Value - -> Either ScriptDataJsonSchemaError ScriptData - conv Aeson.Null = Left ScriptDataJsonNullNotAllowed - conv Aeson.Bool{} = Left ScriptDataJsonBoolNotAllowed - - conv (Aeson.Number d) = - case Scientific.floatingOrInteger d :: Either Double Integer of - Left n -> Left (ScriptDataJsonNumberNotInteger n) - Right n -> Right (ScriptDataNumber n) - - conv (Aeson.String s) - | Just s' <- Text.stripPrefix bytesPrefix s - , let bs' = Text.encodeUtf8 s' - , Right bs <- Base16.decode bs' - , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') - = Right (ScriptDataBytes bs) - - | otherwise - = Right (ScriptDataBytes (Text.encodeUtf8 s)) - - conv (Aeson.Array vs) = - fmap ScriptDataList + where + conv + :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv Aeson.Null = Left ScriptDataJsonNullNotAllowed + conv Aeson.Bool {} = Left ScriptDataJsonBoolNotAllowed + conv (Aeson.Number d) = + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + conv (Aeson.String s) + | Just s' <- Text.stripPrefix bytesPrefix s + , let bs' = Text.encodeUtf8 s' + , Right bs <- Base16.decode bs' + , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') = + Right (ScriptDataBytes bs) + | otherwise = + Right (ScriptDataBytes (Text.encodeUtf8 s)) + conv (Aeson.Array vs) = + fmap ScriptDataList . traverse conv $ Vector.toList vs - - conv (Aeson.Object kvs) = - fmap ScriptDataMap - . traverse (\(k,v) -> (,) (convKey k) <$> conv v) + conv (Aeson.Object kvs) = + fmap ScriptDataMap + . traverse (\(k, v) -> (,) (convKey k) <$> conv v) . List.sortOn fst . fmap (first Aeson.toText) $ KeyMap.toList kvs - convKey :: Text -> ScriptData - convKey s = - fromMaybe (ScriptDataBytes (Text.encodeUtf8 s)) $ - parseAll ((fmap ScriptDataNumber pSigned <* Atto.endOfInput) - <|> (fmap ScriptDataBytes pBytes <* Atto.endOfInput)) s + convKey :: Text -> ScriptData + convKey s = + fromMaybe (ScriptDataBytes (Text.encodeUtf8 s)) $ + parseAll + ( (fmap ScriptDataNumber pSigned <* Atto.endOfInput) + <|> (fmap ScriptDataBytes pBytes <* Atto.endOfInput) + ) + s -- | JSON strings that are base16 encoded and prefixed with 'bytesPrefix' will -- be encoded as CBOR bytestrings. @@ -470,9 +478,9 @@ bytesPrefix :: Text bytesPrefix = "0x" data ScriptDataJsonBytesError - = ScriptDataJsonBytesErrorValue ScriptDataJsonError - | ScriptDataJsonBytesErrorInvalid ScriptDataRangeError - deriving (Show, Data) + = ScriptDataJsonBytesErrorValue ScriptDataJsonError + | ScriptDataJsonBytesErrorInvalid ScriptDataRangeError + deriving (Show, Data) instance Error ScriptDataJsonBytesError where prettyError (ScriptDataJsonBytesErrorValue e) = @@ -480,12 +488,12 @@ instance Error ScriptDataJsonBytesError where prettyError (ScriptDataJsonBytesErrorInvalid e) = "ScriptData is invalid: " <> prettyError e - -- | This allows us to take JSON formatted ScriptData and encode it in the CDDL format -- whilst preserving the original bytes. scriptDataJsonToHashable :: ScriptDataJsonSchema - -> Aeson.Value -- ^ ScriptData Value + -> Aeson.Value + -- ^ ScriptData Value -> Either ScriptDataJsonBytesError HashableScriptData scriptDataJsonToHashable schema scriptDataVal = do sData <- first ScriptDataJsonBytesErrorValue $ scriptDataFromJson schema scriptDataVal @@ -498,109 +506,109 @@ scriptDataJsonToHashable schema scriptDataVal = do scriptDataToJsonDetailedSchema :: HashableScriptData -> Aeson.Value scriptDataToJsonDetailedSchema = conv . getScriptData - where - conv :: ScriptData -> Aeson.Value - conv (ScriptDataNumber n) = singleFieldObject "int" - . Aeson.Number - $ fromInteger n - conv (ScriptDataBytes bs) = singleFieldObject "bytes" - . Aeson.String - $ Text.decodeLatin1 (Base16.encode bs) - conv (ScriptDataList vs) = singleFieldObject "list" - . Aeson.Array - $ Vector.fromList (map conv vs) - conv (ScriptDataMap kvs) = singleFieldObject "map" - . Aeson.Array - $ Vector.fromList - [ Aeson.object [ ("k", conv k), ("v", conv v) ] - | (k, v) <- kvs ] - - conv (ScriptDataConstructor n vs) = - Aeson.object - [ ("constructor", Aeson.Number (fromInteger n)) - , ("fields", Aeson.Array (Vector.fromList (map conv vs))) + where + conv :: ScriptData -> Aeson.Value + conv (ScriptDataNumber n) = + singleFieldObject "int" + . Aeson.Number + $ fromInteger n + conv (ScriptDataBytes bs) = + singleFieldObject "bytes" + . Aeson.String + $ Text.decodeLatin1 (Base16.encode bs) + conv (ScriptDataList vs) = + singleFieldObject "list" + . Aeson.Array + $ Vector.fromList (map conv vs) + conv (ScriptDataMap kvs) = + singleFieldObject "map" + . Aeson.Array + $ Vector.fromList + [ Aeson.object [("k", conv k), ("v", conv v)] + | (k, v) <- kvs ] + conv (ScriptDataConstructor n vs) = + Aeson.object + [ ("constructor", Aeson.Number (fromInteger n)) + , ("fields", Aeson.Array (Vector.fromList (map conv vs))) + ] - singleFieldObject name v = Aeson.object [(name, v)] - + singleFieldObject name v = Aeson.object [(name, v)] -scriptDataFromJsonDetailedSchema :: Aeson.Value - -> Either ScriptDataJsonSchemaError - HashableScriptData +scriptDataFromJsonDetailedSchema + :: Aeson.Value + -> Either + ScriptDataJsonSchemaError + HashableScriptData scriptDataFromJsonDetailedSchema = fmap (\sd -> HashableScriptData (serialiseToCBOR sd) sd) . conv - where - conv :: Aeson.Value - -> Either ScriptDataJsonSchemaError ScriptData - conv (Aeson.Object m) = - case List.sort $ KeyMap.toList m of - [("int", Aeson.Number d)] -> - case Scientific.floatingOrInteger d :: Either Double Integer of - Left n -> Left (ScriptDataJsonNumberNotInteger n) - Right n -> Right (ScriptDataNumber n) - - [("bytes", Aeson.String s)] - | Right bs <- Base16.decode (Text.encodeUtf8 s) - -> Right (ScriptDataBytes bs) - - [("list", Aeson.Array vs)] -> - fmap ScriptDataList + where + conv + :: Aeson.Value + -> Either ScriptDataJsonSchemaError ScriptData + conv (Aeson.Object m) = + case List.sort $ KeyMap.toList m of + [("int", Aeson.Number d)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> Right (ScriptDataNumber n) + [("bytes", Aeson.String s)] + | Right bs <- Base16.decode (Text.encodeUtf8 s) -> + Right (ScriptDataBytes bs) + [("list", Aeson.Array vs)] -> + fmap ScriptDataList . traverse conv $ Vector.toList vs - - [("map", Aeson.Array kvs)] -> - fmap ScriptDataMap + [("map", Aeson.Array kvs)] -> + fmap ScriptDataMap . traverse convKeyValuePair $ Vector.toList kvs - - [("constructor", Aeson.Number d), - ("fields", Aeson.Array vs)] -> + [ ("constructor", Aeson.Number d) + , ("fields", Aeson.Array vs) + ] -> case Scientific.floatingOrInteger d :: Either Double Integer of - Left n -> Left (ScriptDataJsonNumberNotInteger n) - Right n -> fmap (ScriptDataConstructor n) - . traverse conv - $ Vector.toList vs - - (key, v):_ | key `elem` ["int", "bytes", "list", "map", "constructor"] -> + Left n -> Left (ScriptDataJsonNumberNotInteger n) + Right n -> + fmap (ScriptDataConstructor n) + . traverse conv + $ Vector.toList vs + (key, v) : _ + | key `elem` ["int", "bytes", "list", "map", "constructor"] -> Left (ScriptDataJsonTypeMismatch (Aeson.toText key) v) - - kvs -> Left (ScriptDataJsonBadObject $ first Aeson.toText <$> kvs) - - conv v = Left (ScriptDataJsonNotObject v) - - convKeyValuePair :: Aeson.Value - -> Either ScriptDataJsonSchemaError - (ScriptData, ScriptData) - convKeyValuePair (Aeson.Object m) - | KeyMap.size m == 2 - , Just k <- KeyMap.lookup "k" m - , Just v <- KeyMap.lookup "v" m - = (,) <$> conv k <*> conv v - - convKeyValuePair v = Left (ScriptDataJsonBadMapPair v) - + kvs -> Left (ScriptDataJsonBadObject $ first Aeson.toText <$> kvs) + conv v = Left (ScriptDataJsonNotObject v) + + convKeyValuePair + :: Aeson.Value + -> Either + ScriptDataJsonSchemaError + (ScriptData, ScriptData) + convKeyValuePair (Aeson.Object m) + | KeyMap.size m == 2 + , Just k <- KeyMap.lookup "k" m + , Just v <- KeyMap.lookup "v" m = + (,) <$> conv k <*> conv v + convKeyValuePair v = Left (ScriptDataJsonBadMapPair v) -- ---------------------------------------------------------------------------- -- Shared JSON conversion error types -- -data ScriptDataJsonError = - ScriptDataJsonSchemaError !Aeson.Value !ScriptDataJsonSchemaError - | ScriptDataRangeError !Aeson.Value !ScriptDataRangeError +data ScriptDataJsonError + = ScriptDataJsonSchemaError !Aeson.Value !ScriptDataJsonSchemaError + | ScriptDataRangeError !Aeson.Value !ScriptDataRangeError deriving (Eq, Show, Data) -data ScriptDataJsonSchemaError = - -- Only used for 'ScriptDataJsonNoSchema' - ScriptDataJsonNullNotAllowed - | ScriptDataJsonBoolNotAllowed - - -- Used by both mappings - | ScriptDataJsonNumberNotInteger !Double - - -- Only used for 'ScriptDataJsonDetailedSchema' - | ScriptDataJsonNotObject !Aeson.Value - | ScriptDataJsonBadObject ![(Text, Aeson.Value)] - | ScriptDataJsonBadMapPair !Aeson.Value - | ScriptDataJsonTypeMismatch !Text !Aeson.Value +data ScriptDataJsonSchemaError + = -- Only used for 'ScriptDataJsonNoSchema' + ScriptDataJsonNullNotAllowed + | ScriptDataJsonBoolNotAllowed + | -- Used by both mappings + ScriptDataJsonNumberNotInteger !Double + | -- Only used for 'ScriptDataJsonDetailedSchema' + ScriptDataJsonNotObject !Aeson.Value + | ScriptDataJsonBadObject ![(Text, Aeson.Value)] + | ScriptDataJsonBadMapPair !Aeson.Value + | ScriptDataJsonTypeMismatch !Text !Aeson.Value deriving (Eq, Show, Data) instance Error ScriptDataJsonError where diff --git a/cardano-api/internal/Cardano/Api/SerialiseBech32.hs b/cardano-api/internal/Cardano/Api/SerialiseBech32.hs index d9fc7ae14e..0d2b770888 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseBech32.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseBech32.hs @@ -4,174 +4,164 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Bech32 Serialisation --- module Cardano.Api.SerialiseBech32 - ( SerialiseAsBech32(..) + ( SerialiseAsBech32 (..) , serialiseToBech32 - , Bech32DecodeError(..) + , Bech32DecodeError (..) , deserialiseFromBech32 , deserialiseAnyOfFromBech32 - ) where - -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Orphans () -import Cardano.Api.Pretty -import Cardano.Api.SerialiseRaw -import Cardano.Api.Utils - + ) +where + +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Orphans () +import Cardano.Api.Pretty +import Cardano.Api.SerialiseRaw +import Cardano.Api.Utils import qualified Codec.Binary.Bech32 as Bech32 -import Control.Monad (guard) -import Data.ByteString (ByteString) -import Data.Data (Data) +import Control.Monad (guard) +import Data.ByteString (ByteString) +import Data.Data (Data) import qualified Data.List as List -import Data.Set (Set) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where + -- | The human readable prefix to use when encoding this value to Bech32. + bech32PrefixFor :: a -> Text - -- | The human readable prefix to use when encoding this value to Bech32. - -- - bech32PrefixFor :: a -> Text - - -- | The set of human readable prefixes that can be used for this type. - -- - bech32PrefixesPermitted :: AsType a -> [Text] - + -- | The set of human readable prefixes that can be used for this type. + bech32PrefixesPermitted :: AsType a -> [Text] serialiseToBech32 :: SerialiseAsBech32 a => a -> Text serialiseToBech32 a = - Bech32.encodeLenient - humanReadablePart - (Bech32.dataPartFromBytes (serialiseToRawBytes a)) - where - humanReadablePart = - case Bech32.humanReadablePartFromText (bech32PrefixFor a) of - Right p -> p - Left err -> error $ "serialiseToBech32: invalid prefix " - ++ show (bech32PrefixFor a) - ++ ", " ++ show err - - -deserialiseFromBech32 :: SerialiseAsBech32 a - => AsType a -> Text -> Either Bech32DecodeError a + Bech32.encodeLenient + humanReadablePart + (Bech32.dataPartFromBytes (serialiseToRawBytes a)) + where + humanReadablePart = + case Bech32.humanReadablePartFromText (bech32PrefixFor a) of + Right p -> p + Left err -> + error $ + "serialiseToBech32: invalid prefix " + ++ show (bech32PrefixFor a) + ++ ", " + ++ show err + +deserialiseFromBech32 + :: SerialiseAsBech32 a + => AsType a -> Text -> Either Bech32DecodeError a deserialiseFromBech32 asType bech32Str = do - (prefix, dataPart) <- Bech32.decodeLenient bech32Str - ?!. Bech32DecodingError + (prefix, dataPart) <- + Bech32.decodeLenient bech32Str + ?!. Bech32DecodingError - let actualPrefix = Bech32.humanReadablePartToText prefix - permittedPrefixes = bech32PrefixesPermitted asType - guard (actualPrefix `elem` permittedPrefixes) - ?! Bech32UnexpectedPrefix actualPrefix (Set.fromList permittedPrefixes) + let actualPrefix = Bech32.humanReadablePartToText prefix + permittedPrefixes = bech32PrefixesPermitted asType + guard (actualPrefix `elem` permittedPrefixes) + ?! Bech32UnexpectedPrefix actualPrefix (Set.fromList permittedPrefixes) - payload <- Bech32.dataPartToBytes dataPart - ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart) + payload <- + Bech32.dataPartToBytes dataPart + ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart) - value <- case deserialiseFromRawBytes asType payload of - Right a -> Right a - Left _ -> Left $ Bech32DeserialiseFromBytesError payload + value <- case deserialiseFromRawBytes asType payload of + Right a -> Right a + Left _ -> Left $ Bech32DeserialiseFromBytesError payload - let expectedPrefix = bech32PrefixFor value - guard (actualPrefix == expectedPrefix) - ?! Bech32WrongPrefix actualPrefix expectedPrefix - - return value + let expectedPrefix = bech32PrefixFor value + guard (actualPrefix == expectedPrefix) + ?! Bech32WrongPrefix actualPrefix expectedPrefix + return value deserialiseAnyOfFromBech32 - :: forall b. - [FromSomeType SerialiseAsBech32 b] + :: forall b + . [FromSomeType SerialiseAsBech32 b] -> Text -> Either Bech32DecodeError b deserialiseAnyOfFromBech32 types bech32Str = do - (prefix, dataPart) <- Bech32.decodeLenient bech32Str - ?!. Bech32DecodingError - - let actualPrefix = Bech32.humanReadablePartToText prefix - - FromSomeType actualType fromType <- - findForPrefix actualPrefix - ?! Bech32UnexpectedPrefix actualPrefix permittedPrefixes - - payload <- Bech32.dataPartToBytes dataPart - ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart) - - value <- case deserialiseFromRawBytes actualType payload of - Right a -> Right a - Left _ -> Left $ Bech32DeserialiseFromBytesError payload - - let expectedPrefix = bech32PrefixFor value - guard (actualPrefix == expectedPrefix) - ?! Bech32WrongPrefix actualPrefix expectedPrefix - - return (fromType value) - where - findForPrefix - :: Text - -> Maybe (FromSomeType SerialiseAsBech32 b) - findForPrefix prefix = - List.find - (\(FromSomeType t _) -> prefix `elem` bech32PrefixesPermitted t) - types - - permittedPrefixes :: Set Text - permittedPrefixes = - Set.fromList $ concat + (prefix, dataPart) <- + Bech32.decodeLenient bech32Str + ?!. Bech32DecodingError + + let actualPrefix = Bech32.humanReadablePartToText prefix + + FromSomeType actualType fromType <- + findForPrefix actualPrefix + ?! Bech32UnexpectedPrefix actualPrefix permittedPrefixes + + payload <- + Bech32.dataPartToBytes dataPart + ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart) + + value <- case deserialiseFromRawBytes actualType payload of + Right a -> Right a + Left _ -> Left $ Bech32DeserialiseFromBytesError payload + + let expectedPrefix = bech32PrefixFor value + guard (actualPrefix == expectedPrefix) + ?! Bech32WrongPrefix actualPrefix expectedPrefix + + return (fromType value) + where + findForPrefix + :: Text + -> Maybe (FromSomeType SerialiseAsBech32 b) + findForPrefix prefix = + List.find + (\(FromSomeType t _) -> prefix `elem` bech32PrefixesPermitted t) + types + + permittedPrefixes :: Set Text + permittedPrefixes = + Set.fromList $ + concat [ bech32PrefixesPermitted ttoken | FromSomeType ttoken _f <- types ] - -- | Bech32 decoding error. --- -data Bech32DecodeError = - - -- | There was an error decoding the string as Bech32. - Bech32DecodingError !Bech32.DecodingError - - -- | The human-readable prefix in the Bech32-encoded string is not one - -- of the ones expected. - | Bech32UnexpectedPrefix !Text !(Set Text) - - -- | There was an error in extracting a 'ByteString' from the data part of - -- the Bech32-encoded string. - | Bech32DataPartToBytesError !Text - - -- | There was an error in deserialising the bytes into a value of the - -- expected type. - | Bech32DeserialiseFromBytesError !ByteString - - -- | The human-readable prefix in the Bech32-encoded string does not - -- correspond to the prefix that should be used for the payload value. - | Bech32WrongPrefix !Text !Text - +data Bech32DecodeError + = -- | There was an error decoding the string as Bech32. + Bech32DecodingError !Bech32.DecodingError + | -- | The human-readable prefix in the Bech32-encoded string is not one + -- of the ones expected. + Bech32UnexpectedPrefix !Text !(Set Text) + | -- | There was an error in extracting a 'ByteString' from the data part of + -- the Bech32-encoded string. + Bech32DataPartToBytesError !Text + | -- | There was an error in deserialising the bytes into a value of the + -- expected type. + Bech32DeserialiseFromBytesError !ByteString + | -- | The human-readable prefix in the Bech32-encoded string does not + -- correspond to the prefix that should be used for the payload value. + Bech32WrongPrefix !Text !Text deriving (Eq, Show, Data) instance Error Bech32DecodeError where prettyError = \case Bech32DecodingError decErr -> pshow decErr -- TODO - Bech32UnexpectedPrefix actual permitted -> mconcat [ "Unexpected Bech32 prefix: the actual prefix is " <> pshow actual , ", but it was expected to be " , mconcat $ List.intersperse " or " (map pshow (Set.toList permitted)) ] - Bech32DataPartToBytesError _dataPart -> mconcat [ "There was an error in extracting the bytes from the data part of the " , "Bech32-encoded string." ] - Bech32DeserialiseFromBytesError _bytes -> mconcat [ "There was an error in deserialising the data part of the " , "Bech32-encoded string into a value of the expected type." ] - Bech32WrongPrefix actual expected -> mconcat [ "Mismatch in the Bech32 prefix: the actual prefix is " <> pshow actual diff --git a/cardano-api/internal/Cardano/Api/SerialiseCBOR.hs b/cardano-api/internal/Cardano/Api/SerialiseCBOR.hs index 4f2cc224c6..654c45e19d 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseCBOR.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseCBOR.hs @@ -1,31 +1,28 @@ {-# LANGUAGE DefaultSignatures #-} -- | CBOR serialisation --- module Cardano.Api.SerialiseCBOR - ( SerialiseAsCBOR(..) - , FromCBOR(..) - , ToCBOR(..) - ) where - -import Cardano.Api.HasTypeProxy - -import Cardano.Binary (FromCBOR, ToCBOR) + ( SerialiseAsCBOR (..) + , FromCBOR (..) + , ToCBOR (..) + ) +where + +import Cardano.Api.HasTypeProxy +import Cardano.Binary (FromCBOR, ToCBOR) import qualified Cardano.Binary as CBOR - -import Data.ByteString (ByteString) - +import Data.ByteString (ByteString) class HasTypeProxy a => SerialiseAsCBOR a where - serialiseToCBOR :: a -> ByteString - deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a - - default serialiseToCBOR :: ToCBOR a => a -> ByteString - serialiseToCBOR = CBOR.serialize' - - default deserialiseFromCBOR :: FromCBOR a - => AsType a - -> ByteString - -> Either CBOR.DecoderError a - deserialiseFromCBOR _proxy = CBOR.decodeFull' - + serialiseToCBOR :: a -> ByteString + deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a + + default serialiseToCBOR :: ToCBOR a => a -> ByteString + serialiseToCBOR = CBOR.serialize' + + default deserialiseFromCBOR + :: FromCBOR a + => AsType a + -> ByteString + -> Either CBOR.DecoderError a + deserialiseFromCBOR _proxy = CBOR.decodeFull' diff --git a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs index 0856121820..7a95b0afb1 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseJSON.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseJSON.hs @@ -1,33 +1,32 @@ {-# LANGUAGE DeriveDataTypeable #-} -- | JSON serialisation --- module Cardano.Api.SerialiseJSON ( serialiseToJSON - , ToJSON(..) + , ToJSON (..) , ToJSONKey , deserialiseFromJSON , prettyPrintJSON - , FromJSON(..) + , FromJSON (..) , FromJSONKey - , JsonDecodeError(..) + , JsonDecodeError (..) , readFileJSON , writeFileJSON - ) where + ) +where -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty - -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither) -import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither) +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) import qualified Data.Aeson as Aeson -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.ByteString (ByteString) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Data.Data (Data) +import Data.Data (Data) newtype JsonDecodeError = JsonDecodeError String deriving (Eq, Show, Data) @@ -42,30 +41,33 @@ serialiseToJSON = LBS.toStrict . Aeson.encode prettyPrintJSON :: ToJSON a => a -> ByteString prettyPrintJSON = LBS.toStrict . encodePretty -deserialiseFromJSON :: FromJSON a - => AsType a - -> ByteString - -> Either JsonDecodeError a -deserialiseFromJSON _proxy = either (Left . JsonDecodeError) Right - . Aeson.eitherDecodeStrict' - +deserialiseFromJSON + :: FromJSON a + => AsType a + -> ByteString + -> Either JsonDecodeError a +deserialiseFromJSON _proxy = + either (Left . JsonDecodeError) Right + . Aeson.eitherDecodeStrict' -readFileJSON :: FromJSON a - => AsType a - -> FilePath - -> IO (Either (FileError JsonDecodeError) a) +readFileJSON + :: FromJSON a + => AsType a + -> FilePath + -> IO (Either (FileError JsonDecodeError) a) readFileJSON ttoken path = - runExceptT $ do - content <- fileIOExceptT path BS.readFile - firstExceptT (FileError path) $ hoistEither $ + runExceptT $ do + content <- fileIOExceptT path BS.readFile + firstExceptT (FileError path) $ + hoistEither $ deserialiseFromJSON ttoken content -writeFileJSON :: ToJSON a - => FilePath - -> a - -> IO (Either (FileError ()) ()) +writeFileJSON + :: ToJSON a + => FilePath + -> a + -> IO (Either (FileError ()) ()) writeFileJSON path x = - runExceptT $ - handleIOExceptT (FileIOError path) $ - BS.writeFile path (serialiseToJSON x) - + runExceptT $ + handleIOExceptT (FileIOError path) $ + BS.writeFile path (serialiseToJSON x) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index d85554f9e1..b52b93c606 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -9,19 +9,17 @@ {-# LANGUAGE TypeFamilies #-} -- | Ledger CDDL Serialisation --- module Cardano.Api.SerialiseLedgerCddl ( TextEnvelopeCddlError (..) - , FromSomeTypeCDDL(..) + , FromSomeTypeCDDL (..) + + -- * Reading one of several transaction or - -- * Reading one of several transaction or -- key witness types , readFileTextEnvelopeCddlAnyOf , deserialiseFromTextEnvelopeCddlAnyOf - , writeTxFileTextEnvelopeCddl , writeTxWitnessFileTextEnvelopeCddl - -- Exported for testing , serialiseTxLedgerCddl , deserialiseTxLedgerCddl @@ -33,35 +31,43 @@ module Cardano.Api.SerialiseLedgerCddl , serializeByronTx , writeByronTxFileTextEnvelopeCddl ) - where - -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.IO -import Cardano.Api.Pretty -import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), - TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), - TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, - legacyComparison, serialiseToTextEnvelope) -import Cardano.Api.Tx.Sign -import Cardano.Api.Utils - +where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.IO +import Cardano.Api.Pretty +import Cardano.Api.SerialiseTextEnvelope + ( TextEnvelope (..) + , TextEnvelopeDescr (TextEnvelopeDescr) + , TextEnvelopeError (..) + , TextEnvelopeType (TextEnvelopeType) + , deserialiseFromTextEnvelope + , legacyComparison + , serialiseToTextEnvelope + ) +import Cardano.Api.Tx.Sign +import Cardano.Api.Utils import qualified Cardano.Chain.UTxO as Byron -import Cardano.Ledger.Binary (DecoderError) +import Cardano.Ledger.Binary (DecoderError) import qualified Cardano.Ledger.Binary as CBOR - -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, - newExceptT, runExceptT) +import Control.Monad.Trans.Except.Extra + ( firstExceptT + , handleIOExceptT + , hoistEither + , newExceptT + , runExceptT + ) import qualified Data.Aeson as Aeson -import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) +import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS -import Data.Data (Data) -import Data.Either.Combinators (mapLeft) +import Data.Data (Data) +import Data.Either.Combinators (mapLeft) import qualified Data.List as List -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T -- Why have we gone this route? The serialization format of `TxBody era` @@ -83,16 +89,20 @@ data TextEnvelopeCddlError | TextEnvelopeCddlAesonDecodeError FilePath String | TextEnvelopeCddlUnknownKeyWitness | TextEnvelopeCddlTypeError - [Text] -- ^ Expected types - Text -- ^ Actual types + [Text] + -- ^ Expected types + Text + -- ^ Actual types | TextEnvelopeCddlErrUnknownType Text | TextEnvelopeCddlErrByronKeyWitnessUnsupported deriving (Show, Eq, Data) textEnvelopeErrorToTextEnvelopeCddlError :: TextEnvelopeError -> TextEnvelopeCddlError textEnvelopeErrorToTextEnvelopeCddlError = \case - TextEnvelopeTypeError expectedTypes actualType -> TextEnvelopeCddlTypeError (map (T.pack . show) expectedTypes) - (T.pack $ show actualType) + TextEnvelopeTypeError expectedTypes actualType -> + TextEnvelopeCddlTypeError + (map (T.pack . show) expectedTypes) + (T.pack $ show actualType) TextEnvelopeDecodeError decoderError -> TextEnvelopeCddlErrCBORDecodingError decoderError TextEnvelopeAesonDecodeError errorString -> TextEnvelopeCddlAesonDecodeError "" errorString @@ -119,35 +129,45 @@ instance Error TextEnvelopeCddlError where TextEnvelopeCddlErrByronKeyWitnessUnsupported -> "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." -{-# DEPRECATED serialiseTxLedgerCddl "Use 'serialiseToTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} +{-# DEPRECATED + serialiseTxLedgerCddl + "Use 'serialiseToTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." + #-} serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope -serialiseTxLedgerCddl era tx = shelleyBasedEraConstraints era $ - (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx){teType = TextEnvelopeType $ T.unpack $ genType tx} - where - genType :: Tx era -> Text - genType tx' = case getTxWitnesses tx' of - [] -> "Unwitnessed " <> genTxType - _ -> "Witnessed " <> genTxType - genTxType :: Text - genTxType = - case era of - ShelleyBasedEraShelley -> "Tx ShelleyEra" - ShelleyBasedEraAllegra -> "Tx AllegraEra" - ShelleyBasedEraMary -> "Tx MaryEra" - ShelleyBasedEraAlonzo -> "Tx AlonzoEra" - ShelleyBasedEraBabbage -> "Tx BabbageEra" - ShelleyBasedEraConway -> "Tx ConwayEra" - -{-# DEPRECATED deserialiseTxLedgerCddl "Use 'deserialiseFromTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} -deserialiseTxLedgerCddl :: forall era . - ShelleyBasedEra era +serialiseTxLedgerCddl era tx = + shelleyBasedEraConstraints era $ + (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx) + { teType = TextEnvelopeType $ T.unpack $ genType tx + } + where + genType :: Tx era -> Text + genType tx' = case getTxWitnesses tx' of + [] -> "Unwitnessed " <> genTxType + _ -> "Witnessed " <> genTxType + genTxType :: Text + genTxType = + case era of + ShelleyBasedEraShelley -> "Tx ShelleyEra" + ShelleyBasedEraAllegra -> "Tx AllegraEra" + ShelleyBasedEraMary -> "Tx MaryEra" + ShelleyBasedEraAlonzo -> "Tx AlonzoEra" + ShelleyBasedEraBabbage -> "Tx BabbageEra" + ShelleyBasedEraConway -> "Tx ConwayEra" + +{-# DEPRECATED + deserialiseTxLedgerCddl + "Use 'deserialiseFromTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." + #-} +deserialiseTxLedgerCddl + :: forall era + . ShelleyBasedEra era -> TextEnvelope -> Either TextEnvelopeError (Tx era) deserialiseTxLedgerCddl era = shelleyBasedEraConstraints era $ deserialiseFromTextEnvelope asType - where - asType :: AsType (Tx era) - asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy + where + asType :: AsType (Tx era) + asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy writeByronTxFileTextEnvelopeCddl :: File content Out @@ -156,8 +176,8 @@ writeByronTxFileTextEnvelopeCddl writeByronTxFileTextEnvelopeCddl path w = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson - where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serializeByronTx w) <> "\n" + where + txJson = encodePretty' textEnvelopeCddlJSONConfig (serializeByronTx w) <> "\n" serializeByronTx :: Byron.ATxAux ByteString -> TextEnvelope serializeByronTx tx = @@ -169,50 +189,68 @@ serializeByronTx tx = deserialiseByronTxCddl :: TextEnvelope -> Either TextEnvelopeCddlError (Byron.ATxAux ByteString) deserialiseByronTxCddl tec = - first TextEnvelopeCddlErrCBORDecodingError $ - CBOR.decodeFullAnnotatedBytes - CBOR.byronProtVer "Byron Tx" - CBOR.decCBOR (LBS.fromStrict $ teRawCBOR tec) + first TextEnvelopeCddlErrCBORDecodingError $ + CBOR.decodeFullAnnotatedBytes + CBOR.byronProtVer + "Byron Tx" + CBOR.decCBOR + (LBS.fromStrict $ teRawCBOR tec) serialiseWitnessLedgerCddl :: forall era. ShelleyBasedEra era -> KeyWitness era -> TextEnvelope -serialiseWitnessLedgerCddl sbe kw = shelleyBasedEraConstraints sbe $ - serialiseToTextEnvelope (Just (TextEnvelopeDescr $ T.unpack $ genDesc kw)) kw +serialiseWitnessLedgerCddl sbe kw = + shelleyBasedEraConstraints sbe $ + serialiseToTextEnvelope (Just (TextEnvelopeDescr $ T.unpack $ genDesc kw)) kw where genDesc :: KeyWitness era -> Text - genDesc ByronKeyWitness{} = case sbe of {} - genDesc ShelleyBootstrapWitness{} = "Key BootstrapWitness ShelleyEra" - genDesc ShelleyKeyWitness{} = "Key Witness ShelleyEra" + genDesc ByronKeyWitness {} = case sbe of {} + genDesc ShelleyBootstrapWitness {} = "Key BootstrapWitness ShelleyEra" + genDesc ShelleyKeyWitness {} = "Key Witness ShelleyEra" -deserialiseWitnessLedgerCddl :: forall era . - ShelleyBasedEra era +deserialiseWitnessLedgerCddl + :: forall era + . ShelleyBasedEra era -> TextEnvelope -> Either TextEnvelopeCddlError (KeyWitness era) deserialiseWitnessLedgerCddl sbe te = - shelleyBasedEraConstraints sbe $ legacyDecoding te $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ - deserialiseFromTextEnvelope asType te - where - asType :: AsType (KeyWitness era) - asType = shelleyBasedEraConstraints sbe $ proxyToAsType Proxy - - -- | This wrapper ensures that we can still decode the key witness - -- that were serialized before we migrated to using 'serialiseToTextEnvelope' - legacyDecoding :: TextEnvelope -> Either TextEnvelopeCddlError (KeyWitness era) -> Either TextEnvelopeCddlError (KeyWitness era) - legacyDecoding TextEnvelope{teDescription, teRawCBOR} (Left (TextEnvelopeCddlErrCBORDecodingError _)) = - case teDescription of - "Key BootstrapWitness ShelleyEra" -> do - w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeFullAnnotator - (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teRawCBOR) - Right $ ShelleyBootstrapWitness sbe w - "Key Witness ShelleyEra" -> do - w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeFullAnnotator - (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teRawCBOR) - Right $ ShelleyKeyWitness sbe w - _ -> Left TextEnvelopeCddlUnknownKeyWitness - legacyDecoding _ v = v - -writeTxFileTextEnvelopeCddl :: () + shelleyBasedEraConstraints sbe $ + legacyDecoding te $ + mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ + deserialiseFromTextEnvelope asType te + where + asType :: AsType (KeyWitness era) + asType = shelleyBasedEraConstraints sbe $ proxyToAsType Proxy + + -- \| This wrapper ensures that we can still decode the key witness + -- that were serialized before we migrated to using 'serialiseToTextEnvelope' + legacyDecoding + :: TextEnvelope + -> Either TextEnvelopeCddlError (KeyWitness era) + -> Either TextEnvelopeCddlError (KeyWitness era) + legacyDecoding TextEnvelope {teDescription, teRawCBOR} (Left (TextEnvelopeCddlErrCBORDecodingError _)) = + case teDescription of + "Key BootstrapWitness ShelleyEra" -> do + w <- + first TextEnvelopeCddlErrCBORDecodingError $ + CBOR.decodeFullAnnotator + (eraProtVerLow sbe) + "Shelley Witness" + CBOR.decCBOR + (LBS.fromStrict teRawCBOR) + Right $ ShelleyBootstrapWitness sbe w + "Key Witness ShelleyEra" -> do + w <- + first TextEnvelopeCddlErrCBORDecodingError $ + CBOR.decodeFullAnnotator + (eraProtVerLow sbe) + "Shelley Witness" + CBOR.decCBOR + (LBS.fromStrict teRawCBOR) + Right $ ShelleyKeyWitness sbe w + _ -> Left TextEnvelopeCddlUnknownKeyWitness + legacyDecoding _ v = v + +writeTxFileTextEnvelopeCddl + :: () => ShelleyBasedEra era -> File content Out -> Tx era @@ -220,8 +258,8 @@ writeTxFileTextEnvelopeCddl :: () writeTxFileTextEnvelopeCddl era path tx = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson - where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n" + where + txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n" writeTxWitnessFileTextEnvelopeCddl :: ShelleyBasedEra era @@ -231,12 +269,12 @@ writeTxWitnessFileTextEnvelopeCddl writeTxWitnessFileTextEnvelopeCddl sbe path w = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson - where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseWitnessLedgerCddl sbe w) <> "\n" + where + txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseWitnessLedgerCddl sbe w) <> "\n" textEnvelopeCddlJSONConfig :: Config textEnvelopeCddlJSONConfig = - defConfig { confCompare = textEnvelopeCddlJSONKeyOrder } + defConfig {confCompare = textEnvelopeCddlJSONKeyOrder} textEnvelopeCddlJSONKeyOrder :: Text -> Text -> Ordering textEnvelopeCddlJSONKeyOrder = keyOrder ["type", "description", "cborHex"] @@ -245,12 +283,13 @@ textEnvelopeCddlJSONKeyOrder = keyOrder ["type", "description", "cborHex"] -- having to provide the era. data FromSomeTypeCDDL c b where FromCDDLTx - :: Text -- ^ CDDL type that we want + :: Text + -- ^ CDDL type that we want -> (InAnyShelleyBasedEra Tx -> b) -> FromSomeTypeCDDL TextEnvelope b - FromCDDLWitness - :: Text -- ^ CDDL type that we want + :: Text + -- ^ CDDL type that we want -> (InAnyShelleyBasedEra KeyWitness -> b) -> FromSomeTypeCDDL TextEnvelope b @@ -259,27 +298,26 @@ deserialiseFromTextEnvelopeCddlAnyOf -> TextEnvelope -> Either TextEnvelopeCddlError b deserialiseFromTextEnvelopeCddlAnyOf types teCddl = - case List.find matching types of - Nothing -> - Left (TextEnvelopeCddlTypeError expectedTypes actualType) - - Just (FromCDDLTx ttoken f) -> do - AnyShelleyBasedEra era <- cddlTypeToEra ttoken - f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseTxLedgerCddl era teCddl) - - Just (FromCDDLWitness ttoken f) -> do - AnyShelleyBasedEra era <- cddlTypeToEra ttoken - f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl - where - actualType :: Text - actualType = T.pack $ show $ teType teCddl + case List.find matching types of + Nothing -> + Left (TextEnvelopeCddlTypeError expectedTypes actualType) + Just (FromCDDLTx ttoken f) -> do + AnyShelleyBasedEra era <- cddlTypeToEra ttoken + f . InAnyShelleyBasedEra era + <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseTxLedgerCddl era teCddl) + Just (FromCDDLWitness ttoken f) -> do + AnyShelleyBasedEra era <- cddlTypeToEra ttoken + f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl + where + actualType :: Text + actualType = T.pack $ show $ teType teCddl - expectedTypes :: [Text] - expectedTypes = [ typ | FromCDDLTx typ _f <- types ] + expectedTypes :: [Text] + expectedTypes = [typ | FromCDDLTx typ _f <- types] - matching :: FromSomeTypeCDDL TextEnvelope b -> Bool - matching (FromCDDLTx ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl - matching (FromCDDLWitness ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl + matching :: FromSomeTypeCDDL TextEnvelope b -> Bool + matching (FromCDDLTx ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl + matching (FromCDDLWitness ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl -- Parse the text into types because this will increase code readability and -- will make it easier to keep track of the different Cddl descriptions via @@ -323,4 +361,5 @@ readTextEnvelopeCddlFromFile path = runExceptT $ do bs <- fileIOExceptT path readFileBlocking firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path) - . hoistEither $ Aeson.eitherDecodeStrict' bs + . hoistEither + $ Aeson.eitherDecodeStrict' bs diff --git a/cardano-api/internal/Cardano/Api/SerialiseRaw.hs b/cardano-api/internal/Cardano/Api/SerialiseRaw.hs index 15140788bb..f58b39e8db 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseRaw.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseRaw.hs @@ -3,28 +3,27 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Raw binary serialisation --- module Cardano.Api.SerialiseRaw - ( RawBytesHexError(..) - , SerialiseAsRawBytes(..) - , SerialiseAsRawBytesError(..) + ( RawBytesHexError (..) + , SerialiseAsRawBytes (..) + , SerialiseAsRawBytesError (..) , serialiseToRawBytesHex , deserialiseFromRawBytesHex , serialiseToRawBytesHexText - ) where + ) +where -import Cardano.Api.Error (Error, prettyError) -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty - -import Data.Bifunctor (Bifunctor (..)) -import Data.ByteString (ByteString) +import Cardano.Api.Error (Error, prettyError) +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty +import Data.Bifunctor (Bifunctor (..)) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 -import Data.Data (typeRep) -import Data.Text (Text) +import Data.Data (typeRep) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Typeable (TypeRep, Typeable) +import Data.Typeable (TypeRep, Typeable) newtype SerialiseAsRawBytesError = SerialiseAsRawBytesError -- TODO We can do better than use String to carry the error message @@ -33,7 +32,6 @@ newtype SerialiseAsRawBytesError = SerialiseAsRawBytesError deriving (Eq, Show) class (HasTypeProxy a, Typeable a) => SerialiseAsRawBytes a where - serialiseToRawBytes :: a -> ByteString deserialiseFromRawBytes :: AsType a -> ByteString -> Either SerialiseAsRawBytesError a @@ -47,25 +45,32 @@ serialiseToRawBytesHexText = Text.decodeUtf8 . serialiseToRawBytesHex -- | The errors that the pure 'SerialiseAsRawBytes' parsing\/decoding functions can return. data RawBytesHexError = RawBytesHexErrorBase16DecodeFail - ByteString -- ^ original input - String -- ^ error message + ByteString + -- ^ original input + String + -- ^ error message | RawBytesHexErrorRawBytesDecodeFail - ByteString -- ^ original input - TypeRep -- ^ expected type - SerialiseAsRawBytesError -- ^ error message + ByteString + -- ^ original input + TypeRep + -- ^ expected type + SerialiseAsRawBytesError + -- ^ error message deriving (Show) instance Error RawBytesHexError where prettyError = \case RawBytesHexErrorBase16DecodeFail input message -> - "Expected Base16-encoded bytestring, but got " <> pretty (toText input) <> "; " - <> pretty message + "Expected Base16-encoded bytestring, but got " + <> pretty (toText input) + <> "; " + <> pretty message RawBytesHexErrorRawBytesDecodeFail input asType (SerialiseAsRawBytesError e) -> "Failed to deserialise " <> pretty (toText input) <> " as " <> pshow asType <> ". " <> pretty e - where - toText bs = case Text.decodeUtf8' bs of - Right t -> Text.unpack t - Left _ -> show bs + where + toText bs = case Text.decodeUtf8' bs of + Right t -> Text.unpack t + Left _ -> show bs deserialiseFromRawBytesHex :: SerialiseAsRawBytes a diff --git a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index ae5d208e8e..650d6d6146 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs @@ -10,15 +10,14 @@ {-# LANGUAGE TypeFamilies #-} -- | TextEnvelope Serialisation --- module Cardano.Api.SerialiseTextEnvelope - ( HasTextEnvelope(..) + ( HasTextEnvelope (..) , textEnvelopeTypeInEra - , TextEnvelope(..) - , TextEnvelopeType(..) - , TextEnvelopeDescr(..) + , TextEnvelope (..) + , TextEnvelopeType (..) + , TextEnvelopeDescr (..) , textEnvelopeRawCBOR - , TextEnvelopeError(..) + , TextEnvelopeError (..) , serialiseToTextEnvelope , deserialiseFromTextEnvelope , readFileTextEnvelope @@ -29,40 +28,39 @@ module Cardano.Api.SerialiseTextEnvelope , legacyComparison -- * Reading one of several key types - , FromSomeType(..) + , FromSomeType (..) , deserialiseFromTextEnvelopeAnyOf , readFileTextEnvelopeAnyOf -- * Data family instances - , AsType(..) - ) where - -import Cardano.Api.Eras -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.IO -import Cardano.Api.Orphans () -import Cardano.Api.Pretty -import Cardano.Api.SerialiseCBOR -import Cardano.Api.Utils (readFileBlocking) - -import Cardano.Binary (DecoderError) - -import Control.Monad (unless) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither) -import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) + , AsType (..) + ) +where + +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.IO +import Cardano.Api.Orphans () +import Cardano.Api.Pretty +import Cardano.Api.SerialiseCBOR +import Cardano.Api.Utils (readFileBlocking) +import Cardano.Binary (DecoderError) +import Control.Monad (unless) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import qualified Data.Aeson as Aeson -import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) +import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS -import Data.Data (Data) +import Data.Data (Data) import qualified Data.List as List -import Data.Maybe (fromMaybe) -import Data.String (IsString) -import Data.Text (Text) +import Data.Maybe (fromMaybe) +import Data.String (IsString) +import Data.Text (Text) import qualified Data.Text.Encoding as Text -- ---------------------------------------------------------------------------- @@ -86,48 +84,48 @@ newtype TextEnvelopeDescr = TextEnvelopeDescr String -- -- It also contains a \"title\" field which is free-form, and could be used -- to indicate the role or purpose to a reader. --- data TextEnvelope = TextEnvelope - { teType :: !TextEnvelopeType + { teType :: !TextEnvelopeType , teDescription :: !TextEnvelopeDescr - , teRawCBOR :: !ByteString - } deriving (Eq, Show) + , teRawCBOR :: !ByteString + } + deriving (Eq, Show) instance HasTypeProxy TextEnvelope where - data AsType TextEnvelope = AsTextEnvelope - proxyToAsType _ = AsTextEnvelope + data AsType TextEnvelope = AsTextEnvelope + proxyToAsType _ = AsTextEnvelope instance ToJSON TextEnvelope where toJSON TextEnvelope {teType, teDescription, teRawCBOR} = - object [ "type" .= teType - , "description" .= teDescription - , "cborHex" .= Text.decodeUtf8 (Base16.encode teRawCBOR) - ] + object + [ "type" .= teType + , "description" .= teDescription + , "cborHex" .= Text.decodeUtf8 (Base16.encode teRawCBOR) + ] instance FromJSON TextEnvelope where parseJSON = withObject "TextEnvelope" $ \v -> - TextEnvelope <$> (v .: "type") - <*> (v .: "description") - <*> (parseJSONBase16 =<< v .: "cborHex") - where - parseJSONBase16 v = - either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v + TextEnvelope + <$> (v .: "type") + <*> (v .: "description") + <*> (parseJSONBase16 =<< v .: "cborHex") + where + parseJSONBase16 v = + either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v textEnvelopeJSONConfig :: Config -textEnvelopeJSONConfig = defConfig { confCompare = textEnvelopeJSONKeyOrder } +textEnvelopeJSONConfig = defConfig {confCompare = textEnvelopeJSONKeyOrder} textEnvelopeJSONKeyOrder :: Text -> Text -> Ordering textEnvelopeJSONKeyOrder = keyOrder ["type", "description", "cborHex"] - textEnvelopeRawCBOR :: TextEnvelope -> ByteString textEnvelopeRawCBOR = teRawCBOR - -- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return. --- data TextEnvelopeError - = TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType -- ^ expected, actual + = -- | expected, actual + TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType | TextEnvelopeDecodeError !DecoderError | TextEnvelopeAesonDecodeError !String deriving (Eq, Show, Data) @@ -140,7 +138,6 @@ instance Error TextEnvelopeError where , " Expected: " <> pretty expType , " Actual: " <> pretty actType ] - TextEnvelopeTypeError expTypes (TextEnvelopeType actType) -> mconcat [ "TextEnvelope type error: " @@ -153,15 +150,13 @@ instance Error TextEnvelopeError where TextEnvelopeDecodeError decErr -> "TextEnvelope decode error: " <> pshow decErr - -- | Check that the \"type\" of the 'TextEnvelope' is as expected. -- -- For example, one might check that the type is \"TxSignedShelley\". --- expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError () -expectTextEnvelopeOfType expectedType TextEnvelope { teType = actualType } = - unless (expectedType `legacyComparison` actualType) $ - Left (TextEnvelopeTypeError [expectedType] actualType) +expectTextEnvelopeOfType expectedType TextEnvelope {teType = actualType} = + unless (expectedType `legacyComparison` actualType) $ + Left (TextEnvelopeTypeError [expectedType] actualType) -- | This is a backwards-compatibility patch to ensure that old envelopes -- generated by 'serialiseTxLedgerCddl' can be deserialised after switching @@ -183,18 +178,18 @@ legacyComparison (TextEnvelopeType expectedType) (TextEnvelopeType actualType) = ("Tx ConwayEra", "Unwitnessed Tx ConwayEra") -> True (expectedOther, expectedActual) -> expectedOther == expectedActual - -- ---------------------------------------------------------------------------- -- Serialisation in text envelope format -- class SerialiseAsCBOR a => HasTextEnvelope a where - textEnvelopeType :: AsType a -> TextEnvelopeType + textEnvelopeType :: AsType a -> TextEnvelopeType - textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr - textEnvelopeDefaultDescr _ = "" + textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr + textEnvelopeDefaultDescr _ = "" -textEnvelopeTypeInEra :: () +textEnvelopeTypeInEra + :: () => HasTextEnvelope (f era) => CardanoEra era -> AsType (f era) @@ -202,90 +197,95 @@ textEnvelopeTypeInEra :: () textEnvelopeTypeInEra _ = textEnvelopeType -serialiseToTextEnvelope :: forall a. HasTextEnvelope a - => Maybe TextEnvelopeDescr -> a -> TextEnvelope +serialiseToTextEnvelope + :: forall a + . HasTextEnvelope a + => Maybe TextEnvelopeDescr -> a -> TextEnvelope serialiseToTextEnvelope mbDescr a = - TextEnvelope { - teType = textEnvelopeType ttoken - , teDescription = fromMaybe (textEnvelopeDefaultDescr a) mbDescr + TextEnvelope + { teType = textEnvelopeType ttoken + , teDescription = fromMaybe (textEnvelopeDefaultDescr a) mbDescr , teRawCBOR = serialiseToCBOR a } - where - ttoken :: AsType a - ttoken = proxyToAsType Proxy - - -deserialiseFromTextEnvelope :: HasTextEnvelope a - => AsType a - -> TextEnvelope - -> Either TextEnvelopeError a + where + ttoken :: AsType a + ttoken = proxyToAsType Proxy + +deserialiseFromTextEnvelope + :: HasTextEnvelope a + => AsType a + -> TextEnvelope + -> Either TextEnvelopeError a deserialiseFromTextEnvelope ttoken te = do - expectTextEnvelopeOfType (textEnvelopeType ttoken) te - first TextEnvelopeDecodeError $ - deserialiseFromCBOR ttoken (teRawCBOR te) --TODO: You have switched from CBOR to JSON - - -deserialiseFromTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b] - -> TextEnvelope - -> Either TextEnvelopeError b + expectTextEnvelopeOfType (textEnvelopeType ttoken) te + first TextEnvelopeDecodeError $ + deserialiseFromCBOR ttoken (teRawCBOR te) -- TODO: You have switched from CBOR to JSON + +deserialiseFromTextEnvelopeAnyOf + :: [FromSomeType HasTextEnvelope b] + -> TextEnvelope + -> Either TextEnvelopeError b deserialiseFromTextEnvelopeAnyOf types te = - case List.find matching types of - Nothing -> - Left (TextEnvelopeTypeError expectedTypes actualType) - - Just (FromSomeType ttoken f) -> - first TextEnvelopeDecodeError $ - f <$> deserialiseFromCBOR ttoken (teRawCBOR te) - where - actualType = teType te - expectedTypes = [ textEnvelopeType ttoken - | FromSomeType ttoken _f <- types ] - - matching (FromSomeType ttoken _f) = textEnvelopeType ttoken `legacyComparison` actualType - -writeFileTextEnvelope :: HasTextEnvelope a - => File content Out - -> Maybe TextEnvelopeDescr - -> a - -> IO (Either (FileError ()) ()) + case List.find matching types of + Nothing -> + Left (TextEnvelopeTypeError expectedTypes actualType) + Just (FromSomeType ttoken f) -> + first TextEnvelopeDecodeError $ + f <$> deserialiseFromCBOR ttoken (teRawCBOR te) + where + actualType = teType te + expectedTypes = + [ textEnvelopeType ttoken + | FromSomeType ttoken _f <- types + ] + + matching (FromSomeType ttoken _f) = textEnvelopeType ttoken `legacyComparison` actualType + +writeFileTextEnvelope + :: HasTextEnvelope a + => File content Out + -> Maybe TextEnvelopeDescr + -> a + -> IO (Either (FileError ()) ()) writeFileTextEnvelope outputFile mbDescr a = writeLazyByteStringFile outputFile (textEnvelopeToJSON mbDescr a) -textEnvelopeToJSON :: HasTextEnvelope a => Maybe TextEnvelopeDescr -> a -> LBS.ByteString -textEnvelopeToJSON mbDescr a = +textEnvelopeToJSON :: HasTextEnvelope a => Maybe TextEnvelopeDescr -> a -> LBS.ByteString +textEnvelopeToJSON mbDescr a = encodePretty' textEnvelopeJSONConfig (serialiseToTextEnvelope mbDescr a) <> "\n" -readFileTextEnvelope :: HasTextEnvelope a - => AsType a - -> File content In - -> IO (Either (FileError TextEnvelopeError) a) +readFileTextEnvelope + :: HasTextEnvelope a + => AsType a + -> File content In + -> IO (Either (FileError TextEnvelopeError) a) readFileTextEnvelope ttoken path = - runExceptT $ do - content <- fileIOExceptT (unFile path) readFileBlocking - firstExceptT (FileError (unFile path)) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelope ttoken te - - -readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b] - -> File content In - -> IO (Either (FileError TextEnvelopeError) b) + runExceptT $ do + content <- fileIOExceptT (unFile path) readFileBlocking + firstExceptT (FileError (unFile path)) $ hoistEither $ do + te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content + deserialiseFromTextEnvelope ttoken te + +readFileTextEnvelopeAnyOf + :: [FromSomeType HasTextEnvelope b] + -> File content In + -> IO (Either (FileError TextEnvelopeError) b) readFileTextEnvelopeAnyOf types path = - runExceptT $ do - content <- fileIOExceptT (unFile path) readFileBlocking - firstExceptT (FileError (unFile path)) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelopeAnyOf types te - + runExceptT $ do + content <- fileIOExceptT (unFile path) readFileBlocking + firstExceptT (FileError (unFile path)) $ hoistEither $ do + te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content + deserialiseFromTextEnvelopeAnyOf types te -readTextEnvelopeFromFile :: FilePath - -> IO (Either (FileError TextEnvelopeError) TextEnvelope) +readTextEnvelopeFromFile + :: FilePath + -> IO (Either (FileError TextEnvelopeError) TextEnvelope) readTextEnvelopeFromFile path = runExceptT $ do bs <- fileIOExceptT path readFileBlocking firstExceptT (FileError path . TextEnvelopeAesonDecodeError) - . hoistEither $ Aeson.eitherDecodeStrict' bs - + . hoistEither + $ Aeson.eitherDecodeStrict' bs readTextEnvelopeOfTypeFromFile :: TextEnvelopeType @@ -294,7 +294,7 @@ readTextEnvelopeOfTypeFromFile readTextEnvelopeOfTypeFromFile expectedType path = runExceptT $ do te <- ExceptT (readTextEnvelopeFromFile path) - firstExceptT (FileError path) $ hoistEither $ - expectTextEnvelopeOfType expectedType te + firstExceptT (FileError path) $ + hoistEither $ + expectTextEnvelopeOfType expectedType te return te - diff --git a/cardano-api/internal/Cardano/Api/SerialiseUsing.hs b/cardano-api/internal/Cardano/Api/SerialiseUsing.hs index c97995d068..1bd3d8f26f 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseUsing.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseUsing.hs @@ -1,50 +1,47 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Raw binary serialisation --- module Cardano.Api.SerialiseUsing - ( UsingRawBytes(..) - , UsingRawBytesHex(..) - , UsingBech32(..) - ) where - -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw - + ( UsingRawBytes (..) + , UsingRawBytesHex (..) + , UsingBech32 (..) + ) +where + +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw import qualified Data.Aeson.Types as Aeson -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BSC -import Data.String (IsString (..)) +import Data.String (IsString (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Typeable (tyConName, typeRep, typeRepTyCon) +import Data.Typeable (tyConName, typeRep, typeRepTyCon) -- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances, -- based on the 'SerialiseAsRawBytes' instance. -- -- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah) --- newtype UsingRawBytes a = UsingRawBytes a instance SerialiseAsRawBytes a => ToCBOR (UsingRawBytes a) where - toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x) + toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x) instance SerialiseAsRawBytes a => FromCBOR (UsingRawBytes a) where - fromCBOR = do - bs <- fromCBOR - case deserialiseFromRawBytes ttoken bs of - Right x -> return (UsingRawBytes x) - Left (SerialiseAsRawBytesError msg) -> fail ("cannot deserialise as a " ++ tname ++ ". The error was: " ++ msg) - where - ttoken = proxyToAsType (Proxy :: Proxy a) - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - + fromCBOR = do + bs <- fromCBOR + case deserialiseFromRawBytes ttoken bs of + Right x -> return (UsingRawBytes x) + Left (SerialiseAsRawBytesError msg) -> fail ("cannot deserialise as a " ++ tname ++ ". The error was: " ++ msg) + where + ttoken = proxyToAsType (Proxy :: Proxy a) + tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) -- | For use with @deriving via@, to provide instances for any\/all of 'Show', -- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex @@ -53,46 +50,43 @@ instance SerialiseAsRawBytes a => FromCBOR (UsingRawBytes a) where -- > deriving (Show, IsString) via (UsingRawBytesHex Blah) -- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah) -- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah) --- newtype UsingRawBytesHex a = UsingRawBytesHex a instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where - show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x) + show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x) instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where - fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack + fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where - toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x) + toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x) instance SerialiseAsRawBytes a => FromJSON (UsingRawBytesHex a) where parseJSON = Aeson.withText tname $ either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 - where - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) + where + tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where toJSONKey = Aeson.toJSONKeyText $ \(UsingRawBytesHex x) -> serialiseToRawBytesHexText x instance SerialiseAsRawBytes a => FromJSONKey (UsingRawBytesHex a) where - fromJSONKey = Aeson.FromJSONKeyTextParser $ - either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 + either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 -deserialiseFromRawBytesBase16 :: - SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a) +deserialiseFromRawBytesBase16 + :: SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a) deserialiseFromRawBytesBase16 str = case Base16.decode str of Right raw -> case deserialiseFromRawBytes ttoken raw of - Right x -> Right (UsingRawBytesHex x) + Right x -> Right (UsingRawBytesHex x) Left (SerialiseAsRawBytesError msg) -> Left ("cannot deserialise " ++ show str ++ ". The error was: " <> msg) - Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg) - where - ttoken = proxyToAsType (Proxy :: Proxy a) - + Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg) + where + ttoken = proxyToAsType (Proxy :: Proxy a) -- | For use with @deriving via@, to provide instances for any\/all of 'Show', -- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a bech32 @@ -101,35 +95,36 @@ deserialiseFromRawBytesBase16 str = -- > deriving (Show, IsString) via (UsingBech32 Blah) -- > deriving (ToJSON, FromJSON) via (UsingBech32 Blah) -- > deriving (ToJSONKey, FromJSONKey) via (UsingBech32 Blah) --- newtype UsingBech32 a = UsingBech32 a instance SerialiseAsBech32 a => Show (UsingBech32 a) where - show (UsingBech32 x) = show (serialiseToBech32 x) + show (UsingBech32 x) = show (serialiseToBech32 x) instance SerialiseAsBech32 a => IsString (UsingBech32 a) where - fromString str = - case deserialiseFromBech32 ttoken (Text.pack str) of - Right x -> UsingBech32 x - Left e -> - error $ docToString $ + fromString str = + case deserialiseFromBech32 ttoken (Text.pack str) of + Right x -> UsingBech32 x + Left e -> + error $ + docToString $ "fromString: " <> pretty str <> ": " <> prettyError e - where - ttoken :: AsType a - ttoken = proxyToAsType Proxy + where + ttoken :: AsType a + ttoken = proxyToAsType Proxy instance SerialiseAsBech32 a => ToJSON (UsingBech32 a) where - toJSON (UsingBech32 x) = toJSON (serialiseToBech32 x) + toJSON (UsingBech32 x) = toJSON (serialiseToBech32 x) instance SerialiseAsBech32 a => FromJSON (UsingBech32 a) where - parseJSON = - Aeson.withText tname $ \str -> - case deserialiseFromBech32 ttoken str of - Right x -> return (UsingBech32 x) - Left e -> fail $ docToString $ pretty str <> ": " <> prettyError e - where - ttoken = proxyToAsType (Proxy :: Proxy a) - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) + parseJSON = + Aeson.withText tname $ \str -> + case deserialiseFromBech32 ttoken str of + Right x -> return (UsingBech32 x) + Left e -> fail $ docToString $ pretty str <> ": " <> prettyError e + where + ttoken = proxyToAsType (Proxy :: Proxy a) + tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) instance SerialiseAsBech32 a => ToJSONKey (UsingBech32 a) + instance SerialiseAsBech32 a => FromJSONKey (UsingBech32 a) diff --git a/cardano-api/internal/Cardano/Api/SpecialByron.hs b/cardano-api/internal/Cardano/Api/SpecialByron.hs index c35b1fbc44..8493000d19 100644 --- a/cardano-api/internal/Cardano/Api/SpecialByron.hs +++ b/cardano-api/internal/Cardano/Api/SpecialByron.hs @@ -2,54 +2,68 @@ -- | Special Byron values that we can submit to a node to propose an update proposal -- or to vote on an update proposal. These are not transactions. --- module Cardano.Api.SpecialByron - ( ByronUpdateProposal(..), - ByronProtocolParametersUpdate(..), - AsType(AsByronUpdateProposal, AsByronVote), - makeProtocolParametersUpdate, - toByronLedgerUpdateProposal, - ByronVote(..), - makeByronUpdateProposal, - makeByronVote, - toByronLedgertoByronVote, - applicationName, - applicationVersion, - softwareVersion - ) where - -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.NetworkId (NetworkId, toByronProtocolMagicId) -import Cardano.Api.SerialiseRaw - + ( ByronUpdateProposal (..) + , ByronProtocolParametersUpdate (..) + , AsType (AsByronUpdateProposal, AsByronVote) + , makeProtocolParametersUpdate + , toByronLedgerUpdateProposal + , ByronVote (..) + , makeByronUpdateProposal + , makeByronVote + , toByronLedgertoByronVote + , applicationName + , applicationVersion + , softwareVersion + ) +where + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Byron +import Cardano.Api.NetworkId (NetworkId, toByronProtocolMagicId) +import Cardano.Api.SerialiseRaw import qualified Cardano.Binary as Binary -import Cardano.Chain.Common (LovelacePortion, TxFeePolicy) -import Cardano.Chain.Slotting -import Cardano.Chain.Update (AProposal (aBody, annotation), InstallerHash, - ProposalBody (ProposalBody), ProtocolParametersUpdate (..), ProtocolVersion, - SoftforkRule, SoftwareVersion, SystemTag, UpId, mkVote, recoverUpId, - recoverVoteId, signProposal) +import Cardano.Chain.Common (LovelacePortion, TxFeePolicy) +import Cardano.Chain.Slotting +import Cardano.Chain.Update + ( AProposal (aBody, annotation) + , InstallerHash + , ProposalBody (ProposalBody) + , ProtocolParametersUpdate (..) + , ProtocolVersion + , SoftforkRule + , SoftwareVersion + , SystemTag + , UpId + , mkVote + , recoverUpId + , recoverVoteId + , signProposal + ) import qualified Cardano.Chain.Update as Update import qualified Cardano.Chain.Update.Vote as ByronVote -import Cardano.Crypto (SafeSigner, noPassSafeSigner) -import qualified Cardano.Ledger.Binary as Binary (Annotated (..), ByteSpan (..), annotation, - annotationBytes, byronProtVer, reAnnotate) -import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) -import qualified Ouroboros.Consensus.Byron.Ledger.Mempool as Mempool - -import Data.ByteString (ByteString) +import Cardano.Crypto (SafeSigner, noPassSafeSigner) +import qualified Cardano.Ledger.Binary as Binary + ( Annotated (..) + , ByteSpan (..) + , annotation + , annotationBytes + , byronProtVer + , reAnnotate + ) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import qualified Data.Map.Strict as M -import Data.Word -import Numeric.Natural +import Data.Word +import Numeric.Natural +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import qualified Ouroboros.Consensus.Byron.Ledger.Mempool as Mempool {- HLINT ignore "Use void" -} -- | Byron era update proposal - -newtype ByronUpdateProposal = - ByronUpdateProposal { unByronUpdateProposal :: AProposal ByteString} +newtype ByronUpdateProposal + = ByronUpdateProposal {unByronUpdateProposal :: AProposal ByteString} deriving (Eq, Show) instance HasTypeProxy ByronUpdateProposal where @@ -60,10 +74,10 @@ instance SerialiseAsRawBytes ByronUpdateProposal where serialiseToRawBytes (ByronUpdateProposal proposal) = annotation proposal deserialiseFromRawBytes AsByronUpdateProposal bs = let lBs = LB.fromStrict bs - in case Binary.decodeFull lBs of - Left e -> Left $ SerialiseAsRawBytesError $ "Unable to deserialise ByronUpdateProposal: " <> show e - Right proposal -> Right (ByronUpdateProposal proposal') - where + in case Binary.decodeFull lBs of + Left e -> Left $ SerialiseAsRawBytesError $ "Unable to deserialise ByronUpdateProposal: " <> show e + Right proposal -> Right (ByronUpdateProposal proposal') + where proposal' :: AProposal ByteString proposal' = Binary.annotationBytes lBs proposal @@ -76,64 +90,72 @@ makeByronUpdateProposal -> SomeByronSigningKey -> ByronProtocolParametersUpdate -> ByronUpdateProposal -makeByronUpdateProposal nId pVer sVer sysTag insHash - bWit paramsToUpdate = - let nonAnnotatedProposal :: AProposal () - nonAnnotatedProposal = signProposal (toByronProtocolMagicId nId) proposalBody noPassSigningKey - annotatedPropBody :: Binary.Annotated ProposalBody ByteString - annotatedPropBody = Binary.reAnnotate Binary.byronProtVer $ aBody nonAnnotatedProposal - in ByronUpdateProposal - $ nonAnnotatedProposal { aBody = annotatedPropBody - , annotation = Binary.serialize' nonAnnotatedProposal - } - where - proposalBody :: ProposalBody - proposalBody = ProposalBody pVer protocolParamsUpdate sVer metaData - - metaData :: M.Map SystemTag InstallerHash - metaData = M.singleton sysTag insHash - - noPassSigningKey :: SafeSigner - noPassSigningKey = noPassSafeSigner $ toByronSigningKey bWit - - protocolParamsUpdate :: ProtocolParametersUpdate - protocolParamsUpdate = makeProtocolParametersUpdate paramsToUpdate - -data ByronProtocolParametersUpdate = - ByronProtocolParametersUpdate - { bPpuScriptVersion :: !(Maybe Word16) - -- ^ Redundant. This was meant to be the version of the - -- Plutus smart contract language, however, there are no - -- smart contracts nor scripts in the Byron era. - , bPpuSlotDuration :: !(Maybe Natural) - -- ^ Slot duration in milliseconds. - , bPpuMaxBlockSize :: !(Maybe Natural) - -- ^ Maximum block size in bytes. - , bPpuMaxHeaderSize :: !(Maybe Natural) - -- ^ Maximum block header size in bytes. - , bPpuMaxTxSize :: !(Maybe Natural) - -- ^ Maximum transaction size in bytes. - , bPpuMaxProposalSize :: !(Maybe Natural) - -- ^ Maximum update proposal size in bytes. - , bPpuMpcThd :: !(Maybe LovelacePortion) - , bPpuHeavyDelThd :: !(Maybe LovelacePortion) - -- ^ Heavyweight delegation threshold. The delegate (i.e stakeholder) - -- must possess no less than this threshold of stake in order to participate - -- in heavyweight delegation. - , bPpuUpdateVoteThd :: !(Maybe LovelacePortion) - , bPpuUpdateProposalThd :: !(Maybe LovelacePortion) - , bPpuUpdateProposalTTL :: !(Maybe SlotNumber) - , bPpuSoftforkRule :: !(Maybe SoftforkRule) - -- ^ Values defining the softfork resolution rule. When the stake belonging - -- to block issuers, issuing a given block version, is greater than the - -- current softfork resolution threshold, this block version is adopted. - , bPpuTxFeePolicy :: !(Maybe TxFeePolicy) - -- ^ Transaction fee policy represents a formula to compute the minimal allowed - -- Fee for a transaction. Transactions with lesser fees won't be accepted. - , bPpuUnlockStakeEpoch :: !(Maybe EpochNumber) - -- ^ This has been re-purposed for unlocking the OuroborosBFT logic in the software. - -- Relevant: [CDEC-610](https://iohk.myjetbrains.com/youtrack/issue/CDEC-610) - } deriving Show +makeByronUpdateProposal + nId + pVer + sVer + sysTag + insHash + bWit + paramsToUpdate = + let nonAnnotatedProposal :: AProposal () + nonAnnotatedProposal = signProposal (toByronProtocolMagicId nId) proposalBody noPassSigningKey + annotatedPropBody :: Binary.Annotated ProposalBody ByteString + annotatedPropBody = Binary.reAnnotate Binary.byronProtVer $ aBody nonAnnotatedProposal + in ByronUpdateProposal $ + nonAnnotatedProposal + { aBody = annotatedPropBody + , annotation = Binary.serialize' nonAnnotatedProposal + } + where + proposalBody :: ProposalBody + proposalBody = ProposalBody pVer protocolParamsUpdate sVer metaData + + metaData :: M.Map SystemTag InstallerHash + metaData = M.singleton sysTag insHash + + noPassSigningKey :: SafeSigner + noPassSigningKey = noPassSafeSigner $ toByronSigningKey bWit + + protocolParamsUpdate :: ProtocolParametersUpdate + protocolParamsUpdate = makeProtocolParametersUpdate paramsToUpdate + +data ByronProtocolParametersUpdate + = ByronProtocolParametersUpdate + { bPpuScriptVersion :: !(Maybe Word16) + -- ^ Redundant. This was meant to be the version of the + -- Plutus smart contract language, however, there are no + -- smart contracts nor scripts in the Byron era. + , bPpuSlotDuration :: !(Maybe Natural) + -- ^ Slot duration in milliseconds. + , bPpuMaxBlockSize :: !(Maybe Natural) + -- ^ Maximum block size in bytes. + , bPpuMaxHeaderSize :: !(Maybe Natural) + -- ^ Maximum block header size in bytes. + , bPpuMaxTxSize :: !(Maybe Natural) + -- ^ Maximum transaction size in bytes. + , bPpuMaxProposalSize :: !(Maybe Natural) + -- ^ Maximum update proposal size in bytes. + , bPpuMpcThd :: !(Maybe LovelacePortion) + , bPpuHeavyDelThd :: !(Maybe LovelacePortion) + -- ^ Heavyweight delegation threshold. The delegate (i.e stakeholder) + -- must possess no less than this threshold of stake in order to participate + -- in heavyweight delegation. + , bPpuUpdateVoteThd :: !(Maybe LovelacePortion) + , bPpuUpdateProposalThd :: !(Maybe LovelacePortion) + , bPpuUpdateProposalTTL :: !(Maybe SlotNumber) + , bPpuSoftforkRule :: !(Maybe SoftforkRule) + -- ^ Values defining the softfork resolution rule. When the stake belonging + -- to block issuers, issuing a given block version, is greater than the + -- current softfork resolution threshold, this block version is adopted. + , bPpuTxFeePolicy :: !(Maybe TxFeePolicy) + -- ^ Transaction fee policy represents a formula to compute the minimal allowed + -- Fee for a transaction. Transactions with lesser fees won't be accepted. + , bPpuUnlockStakeEpoch :: !(Maybe EpochNumber) + -- ^ This has been re-purposed for unlocking the OuroborosBFT logic in the software. + -- Relevant: [CDEC-610](https://iohk.myjetbrains.com/youtrack/issue/CDEC-610) + } + deriving (Show) makeProtocolParametersUpdate :: ByronProtocolParametersUpdate @@ -161,8 +183,7 @@ toByronLedgerUpdateProposal (ByronUpdateProposal proposal) = Mempool.ByronUpdateProposal (recoverUpId proposal) proposal -- | Byron era votes - -newtype ByronVote = ByronVote { unByronVote :: ByronVote.AVote ByteString } +newtype ByronVote = ByronVote {unByronVote :: ByronVote.AVote ByteString} deriving (Eq, Show) instance HasTypeProxy ByronVote where @@ -173,14 +194,13 @@ instance SerialiseAsRawBytes ByronVote where serialiseToRawBytes (ByronVote vote) = Binary.serialize' $ fmap (const ()) vote deserialiseFromRawBytes AsByronVote bs = let lBs = LB.fromStrict bs - in case Binary.decodeFull lBs of - Left e -> Left $ SerialiseAsRawBytesError $ "Unable to deserialise ByronVote: " <> show e - Right vote -> Right . ByronVote $ annotateVote vote lBs + in case Binary.decodeFull lBs of + Left e -> Left $ SerialiseAsRawBytesError $ "Unable to deserialise ByronVote: " <> show e + Right vote -> Right . ByronVote $ annotateVote vote lBs where annotateVote :: ByronVote.AVote Binary.ByteSpan -> LB.ByteString -> ByronVote.AVote ByteString annotateVote vote bs' = Binary.annotationBytes bs' vote - makeByronVote :: NetworkId -> SomeByronSigningKey @@ -194,10 +214,11 @@ makeByronVote nId sKey (ByronUpdateProposal proposal) yesOrNo = annotatedProposalId :: Binary.Annotated UpId ByteString annotatedProposalId = Binary.reAnnotate Binary.byronProtVer $ ByronVote.aProposalId nonAnnotatedVote - in ByronVote - $ nonAnnotatedVote { ByronVote.aProposalId = annotatedProposalId - , ByronVote.annotation = Binary.annotation annotatedProposalId - } + in ByronVote $ + nonAnnotatedVote + { ByronVote.aProposalId = annotatedProposalId + , ByronVote.annotation = Binary.annotation annotatedProposalId + } toByronLedgertoByronVote :: ByronVote -> Mempool.GenTx ByronBlock toByronLedgertoByronVote (ByronVote vote) = Mempool.ByronUpdateVote (recoverVoteId vote) vote diff --git a/cardano-api/internal/Cardano/Api/StakePoolMetadata.hs b/cardano-api/internal/Cardano/Api/StakePoolMetadata.hs index fb669a6bde..a572294f98 100644 --- a/cardano-api/internal/Cardano/Api/StakePoolMetadata.hs +++ b/cardano-api/internal/Cardano/Api/StakePoolMetadata.hs @@ -4,132 +4,127 @@ {-# LANGUAGE TypeFamilies #-} -- | Stake pool off-chain metadata --- -module Cardano.Api.StakePoolMetadata ( - -- * Stake pool off-chain metadata - StakePoolMetadata(..), - validateAndHashStakePoolMetadata, - StakePoolMetadataValidationError(..), +module Cardano.Api.StakePoolMetadata + ( -- * Stake pool off-chain metadata + StakePoolMetadata (..) + , validateAndHashStakePoolMetadata + , StakePoolMetadataValidationError (..) -- * Data family instances - AsType(..), - Hash(..), - ) where - -import Cardano.Api.Eras -import Cardano.Api.Error -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Praos -import Cardano.Api.Script -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw - + , AsType (..) + , Hash (..) + ) +where + +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Praos +import Cardano.Api.Script +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley - -import Data.Aeson ((.:)) +import Data.Aeson ((.:)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.Bifunctor (first) -import Data.ByteString (ByteString) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Data (Data) -import Data.Either.Combinators (maybeToRight) -import Data.Text (Text) +import Data.Data (Data) +import Data.Either.Combinators (maybeToRight) +import Data.Text (Text) import qualified Data.Text as Text -import Prettyprinter +import Prettyprinter -- ---------------------------------------------------------------------------- -- Stake pool metadata -- -- | A representation of the required fields for off-chain stake pool metadata. --- -data StakePoolMetadata = - StakePoolMetadata { - - -- | A name of up to 50 characters. - stakePoolName :: !Text - - -- | A description of up to 255 characters. - , stakePoolDescription :: !Text - - -- | A ticker of 3-5 characters, for a compact display of stake pools in - -- a wallet. - , stakePoolTicker :: !Text - - -- | A URL to a homepage with additional information about the pool. - -- n.b. the spec does not specify a character limit for this field. - , stakePoolHomepage :: !Text - } +data StakePoolMetadata + = StakePoolMetadata + { stakePoolName :: !Text + -- ^ A name of up to 50 characters. + , stakePoolDescription :: !Text + -- ^ A description of up to 255 characters. + , stakePoolTicker :: !Text + -- ^ A ticker of 3-5 characters, for a compact display of stake pools in + -- a wallet. + , stakePoolHomepage :: !Text + -- ^ A URL to a homepage with additional information about the pool. + -- n.b. the spec does not specify a character limit for this field. + } deriving (Eq, Show) -newtype instance Hash StakePoolMetadata = - StakePoolMetadataHash (Shelley.Hash StandardCrypto ByteString) - deriving (Eq, Show) +newtype instance Hash StakePoolMetadata + = StakePoolMetadataHash (Shelley.Hash StandardCrypto ByteString) + deriving (Eq, Show) instance HasTypeProxy StakePoolMetadata where - data AsType StakePoolMetadata = AsStakePoolMetadata - proxyToAsType _ = AsStakePoolMetadata + data AsType StakePoolMetadata = AsStakePoolMetadata + proxyToAsType _ = AsStakePoolMetadata instance SerialiseAsRawBytes (Hash StakePoolMetadata) where - serialiseToRawBytes (StakePoolMetadataHash h) = Crypto.hashToBytes h + serialiseToRawBytes (StakePoolMetadataHash h) = Crypto.hashToBytes h - deserialiseFromRawBytes (AsHash AsStakePoolMetadata) bs = - maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakePoolMetadata") $ - StakePoolMetadataHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsStakePoolMetadata) bs = + maybeToRight (SerialiseAsRawBytesError "Unable to deserialise Hash StakePoolMetadata") $ + StakePoolMetadataHash <$> Crypto.hashFromBytes bs ---TODO: instance ToJSON StakePoolMetadata where +-- TODO: instance ToJSON StakePoolMetadata where instance FromJSON StakePoolMetadata where - parseJSON = - Aeson.withObject "StakePoolMetadata" $ \obj -> - StakePoolMetadata - <$> parseName obj - <*> parseDescription obj - <*> parseTicker obj - <*> obj .: "homepage" - - where - -- Parse and validate the stake pool metadata name from a JSON object. - -- The name must be 50 characters or fewer. - -- - parseName :: Aeson.Object -> Aeson.Parser Text - parseName obj = do - name <- obj .: "name" - if Text.length name <= 50 - then pure name - else fail $ "\"name\" must have at most 50 characters, but it has " - <> show (Text.length name) - <> " characters." - - -- Parse and validate the stake pool metadata description - -- The description must be 255 characters or fewer. - -- - parseDescription :: Aeson.Object -> Aeson.Parser Text - parseDescription obj = do - description <- obj .: "description" - if Text.length description <= 255 - then pure description - else fail $ - "\"description\" must have at most 255 characters, but it has " + parseJSON = + Aeson.withObject "StakePoolMetadata" $ \obj -> + StakePoolMetadata + <$> parseName obj + <*> parseDescription obj + <*> parseTicker obj + <*> obj .: "homepage" + where + -- Parse and validate the stake pool metadata name from a JSON object. + -- The name must be 50 characters or fewer. + -- + parseName :: Aeson.Object -> Aeson.Parser Text + parseName obj = do + name <- obj .: "name" + if Text.length name <= 50 + then pure name + else + fail $ + "\"name\" must have at most 50 characters, but it has " + <> show (Text.length name) + <> " characters." + + -- Parse and validate the stake pool metadata description + -- The description must be 255 characters or fewer. + -- + parseDescription :: Aeson.Object -> Aeson.Parser Text + parseDescription obj = do + description <- obj .: "description" + if Text.length description <= 255 + then pure description + else + fail $ + "\"description\" must have at most 255 characters, but it has " <> show (Text.length description) <> " characters." - -- | Parse and validate the stake pool ticker description - -- The ticker must be 3 to 5 characters long. - -- - parseTicker :: Aeson.Object -> Aeson.Parser Text - parseTicker obj = do - ticker <- obj .: "ticker" - let tickerLen = Text.length ticker - if tickerLen >= 3 && tickerLen <= 5 - then pure ticker - else fail $ - "\"ticker\" must have at least 3 and at most 5 " + -- \| Parse and validate the stake pool ticker description + -- The ticker must be 3 to 5 characters long. + parseTicker :: Aeson.Object -> Aeson.Parser Text + parseTicker obj = do + ticker <- obj .: "ticker" + let tickerLen = Text.length ticker + if tickerLen >= 3 && tickerLen <= 5 + then pure ticker + else + fail $ + "\"ticker\" must have at least 3 and at most 5 " <> "characters, but it has " <> show (Text.length ticker) <> " characters." @@ -137,9 +132,9 @@ instance FromJSON StakePoolMetadata where -- | A stake pool metadata validation error. data StakePoolMetadataValidationError = StakePoolMetadataJsonDecodeError !String - | StakePoolMetadataInvalidLengthError - -- ^ The length of the JSON-encoded stake pool metadata exceeds the + | -- | The length of the JSON-encoded stake pool metadata exceeds the -- maximum. + StakePoolMetadataInvalidLengthError !Int -- ^ Maximum byte length. !Int @@ -161,16 +156,17 @@ instance Error StakePoolMetadataValidationError where -- | Decode and validate the provided JSON-encoded bytes as 'StakePoolMetadata'. -- Return the decoded metadata and the hash of the original bytes. --- validateAndHashStakePoolMetadata :: ByteString - -> Either StakePoolMetadataValidationError - (StakePoolMetadata, Hash StakePoolMetadata) + -> Either + StakePoolMetadataValidationError + (StakePoolMetadata, Hash StakePoolMetadata) validateAndHashStakePoolMetadata bs | BS.length bs <= 512 = do - md <- first StakePoolMetadataJsonDecodeError - (Aeson.eitherDecodeStrict' bs) + md <- + first + StakePoolMetadataJsonDecodeError + (Aeson.eitherDecodeStrict' bs) let mdh = StakePoolMetadataHash (Crypto.hashWith id bs) return (md, mdh) | otherwise = Left $ StakePoolMetadataInvalidLengthError 512 (BS.length bs) - diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 4132336c42..6278a238da 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -19,181 +19,180 @@ {- HLINT ignore "Redundant bracket" -} -- | Transaction bodies -module Cardano.Api.Tx.Body ( - parseTxId, +module Cardano.Api.Tx.Body + ( parseTxId + -- * Transaction bodies - TxBody(.., TxBody), - createTransactionBody, - createAndValidateTransactionBody, - TxBodyContent(..), + , TxBody (.., TxBody) + , createTransactionBody + , createAndValidateTransactionBody + , TxBodyContent (..) -- * Byron only - makeByronTransactionBody, + , makeByronTransactionBody -- ** Transaction body builders - defaultTxBodyContent, - defaultTxFee, - defaultTxValidityUpperBound, - setTxIns, - modTxIns, - addTxIn, - setTxInsCollateral, - setTxInsReference, - setTxOuts, - modTxOuts, - addTxOut, - setTxTotalCollateral, - setTxReturnCollateral, - setTxFee, - setTxValidityLowerBound, - setTxValidityUpperBound, - setTxMetadata, - setTxAuxScripts, - setTxExtraKeyWits, - setTxProtocolParams, - setTxWithdrawals, - setTxCertificates, - setTxUpdateProposal, - setTxMintValue, - setTxScriptValidity, - setTxCurrentTreasuryValue, - setTxTreasuryDonation, - TxBodyError(..), - TxBodyScriptData(..), - TxScriptValidity(..), - - ScriptValidity(..), - scriptValidityToIsValid, - isValidToScriptValidity, - txScriptValidityToIsValid, - txScriptValidityToScriptValidity, + , defaultTxBodyContent + , defaultTxFee + , defaultTxValidityUpperBound + , setTxIns + , modTxIns + , addTxIn + , setTxInsCollateral + , setTxInsReference + , setTxOuts + , modTxOuts + , addTxOut + , setTxTotalCollateral + , setTxReturnCollateral + , setTxFee + , setTxValidityLowerBound + , setTxValidityUpperBound + , setTxMetadata + , setTxAuxScripts + , setTxExtraKeyWits + , setTxProtocolParams + , setTxWithdrawals + , setTxCertificates + , setTxUpdateProposal + , setTxMintValue + , setTxScriptValidity + , setTxCurrentTreasuryValue + , setTxTreasuryDonation + , TxBodyError (..) + , TxBodyScriptData (..) + , TxScriptValidity (..) + , ScriptValidity (..) + , scriptValidityToIsValid + , isValidToScriptValidity + , txScriptValidityToIsValid + , txScriptValidityToScriptValidity -- * Transaction Ids - TxId(..), - getTxId, - getTxIdByron, - getTxIdShelley, + , TxId (..) + , getTxId + , getTxIdByron + , getTxIdShelley -- * Transaction inputs - TxIn(..), - TxIns, - TxIx(..), - genesisUTxOPseudoTxIn, - getReferenceInputsSizeForTxIds, + , TxIn (..) + , TxIns + , TxIx (..) + , genesisUTxOPseudoTxIn + , getReferenceInputsSizeForTxIds -- * Transaction outputs - CtxTx, CtxUTxO, - TxOut(..), - TxOutValue(..), - TxOutDatum(TxOutDatumNone, TxOutDatumHash, TxOutDatumInTx, TxOutDatumInline), - toCtxUTxOTxOut, - lovelaceToTxOutValue, - prettyRenderTxOut, - txOutValueToLovelace, - txOutValueToValue, - parseHash, - TxOutInAnyEra(..), - txOutInAnyEra, + , CtxTx + , CtxUTxO + , TxOut (..) + , TxOutValue (..) + , TxOutDatum (TxOutDatumNone, TxOutDatumHash, TxOutDatumInTx, TxOutDatumInline) + , toCtxUTxOTxOut + , lovelaceToTxOutValue + , prettyRenderTxOut + , txOutValueToLovelace + , txOutValueToValue + , parseHash + , TxOutInAnyEra (..) + , txOutInAnyEra -- * Other transaction body types - TxInsCollateral(..), - TxInsReference(..), - TxReturnCollateral(..), - TxTotalCollateral(..), - TxFee(..), - TxValidityLowerBound(..), - TxValidityUpperBound(..), - TxMetadataInEra(..), - TxAuxScripts(..), - TxExtraKeyWitnesses(..), - TxWithdrawals(..), - TxCertificates(..), - TxUpdateProposal(..), - TxMintValue(..), - TxVotingProcedures(..), - TxProposalProcedures(..), + , TxInsCollateral (..) + , TxInsReference (..) + , TxReturnCollateral (..) + , TxTotalCollateral (..) + , TxFee (..) + , TxValidityLowerBound (..) + , TxValidityUpperBound (..) + , TxMetadataInEra (..) + , TxAuxScripts (..) + , TxExtraKeyWitnesses (..) + , TxWithdrawals (..) + , TxCertificates (..) + , TxUpdateProposal (..) + , TxMintValue (..) + , TxVotingProcedures (..) + , TxProposalProcedures (..) -- ** Building vs viewing transactions - BuildTxWith(..), - BuildTx, - ViewTx, + , BuildTxWith (..) + , BuildTx + , ViewTx -- * Inspecting 'ScriptWitness'es - AnyScriptWitness(..), - ScriptWitnessIndex(..), - renderScriptWitnessIndex, - collectTxBodyScriptWitnesses, - toScriptIndex, + , AnyScriptWitness (..) + , ScriptWitnessIndex (..) + , renderScriptWitnessIndex + , collectTxBodyScriptWitnesses + , toScriptIndex -- * Conversion to inline data - scriptDataToInlineDatum, + , scriptDataToInlineDatum -- * Internal conversion functions & types - toByronTxId, - toShelleyTxId, - toShelleyTxIn, - toShelleyTxOut, - toShelleyTxOutAny, - fromShelleyTxId, - fromShelleyTxIn, - fromShelleyTxOut, - fromByronTxIn, - fromLedgerTxOuts, - renderTxIn, + , toByronTxId + , toShelleyTxId + , toShelleyTxIn + , toShelleyTxOut + , toShelleyTxOutAny + , fromShelleyTxId + , fromShelleyTxIn + , fromShelleyTxOut + , fromByronTxIn + , fromLedgerTxOuts + , renderTxIn -- * Misc helpers - calculateExecutionUnitsLovelace, - orderStakeAddrs, - orderTxIns, + , calculateExecutionUnitsLovelace + , orderStakeAddrs + , orderTxIns -- * Data family instances - AsType(AsTxId, AsTxBody, AsByronTxBody, AsShelleyTxBody, AsMaryTxBody), - - getTxBodyContent, - - -- Temp - validateTxIns, - guardShelleyTxInsOverflow, - validateTxOuts, - validateMetadata, - validateMintValue, - validateTxInsCollateral, - validateProtocolParameters, - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Eon.AllegraEraOnwards -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyToAllegraEra -import Cardano.Api.Eon.ShelleyToBabbageEra -import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Core -import Cardano.Api.Error (Error (..), displayError) -import Cardano.Api.Feature -import Cardano.Api.Hash -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Shelley + , AsType (AsTxId, AsTxBody, AsByronTxBody, AsShelleyTxBody, AsMaryTxBody) + , getTxBodyContent + -- Temp + , validateTxIns + , guardShelleyTxInsOverflow + , validateTxOuts + , validateMetadata + , validateMintValue + , validateTxInsCollateral + , validateProtocolParameters + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Eon.AllegraEraOnwards +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyToAllegraEra +import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eras.Case +import Cardano.Api.Eras.Core +import Cardano.Api.Error (Error (..), displayError) +import Cardano.Api.Feature +import Cardano.Api.Hash +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Shelley import qualified Cardano.Api.Ledger.Lens as A -import Cardano.Api.NetworkId -import Cardano.Api.Pretty -import Cardano.Api.ProtocolParameters +import Cardano.Api.NetworkId +import Cardano.Api.Pretty +import Cardano.Api.ProtocolParameters import qualified Cardano.Api.ReexposeLedger as Ledger -import Cardano.Api.Script -import Cardano.Api.ScriptData -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw -import Cardano.Api.Tx.Sign -import Cardano.Api.TxIn -import Cardano.Api.TxMetadata -import Cardano.Api.Utils -import Cardano.Api.Value -import Cardano.Api.ValueParser - +import Cardano.Api.Script +import Cardano.Api.ScriptData +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.Tx.Sign +import Cardano.Api.TxIn +import Cardano.Api.TxMetadata +import Cardano.Api.Utils +import Cardano.Api.Value +import Cardano.Api.ValueParser import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash.Class as Crypto @@ -205,18 +204,18 @@ import qualified Cardano.Ledger.Alonzo.Tx as Alonzo (hashScriptIntegrity) import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage.UTxO as L -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) -import Cardano.Ledger.Binary (Annotated (..)) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Binary (Annotated (..)) import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.Core as L -import Cardano.Ledger.Core () +import Cardano.Ledger.Core () import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Credential as Shelley -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley -import Cardano.Ledger.Mary.Value as L (MaryValue (..), MultiAsset) +import Cardano.Ledger.Mary.Value as L (MaryValue (..), MultiAsset) import qualified Cardano.Ledger.Plutus.Data as Plutus import qualified Cardano.Ledger.Plutus.Language as Plutus import qualified Cardano.Ledger.SafeHash as SafeHash @@ -224,70 +223,79 @@ import qualified Cardano.Ledger.Shelley.API as Ledger import qualified Cardano.Ledger.Shelley.Genesis as Shelley import qualified Cardano.Ledger.Shelley.TxCert as Shelley import qualified Cardano.Ledger.TxIn as L -import Cardano.Ledger.Val as L (isZero) -import Cardano.Slotting.Slot (SlotNo (..)) -import Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlonzo, StandardBabbage, - StandardConway, StandardMary, StandardShelley) - -import Control.Applicative (some) -import Control.Monad (guard, unless) -import Data.Aeson (object, withObject, (.:), (.:?), (.=)) +import Cardano.Ledger.Val as L (isZero) +import Cardano.Slotting.Slot (SlotNo (..)) +import Control.Applicative (some) +import Control.Monad (guard, unless) +import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as Aeson -import Data.Bifunctor (Bifunctor (..)) -import Data.ByteString (ByteString) +import Data.Bifunctor (Bifunctor (..)) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC -import Data.Foldable (for_, toList) -import Data.Function (on) -import Data.Functor (($>)) -import Data.List (sortBy) +import Data.Foldable (for_, toList) +import Data.Function (on) +import Data.Functor (($>)) +import Data.List (sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid -import Data.OSet.Strict (OSet) +import Data.Maybe +import Data.Monoid +import Data.OSet.Strict (OSet) import qualified Data.OSet.Strict as OSet -import Data.Scientific (toBoundedInteger) +import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq -import Data.Set (Set) +import Data.Set (Set) import qualified Data.Set as Set -import Data.String -import Data.Text (Text) +import Data.String +import Data.Text (Text) import qualified Data.Text as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64) -import Lens.Micro hiding (ix) -import Lens.Micro.Extras (view) +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Word (Word16, Word32, Word64) +import Lens.Micro hiding (ix) +import Lens.Micro.Extras (view) +import Ouroboros.Consensus.Shelley.Eras + ( StandardAllegra + , StandardAlonzo + , StandardBabbage + , StandardConway + , StandardMary + , StandardShelley + ) +import Text.Parsec (()) import qualified Text.Parsec as Parsec -import Text.Parsec (()) import qualified Text.Parsec.String as Parsec - -- ---------------------------------------------------------------------------- -- Transaction outputs -- -- | The context is a transaction body data CtxTx + -- | The context is the UTxO data CtxUTxO -data TxOut ctx era = TxOut (AddressInEra era) - (TxOutValue era) - (TxOutDatum ctx era) - (ReferenceScript era) +data TxOut ctx era + = TxOut + (AddressInEra era) + (TxOutValue era) + (TxOutDatum ctx era) + (ReferenceScript era) + +deriving instance Eq (TxOut ctx era) -deriving instance Eq (TxOut ctx era) deriving instance Show (TxOut ctx era) data TxOutInAnyEra where - TxOutInAnyEra :: CardanoEra era - -> TxOut CtxTx era - -> TxOutInAnyEra + TxOutInAnyEra + :: CardanoEra era + -> TxOut CtxTx era + -> TxOutInAnyEra deriving instance Show TxOutInAnyEra @@ -295,7 +303,7 @@ instance Eq TxOutInAnyEra where TxOutInAnyEra era1 out1 == TxOutInAnyEra era2 out2 = case testEquality era1 era2 of Just Refl -> out1 == out2 - Nothing -> False + Nothing -> False deriving via (ShowOf TxOutInAnyEra) instance Pretty TxOutInAnyEra @@ -303,17 +311,17 @@ deriving via (ShowOf TxOutInAnyEra) instance Pretty TxOutInAnyEra txOutInAnyEra :: CardanoEra era -> TxOut CtxTx era -> TxOutInAnyEra txOutInAnyEra = TxOutInAnyEra -toCtxUTxOTxOut :: TxOut CtxTx era -> TxOut CtxUTxO era +toCtxUTxOTxOut :: TxOut CtxTx era -> TxOut CtxUTxO era toCtxUTxOTxOut (TxOut addr val d refS) = let dat = case d of - TxOutDatumNone -> TxOutDatumNone - TxOutDatumHash s h -> TxOutDatumHash s h - TxOutDatumInTx' s h _ -> TxOutDatumHash s h - TxOutDatumInline s sd -> TxOutDatumInline s sd - in TxOut addr val dat refS + TxOutDatumNone -> TxOutDatumNone + TxOutDatumHash s h -> TxOutDatumHash s h + TxOutDatumInTx' s h _ -> TxOutDatumHash s h + TxOutDatumInline s sd -> TxOutDatumInline s sd + in TxOut addr val dat refS instance IsCardanoEra era => ToJSON (TxOut ctx era) where - toJSON = txOutToJsonValue cardanoEra + toJSON = txOutToJsonValue cardanoEra txOutToJsonValue :: CardanoEra era -> TxOut ctx era -> Aeson.Value txOutToJsonValue era (TxOut addr val dat refScript) = @@ -322,12 +330,13 @@ txOutToJsonValue era (TxOut addr val dat refScript) = ShelleyEra -> object ["address" .= addr, "value" .= val] AllegraEra -> object ["address" .= addr, "value" .= val] MaryEra -> object ["address" .= addr, "value" .= val] - AlonzoEra -> object - [ "address" .= addr - , "value" .= val - , datHashJsonVal dat - , "datum" .= datJsonVal dat - ] + AlonzoEra -> + object + [ "address" .= addr + , "value" .= val + , datHashJsonVal dat + , "datum" .= datJsonVal dat + ] BabbageEra -> object [ "address" .= addr @@ -347,290 +356,323 @@ txOutToJsonValue era (TxOut addr val dat refScript) = , "referenceScript" .= refScriptJsonVal refScript ] where - datHashJsonVal :: TxOutDatum ctx era -> Aeson.Pair - datHashJsonVal d = - case d of - TxOutDatumNone -> - "datumhash" .= Aeson.Null - TxOutDatumHash _ h -> - "datumhash" .= toJSON h - TxOutDatumInTx' _ h _ -> - "datumhash" .= toJSON h - TxOutDatumInline _ datum -> - "inlineDatumhash" .= toJSON (hashScriptDataBytes datum) - - datJsonVal :: TxOutDatum ctx era -> Aeson.Value - datJsonVal d = - case d of - TxOutDatumNone -> Aeson.Null - TxOutDatumHash _ _ -> Aeson.Null - TxOutDatumInTx' _ _ datum -> scriptDataToJson ScriptDataJsonDetailedSchema datum - TxOutDatumInline _ _ -> Aeson.Null - - inlineDatumJsonVal :: TxOutDatum ctx era -> Aeson.Value - inlineDatumJsonVal d = - case d of - TxOutDatumNone -> Aeson.Null - TxOutDatumHash {} -> Aeson.Null - TxOutDatumInTx'{} -> Aeson.Null - TxOutDatumInline _ datum -> scriptDataToJson ScriptDataJsonDetailedSchema datum - - refScriptJsonVal :: ReferenceScript era -> Aeson.Value - refScriptJsonVal rScript = - case rScript of - ReferenceScript _ s -> toJSON s - ReferenceScriptNone -> Aeson.Null + datHashJsonVal :: TxOutDatum ctx era -> Aeson.Pair + datHashJsonVal d = + case d of + TxOutDatumNone -> + "datumhash" .= Aeson.Null + TxOutDatumHash _ h -> + "datumhash" .= toJSON h + TxOutDatumInTx' _ h _ -> + "datumhash" .= toJSON h + TxOutDatumInline _ datum -> + "inlineDatumhash" .= toJSON (hashScriptDataBytes datum) + + datJsonVal :: TxOutDatum ctx era -> Aeson.Value + datJsonVal d = + case d of + TxOutDatumNone -> Aeson.Null + TxOutDatumHash _ _ -> Aeson.Null + TxOutDatumInTx' _ _ datum -> scriptDataToJson ScriptDataJsonDetailedSchema datum + TxOutDatumInline _ _ -> Aeson.Null + + inlineDatumJsonVal :: TxOutDatum ctx era -> Aeson.Value + inlineDatumJsonVal d = + case d of + TxOutDatumNone -> Aeson.Null + TxOutDatumHash {} -> Aeson.Null + TxOutDatumInTx' {} -> Aeson.Null + TxOutDatumInline _ datum -> scriptDataToJson ScriptDataJsonDetailedSchema datum + + refScriptJsonVal :: ReferenceScript era -> Aeson.Value + refScriptJsonVal rScript = + case rScript of + ReferenceScript _ s -> toJSON s + ReferenceScriptNone -> Aeson.Null instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where - parseJSON = withObject "TxOut" $ \o -> do - case shelleyBasedEra :: ShelleyBasedEra era of - ShelleyBasedEraShelley -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraMary -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraAllegra -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraAlonzo -> alonzoTxOutParser AlonzoEraOnwardsAlonzo o - - ShelleyBasedEraBabbage -> do - alonzoTxOutInBabbage <- alonzoTxOutParser AlonzoEraOnwardsBabbage o - - -- We check for the existence of inline datums - inlineDatumHash <- o .:? "inlineDatumhash" - inlineDatum <- o .:? "inlineDatum" - mInlineDatum <- - case (inlineDatum, inlineDatumHash) of - (Just dVal, Just h) -> do - case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of - Left err -> - fail $ "Error parsing TxOut JSON: " <> displayError err - Right hashableData -> do - if hashScriptDataBytes hashableData /= h - then fail "Inline datum not equivalent to inline datum hash" - else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData - (Nothing, Nothing) -> return TxOutDatumNone - (_,_) -> fail "Should not be possible to create a tx output with either an inline datum hash or an inline datum" - - mReferenceScript <- o .:? "referenceScript" - - reconcileBabbage alonzoTxOutInBabbage mInlineDatum mReferenceScript - - ShelleyBasedEraConway -> do - alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsConway o - - -- We check for the existence of inline datums - inlineDatumHash <- o .:? "inlineDatumhash" - inlineDatum <- o .:? "inlineDatum" - mInlineDatum <- - case (inlineDatum, inlineDatumHash) of - (Just dVal, Just h) -> - case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of - Left err -> - fail $ "Error parsing TxOut JSON: " <> displayError err - Right sData -> - if hashScriptDataBytes sData /= h - then fail "Inline datum not equivalent to inline datum hash" - else return $ TxOutDatumInline BabbageEraOnwardsConway sData - (Nothing, Nothing) -> return TxOutDatumNone - (_,_) -> fail "Should not be possible to create a tx output with either an inline datum hash or an inline datum" - - mReferenceScript <- o .:? "referenceScript" - - reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript - where - reconcileBabbage - :: TxOut CtxTx BabbageEra -- ^ Alonzo era datum in Babbage era - -> TxOutDatum CtxTx BabbageEra -- ^ Babbage inline datum - -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxTx BabbageEra) - reconcileBabbage top@(TxOut addr v dat r) babbageDatum mBabRefScript = do - -- We check for conflicting datums - finalDat <- case (dat, babbageDatum) of - (TxOutDatumNone, bDatum) -> return bDatum - (anyDat, TxOutDatumNone) -> return anyDat - (alonzoDat, babbageDat) -> - fail $ "Parsed an Alonzo era datum and a Babbage era datum " <> - "TxOut: " <> show top <> - "Alonzo datum: " <> show alonzoDat <> - "Babbage dat: " <> show babbageDat - finalRefScript <- case mBabRefScript of - Nothing -> return r - Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsBabbage anyScript - return $ TxOut addr v finalDat finalRefScript - - reconcileConway - :: TxOut CtxTx ConwayEra -- ^ Alonzo era datum in Conway era - -> TxOutDatum CtxTx ConwayEra -- ^ Babbage inline datum - -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxTx ConwayEra) - reconcileConway top@(TxOut addr v dat r) babbageDatum mBabRefScript = do - -- We check for conflicting datums - finalDat <- case (dat, babbageDatum) of - (TxOutDatumNone, bDatum) -> return bDatum - (anyDat, TxOutDatumNone) -> return anyDat - (alonzoDat, babbageDat) -> - fail $ "Parsed an Alonzo era datum and a Conway era datum " <> - "TxOut: " <> show top <> - "Alonzo datum: " <> show alonzoDat <> - "Conway dat: " <> show babbageDat - finalRefScript <- case mBabRefScript of - Nothing -> return r - Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsConway anyScript - return $ TxOut addr v finalDat finalRefScript - - alonzoTxOutParser - :: AlonzoEraOnwards era -> Aeson.Object -> Aeson.Parser (TxOut CtxTx era) - alonzoTxOutParser w o = do - mDatumHash <- o .:? "datumhash" - mDatumVal <- o .:? "datum" - case (mDatumVal, mDatumHash) of - (Nothing,Nothing) -> TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - (Just dVal, Just dHash) -> do - case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of - Left e -> fail $ "Error parsing ScriptData: " <> show e - Right hashableData -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return (TxOutDatumInTx' w dHash hashableData) - <*> return ReferenceScriptNone - (Nothing, Just dHash) -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return (TxOutDatumHash w dHash) - <*> return ReferenceScriptNone - (Just _dVal, Nothing) -> fail "Only datum JSON was found, this should not be possible." + parseJSON = withObject "TxOut" $ \o -> do + case shelleyBasedEra :: ShelleyBasedEra era of + ShelleyBasedEraShelley -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraMary -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraAllegra -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraAlonzo -> alonzoTxOutParser AlonzoEraOnwardsAlonzo o + ShelleyBasedEraBabbage -> do + alonzoTxOutInBabbage <- alonzoTxOutParser AlonzoEraOnwardsBabbage o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> do + case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right hashableData -> do + if hashScriptDataBytes hashableData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + mReferenceScript <- o .:? "referenceScript" + + reconcileBabbage alonzoTxOutInBabbage mInlineDatum mReferenceScript + ShelleyBasedEraConway -> do + alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsConway o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> + case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right sData -> + if hashScriptDataBytes sData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsConway sData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + mReferenceScript <- o .:? "referenceScript" + + reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript + where + reconcileBabbage + :: TxOut CtxTx BabbageEra + -- \^ Alonzo era datum in Babbage era + -> TxOutDatum CtxTx BabbageEra + -- \^ Babbage inline datum + -> Maybe ScriptInAnyLang + -> Aeson.Parser (TxOut CtxTx BabbageEra) + reconcileBabbage top@(TxOut addr v dat r) babbageDatum mBabRefScript = do + -- We check for conflicting datums + finalDat <- case (dat, babbageDatum) of + (TxOutDatumNone, bDatum) -> return bDatum + (anyDat, TxOutDatumNone) -> return anyDat + (alonzoDat, babbageDat) -> + fail $ + "Parsed an Alonzo era datum and a Babbage era datum " + <> "TxOut: " + <> show top + <> "Alonzo datum: " + <> show alonzoDat + <> "Babbage dat: " + <> show babbageDat + finalRefScript <- case mBabRefScript of + Nothing -> return r + Just anyScript -> + return $ ReferenceScript BabbageEraOnwardsBabbage anyScript + return $ TxOut addr v finalDat finalRefScript + + reconcileConway + :: TxOut CtxTx ConwayEra + -- \^ Alonzo era datum in Conway era + -> TxOutDatum CtxTx ConwayEra + -- \^ Babbage inline datum + -> Maybe ScriptInAnyLang + -> Aeson.Parser (TxOut CtxTx ConwayEra) + reconcileConway top@(TxOut addr v dat r) babbageDatum mBabRefScript = do + -- We check for conflicting datums + finalDat <- case (dat, babbageDatum) of + (TxOutDatumNone, bDatum) -> return bDatum + (anyDat, TxOutDatumNone) -> return anyDat + (alonzoDat, babbageDat) -> + fail $ + "Parsed an Alonzo era datum and a Conway era datum " + <> "TxOut: " + <> show top + <> "Alonzo datum: " + <> show alonzoDat + <> "Conway dat: " + <> show babbageDat + finalRefScript <- case mBabRefScript of + Nothing -> return r + Just anyScript -> + return $ ReferenceScript BabbageEraOnwardsConway anyScript + return $ TxOut addr v finalDat finalRefScript + + alonzoTxOutParser + :: AlonzoEraOnwards era -> Aeson.Object -> Aeson.Parser (TxOut CtxTx era) + alonzoTxOutParser w o = do + mDatumHash <- o .:? "datumhash" + mDatumVal <- o .:? "datum" + case (mDatumVal, mDatumHash) of + (Nothing, Nothing) -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + (Just dVal, Just dHash) -> do + case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of + Left e -> fail $ "Error parsing ScriptData: " <> show e + Right hashableData -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return (TxOutDatumInTx' w dHash hashableData) + <*> return ReferenceScriptNone + (Nothing, Just dHash) -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return (TxOutDatumHash w dHash) + <*> return ReferenceScriptNone + (Just _dVal, Nothing) -> fail "Only datum JSON was found, this should not be possible." instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where - parseJSON = withObject "TxOut" $ \o -> do - case shelleyBasedEra :: ShelleyBasedEra era of - ShelleyBasedEraShelley -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraMary -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraAllegra -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - ShelleyBasedEraAlonzo -> alonzoTxOutParser AlonzoEraOnwardsAlonzo o - - ShelleyBasedEraBabbage -> do - alonzoTxOutInBabbage <- alonzoTxOutParser AlonzoEraOnwardsBabbage o - - -- We check for the existence of inline datums - inlineDatumHash <- o .:? "inlineDatumhash" - inlineDatum <- o .:? "inlineDatum" - mInlineDatum <- - case (inlineDatum, inlineDatumHash) of - (Just dVal, Just h) -> do - case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of - Left err -> - fail $ "Error parsing TxOut JSON: " <> displayError err - Right hashableData -> do - if hashScriptDataBytes hashableData /= h - then fail "Inline datum not equivalent to inline datum hash" - else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData - (Nothing, Nothing) -> return TxOutDatumNone - (_,_) -> fail "Should not be possible to create a tx output with either an inline datum hash or an inline datum" - - -- We check for a reference script - mReferenceScript <- o .:? "referenceScript" - - reconcileBabbage alonzoTxOutInBabbage mInlineDatum mReferenceScript - - ShelleyBasedEraConway -> do - alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsConway o - - -- We check for the existence of inline datums - inlineDatumHash <- o .:? "inlineDatumhash" - inlineDatum <- o .:? "inlineDatum" - mInlineDatum <- - case (inlineDatum, inlineDatumHash) of - (Just dVal, Just h) -> - case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of - Left err -> - fail $ "Error parsing TxOut JSON: " <> displayError err - Right sData -> - if hashScriptDataBytes sData /= h - then fail "Inline datum not equivalent to inline datum hash" - else return $ TxOutDatumInline BabbageEraOnwardsConway sData - (Nothing, Nothing) -> return TxOutDatumNone - (_,_) -> fail "Should not be possible to create a tx output with either an inline datum hash or an inline datum" - - -- We check for a reference script - mReferenceScript <- o .:? "referenceScript" - - reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript - where - reconcileBabbage - :: TxOut CtxUTxO BabbageEra -- ^ Alonzo era datum in Babbage era - -> TxOutDatum CtxUTxO BabbageEra -- ^ Babbage inline datum - -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxUTxO BabbageEra) - reconcileBabbage (TxOut addr v dat r) babbageDatum mBabRefScript = do - -- We check for conflicting datums - finalDat <- case (dat, babbageDatum) of - (TxOutDatumNone, bDatum) -> return bDatum - (anyDat, TxOutDatumNone) -> return anyDat - (_,_) -> fail "Parsed an Alonzo era datum and a Babbage era datum" - finalRefScript <- case mBabRefScript of - Nothing -> return r - Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsBabbage anyScript - - return $ TxOut addr v finalDat finalRefScript - - reconcileConway - :: TxOut CtxUTxO ConwayEra -- ^ Alonzo era datum in Conway era - -> TxOutDatum CtxUTxO ConwayEra -- ^ Babbage inline datum - -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxUTxO ConwayEra) - reconcileConway (TxOut addr v dat r) babbageDatum mBabRefScript = do - -- We check for conflicting datums - finalDat <- case (dat, babbageDatum) of - (TxOutDatumNone, bDatum) -> return bDatum - (anyDat, TxOutDatumNone) -> return anyDat - (_,_) -> fail "Parsed an Alonzo era datum and a Conway era datum" - finalRefScript <- case mBabRefScript of - Nothing -> return r - Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsConway anyScript - - return $ TxOut addr v finalDat finalRefScript - - alonzoTxOutParser :: AlonzoEraOnwards era -> Aeson.Object -> Aeson.Parser (TxOut CtxUTxO era) - alonzoTxOutParser w o = do - mDatumHash <- o .:? "datumhash" - case mDatumHash of - Nothing -> TxOut <$> o .: "address" - <*> o .: "value" - <*> return TxOutDatumNone - <*> return ReferenceScriptNone - Just dHash -> - TxOut <$> o .: "address" - <*> o .: "value" - <*> return (TxOutDatumHash w dHash) - <*> return ReferenceScriptNone + parseJSON = withObject "TxOut" $ \o -> do + case shelleyBasedEra :: ShelleyBasedEra era of + ShelleyBasedEraShelley -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraMary -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraAllegra -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + ShelleyBasedEraAlonzo -> alonzoTxOutParser AlonzoEraOnwardsAlonzo o + ShelleyBasedEraBabbage -> do + alonzoTxOutInBabbage <- alonzoTxOutParser AlonzoEraOnwardsBabbage o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> do + case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right hashableData -> do + if hashScriptDataBytes hashableData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + -- We check for a reference script + mReferenceScript <- o .:? "referenceScript" + + reconcileBabbage alonzoTxOutInBabbage mInlineDatum mReferenceScript + ShelleyBasedEraConway -> do + alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsConway o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> + case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right sData -> + if hashScriptDataBytes sData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsConway sData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + -- We check for a reference script + mReferenceScript <- o .:? "referenceScript" + + reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript + where + reconcileBabbage + :: TxOut CtxUTxO BabbageEra + -- \^ Alonzo era datum in Babbage era + -> TxOutDatum CtxUTxO BabbageEra + -- \^ Babbage inline datum + -> Maybe ScriptInAnyLang + -> Aeson.Parser (TxOut CtxUTxO BabbageEra) + reconcileBabbage (TxOut addr v dat r) babbageDatum mBabRefScript = do + -- We check for conflicting datums + finalDat <- case (dat, babbageDatum) of + (TxOutDatumNone, bDatum) -> return bDatum + (anyDat, TxOutDatumNone) -> return anyDat + (_, _) -> fail "Parsed an Alonzo era datum and a Babbage era datum" + finalRefScript <- case mBabRefScript of + Nothing -> return r + Just anyScript -> + return $ ReferenceScript BabbageEraOnwardsBabbage anyScript + + return $ TxOut addr v finalDat finalRefScript + + reconcileConway + :: TxOut CtxUTxO ConwayEra + -- \^ Alonzo era datum in Conway era + -> TxOutDatum CtxUTxO ConwayEra + -- \^ Babbage inline datum + -> Maybe ScriptInAnyLang + -> Aeson.Parser (TxOut CtxUTxO ConwayEra) + reconcileConway (TxOut addr v dat r) babbageDatum mBabRefScript = do + -- We check for conflicting datums + finalDat <- case (dat, babbageDatum) of + (TxOutDatumNone, bDatum) -> return bDatum + (anyDat, TxOutDatumNone) -> return anyDat + (_, _) -> fail "Parsed an Alonzo era datum and a Conway era datum" + finalRefScript <- case mBabRefScript of + Nothing -> return r + Just anyScript -> + return $ ReferenceScript BabbageEraOnwardsConway anyScript + + return $ TxOut addr v finalDat finalRefScript + + alonzoTxOutParser :: AlonzoEraOnwards era -> Aeson.Object -> Aeson.Parser (TxOut CtxUTxO era) + alonzoTxOutParser w o = do + mDatumHash <- o .:? "datumhash" + case mDatumHash of + Nothing -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return TxOutDatumNone + <*> return ReferenceScriptNone + Just dHash -> + TxOut + <$> o .: "address" + <*> o .: "value" + <*> return (TxOutDatumHash w dHash) + <*> return ReferenceScriptNone toByronTxOut :: TxOut ctx ByronEra -> Maybe Byron.TxOut toByronTxOut = \case @@ -638,26 +680,25 @@ toByronTxOut = \case Byron.TxOut addr <$> toByronLovelace value TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValueShelleyBased w _) _ _ -> case w of {} - TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> + TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress {}) _ _ _ -> case sbe of {} - -toShelleyTxOut :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> TxOut CtxUTxO era - -> Ledger.TxOut ledgerera -toShelleyTxOut _ = \case -- jky simplify +toShelleyTxOut + :: forall era ledgerera + . ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> TxOut CtxUTxO era + -> Ledger.TxOut ledgerera +toShelleyTxOut _ = \case + -- jky simplify TxOut _ (TxOutValueByron _) _ _ -> -- TODO: Temporary until we have basic tx -- construction functionality error "toShelleyTxOut: Expected a Shelley value" - TxOut addr (TxOutValueShelleyBased sbe value) txoutdata refScript -> caseShelleyToMaryOrAlonzoEraOnwards - (const $ L.mkBasicTxOut (toShelleyAddr addr) value - ) - (\case + (const $ L.mkBasicTxOut (toShelleyAddr addr) value) + ( \case AlonzoEraOnwardsAlonzo -> L.mkBasicTxOut (toShelleyAddr addr) value & L.dataHashTxOutL .~ toAlonzoTxOutDatumHashUTxO txoutdata @@ -676,17 +717,18 @@ toAlonzoTxOutDatumHashUTxO :: TxOutDatum CtxUTxO era -> StrictMaybe (Plutus.DataHash StandardCrypto) toAlonzoTxOutDatumHashUTxO TxOutDatumNone = SNothing toAlonzoTxOutDatumHashUTxO (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh -toAlonzoTxOutDatumHashUTxO (TxOutDatumInline{}) = SNothing +toAlonzoTxOutDatumHashUTxO (TxOutDatumInline {}) = SNothing toBabbageTxOutDatumUTxO :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => TxOutDatum CtxUTxO era -> Plutus.Datum (ShelleyLedgerEra era) -toBabbageTxOutDatumUTxO TxOutDatumNone = Plutus.NoDatum +toBabbageTxOutDatumUTxO TxOutDatumNone = Plutus.NoDatum toBabbageTxOutDatumUTxO (TxOutDatumHash _ (ScriptDataHash dh)) = Plutus.DatumHash dh toBabbageTxOutDatumUTxO (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd - -fromShelleyTxOut :: forall era ctx. () +fromShelleyTxOut + :: forall era ctx + . () => ShelleyBasedEra era -> Core.TxOut (ShelleyLedgerEra era) -> TxOut ctx era @@ -697,57 +739,58 @@ fromShelleyTxOut sbe ledgerTxOut = shelleyBasedEraConstraints sbe $ do case sbe of ShelleyBasedEraShelley -> TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone - ShelleyBasedEraAllegra -> TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone - ShelleyBasedEraMary -> TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone - ShelleyBasedEraAlonzo -> TxOut addressInEra txOutValue TxOutDatumNone ReferenceScriptNone - ShelleyBasedEraBabbage -> - TxOut addressInEra - txOutValue - (fromBabbageTxOutDatum - AlonzoEraOnwardsBabbage - BabbageEraOnwardsBabbage - datum) - (case mRefScript of - SNothing -> ReferenceScriptNone - SJust refScript -> - fromShelleyScriptToReferenceScript ShelleyBasedEraBabbage refScript) - where - datum = ledgerTxOut ^. L.datumTxOutL - mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL - + TxOut + addressInEra + txOutValue + ( fromBabbageTxOutDatum + AlonzoEraOnwardsBabbage + BabbageEraOnwardsBabbage + datum + ) + ( case mRefScript of + SNothing -> ReferenceScriptNone + SJust refScript -> + fromShelleyScriptToReferenceScript ShelleyBasedEraBabbage refScript + ) + where + datum = ledgerTxOut ^. L.datumTxOutL + mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL ShelleyBasedEraConway -> - TxOut addressInEra - txOutValue - (fromBabbageTxOutDatum - AlonzoEraOnwardsConway - BabbageEraOnwardsConway - datum) - (case mRefScript of - SNothing -> ReferenceScriptNone - SJust refScript -> - fromShelleyScriptToReferenceScript ShelleyBasedEraConway refScript) - where - datum = ledgerTxOut ^. L.datumTxOutL - mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL + TxOut + addressInEra + txOutValue + ( fromBabbageTxOutDatum + AlonzoEraOnwardsConway + BabbageEraOnwardsConway + datum + ) + ( case mRefScript of + SNothing -> ReferenceScriptNone + SJust refScript -> + fromShelleyScriptToReferenceScript ShelleyBasedEraConway refScript + ) + where + datum = ledgerTxOut ^. L.datumTxOutL + mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL toAlonzoTxOutDatumHash :: TxOutDatum ctx era -> StrictMaybe (Plutus.DataHash StandardCrypto) toAlonzoTxOutDatumHash TxOutDatumNone = SNothing toAlonzoTxOutDatumHash (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh -toAlonzoTxOutDatumHash (TxOutDatumInline{}) = SNothing +toAlonzoTxOutDatumHash (TxOutDatumInline {}) = SNothing toAlonzoTxOutDatumHash (TxOutDatumInTx' _ (ScriptDataHash dh) _) = SJust dh toBabbageTxOutDatum :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => TxOutDatum ctx era -> Plutus.Datum (ShelleyLedgerEra era) -toBabbageTxOutDatum TxOutDatumNone = Plutus.NoDatum +toBabbageTxOutDatum TxOutDatumNone = Plutus.NoDatum toBabbageTxOutDatum (TxOutDatumHash _ (ScriptDataHash dh)) = Plutus.DatumHash dh toBabbageTxOutDatum (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd toBabbageTxOutDatum (TxOutDatumInTx' _ (ScriptDataHash dh) _) = Plutus.DatumHash dh @@ -764,24 +807,24 @@ fromBabbageTxOutDatum w _ (Plutus.DatumHash dh) = fromBabbageTxOutDatum _ w (Plutus.Datum binData) = TxOutDatumInline w $ binaryDataToScriptData w binData - -- ---------------------------------------------------------------------------- -- Building vs viewing transactions -- data BuildTx + data ViewTx data BuildTxWith build a where - - ViewTx :: BuildTxWith ViewTx a - BuildTxWith :: a -> BuildTxWith BuildTx a + ViewTx :: BuildTxWith ViewTx a + BuildTxWith :: a -> BuildTxWith BuildTx a instance Functor (BuildTxWith build) where - fmap _ ViewTx = ViewTx - fmap f (BuildTxWith x) = BuildTxWith (f x) + fmap _ ViewTx = ViewTx + fmap f (BuildTxWith x) = BuildTxWith (f x) + +deriving instance Eq a => Eq (BuildTxWith build a) -deriving instance Eq a => Eq (BuildTxWith build a) deriving instance Show a => Show (BuildTxWith build a) -- ---------------------------------------------------------------------------- @@ -793,24 +836,24 @@ type TxIns build era = [(TxIn, BuildTxWith build (Witness WitCtxTxIn era))] data TxInsCollateral era where TxInsCollateralNone :: TxInsCollateral era - TxInsCollateral :: AlonzoEraOnwards era -> [TxIn] -- Only key witnesses, no scripts. -> TxInsCollateral era -deriving instance Eq (TxInsCollateral era) +deriving instance Eq (TxInsCollateral era) + deriving instance Show (TxInsCollateral era) data TxInsReference build era where + TxInsReferenceNone :: TxInsReference build era + TxInsReference + :: BabbageEraOnwards era + -> [TxIn] + -> TxInsReference build era - TxInsReferenceNone :: TxInsReference build era - - TxInsReference :: BabbageEraOnwards era - -> [TxIn] - -> TxInsReference build era +deriving instance Eq (TxInsReference build era) -deriving instance Eq (TxInsReference build era) deriving instance Show (TxInsReference build era) -- ---------------------------------------------------------------------------- @@ -818,20 +861,19 @@ deriving instance Show (TxInsReference build era) -- data TxOutValue era where - TxOutValueByron :: L.Coin -> TxOutValue era - TxOutValueShelleyBased - :: ( Eq (Ledger.Value (ShelleyLedgerEra era)) - , Show (Ledger.Value (ShelleyLedgerEra era)) - ) + :: ( Eq (Ledger.Value (ShelleyLedgerEra era)) + , Show (Ledger.Value (ShelleyLedgerEra era)) + ) => ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> TxOutValue era -deriving instance Eq (TxOutValue era) +deriving instance Eq (TxOutValue era) + deriving instance Show (TxOutValue era) instance IsCardanoEra era => ToJSON (TxOutValue era) where @@ -843,105 +885,104 @@ instance IsCardanoEra era => ToJSON (TxOutValue era) where instance IsShelleyBasedEra era => FromJSON (TxOutValue era) where parseJSON = withObject "TxOutValue" $ \o -> - caseShelleyToAllegraOrMaryEraOnwards - (\shelleyToAlleg -> do - ll <- o .: "lovelace" - pure - $ shelleyBasedEraConstraints (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) - $ TxOutValueShelleyBased (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) - $ A.mkAdaValue (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) ll + caseShelleyToAllegraOrMaryEraOnwards + ( \shelleyToAlleg -> do + ll <- o .: "lovelace" + pure $ + shelleyBasedEraConstraints (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) $ + TxOutValueShelleyBased (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) $ + A.mkAdaValue (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) ll ) - (\w -> do - let l = KeyMap.toList o - vals <- mapM decodeAssetId l - pure $ shelleyBasedEraConstraints (maryEraOnwardsToShelleyBasedEra w) - $ TxOutValueShelleyBased (maryEraOnwardsToShelleyBasedEra w) - $ toLedgerValue w $ mconcat vals + ( \w -> do + let l = KeyMap.toList o + vals <- mapM decodeAssetId l + pure $ + shelleyBasedEraConstraints (maryEraOnwardsToShelleyBasedEra w) $ + TxOutValueShelleyBased (maryEraOnwardsToShelleyBasedEra w) $ + toLedgerValue w $ + mconcat vals ) (shelleyBasedEra @era) - - where - decodeAssetId :: (Aeson.Key, Aeson.Value) -> Aeson.Parser Value - decodeAssetId (polid, Aeson.Object assetNameHm) = do - let polId = fromString . Text.unpack $ Aeson.toText polid - aNameQuantity <- decodeAssets assetNameHm - pure . valueFromList - $ map (first $ AssetId polId) aNameQuantity - - decodeAssetId ("lovelace", Aeson.Number sci) = - case toBoundedInteger sci of - Just (ll :: Word64) -> - pure $ valueFromList [(AdaAssetId, Quantity $ toInteger ll)] - Nothing -> - fail $ "Expected a Bounded number but got: " <> show sci - decodeAssetId wrong = fail $ "Expected a policy id and a JSON object but got: " <> show wrong - - decodeAssets :: Aeson.Object -> Aeson.Parser [(AssetName, Quantity)] - decodeAssets assetNameHm = - let l = KeyMap.toList assetNameHm + where + decodeAssetId :: (Aeson.Key, Aeson.Value) -> Aeson.Parser Value + decodeAssetId (polid, Aeson.Object assetNameHm) = do + let polId = fromString . Text.unpack $ Aeson.toText polid + aNameQuantity <- decodeAssets assetNameHm + pure . valueFromList $ + map (first $ AssetId polId) aNameQuantity + decodeAssetId ("lovelace", Aeson.Number sci) = + case toBoundedInteger sci of + Just (ll :: Word64) -> + pure $ valueFromList [(AdaAssetId, Quantity $ toInteger ll)] + Nothing -> + fail $ "Expected a Bounded number but got: " <> show sci + decodeAssetId wrong = fail $ "Expected a policy id and a JSON object but got: " <> show wrong + + decodeAssets :: Aeson.Object -> Aeson.Parser [(AssetName, Quantity)] + decodeAssets assetNameHm = + let l = KeyMap.toList assetNameHm in mapM (\(aName, q) -> (,) <$> parseAssetName aName <*> decodeQuantity q) l - parseAssetName :: Aeson.Key -> Aeson.Parser AssetName - parseAssetName aName = runParsecParser assetName (Aeson.toText aName) + parseAssetName :: Aeson.Key -> Aeson.Parser AssetName + parseAssetName aName = runParsecParser assetName (Aeson.toText aName) - decodeQuantity :: Aeson.Value -> Aeson.Parser Quantity - decodeQuantity (Aeson.Number sci) = - case toBoundedInteger sci of - Just (ll :: Word64) -> return . Quantity $ toInteger ll - Nothing -> fail $ "Expected a Bounded number but got: " <> show sci - decodeQuantity wrong = fail $ "Expected aeson Number but got: " <> show wrong + decodeQuantity :: Aeson.Value -> Aeson.Parser Quantity + decodeQuantity (Aeson.Number sci) = + case toBoundedInteger sci of + Just (ll :: Word64) -> return . Quantity $ toInteger ll + Nothing -> fail $ "Expected a Bounded number but got: " <> show sci + decodeQuantity wrong = fail $ "Expected aeson Number but got: " <> show wrong - -lovelaceToTxOutValue :: () +lovelaceToTxOutValue + :: () => ShelleyBasedEra era -> L.Coin -> TxOutValue era lovelaceToTxOutValue era ll = - shelleyBasedEraConstraints era - $ TxOutValueShelleyBased era - $ A.mkAdaValue era ll + shelleyBasedEraConstraints era $ + TxOutValueShelleyBased era $ + A.mkAdaValue era ll txOutValueToLovelace :: TxOutValue era -> L.Coin txOutValueToLovelace tv = case tv of - TxOutValueByron l -> l - TxOutValueShelleyBased sbe v -> v ^. A.adaAssetL sbe + TxOutValueByron l -> l + TxOutValueShelleyBased sbe v -> v ^. A.adaAssetL sbe txOutValueToValue :: TxOutValue era -> Value txOutValueToValue tv = case tv of - TxOutValueByron l -> lovelaceToValue l - TxOutValueShelleyBased sbe v -> fromLedgerValue sbe v + TxOutValueByron l -> lovelaceToValue l + TxOutValueShelleyBased sbe v -> fromLedgerValue sbe v prettyRenderTxOut :: TxOutInAnyEra -> Text prettyRenderTxOut (TxOutInAnyEra _ (TxOut (AddressInEra _ addr) txOutVal _ _)) = - serialiseAddress (toAddressAny addr) <> " + " - <> renderValue (txOutValueToValue txOutVal) + serialiseAddress (toAddressAny addr) + <> " + " + <> renderValue (txOutValueToValue txOutVal) data TxReturnCollateral ctx era where - TxReturnCollateralNone :: TxReturnCollateral ctx era - TxReturnCollateral :: BabbageEraOnwards era -> TxOut ctx era -> TxReturnCollateral ctx era -deriving instance Eq (TxReturnCollateral ctx era) +deriving instance Eq (TxReturnCollateral ctx era) + deriving instance Show (TxReturnCollateral ctx era) data TxTotalCollateral era where - TxTotalCollateralNone :: TxTotalCollateral era - TxTotalCollateral :: BabbageEraOnwards era -> L.Coin -> TxTotalCollateral era -deriving instance Eq (TxTotalCollateral era) +deriving instance Eq (TxTotalCollateral era) + deriving instance Show (TxTotalCollateral era) -- ---------------------------------------------------------------------------- @@ -949,34 +990,31 @@ deriving instance Show (TxTotalCollateral era) -- data TxOutDatum ctx era where + TxOutDatumNone :: TxOutDatum ctx era + -- | A transaction output that only specifies the hash of the datum, but + -- not the full datum value. + TxOutDatumHash + :: AlonzoEraOnwards era + -> Hash ScriptData + -> TxOutDatum ctx era + -- | A transaction output that specifies the whole datum value. This can + -- only be used in the context of the transaction body, and does not occur + -- in the UTxO. The UTxO only contains the datum hash. + TxOutDatumInTx' + :: AlonzoEraOnwards era + -> Hash ScriptData + -> HashableScriptData + -> TxOutDatum CtxTx era + -- | A transaction output that specifies the whole datum instead of the + -- datum hash. Note that the datum map will not be updated with this datum, + -- it only exists at the transaction output. + TxOutDatumInline + :: BabbageEraOnwards era + -> HashableScriptData + -> TxOutDatum ctx era + +deriving instance Eq (TxOutDatum ctx era) - TxOutDatumNone :: TxOutDatum ctx era - - -- | A transaction output that only specifies the hash of the datum, but - -- not the full datum value. - -- - TxOutDatumHash :: AlonzoEraOnwards era - -> Hash ScriptData - -> TxOutDatum ctx era - - -- | A transaction output that specifies the whole datum value. This can - -- only be used in the context of the transaction body, and does not occur - -- in the UTxO. The UTxO only contains the datum hash. - -- - TxOutDatumInTx' :: AlonzoEraOnwards era - -> Hash ScriptData - -> HashableScriptData - -> TxOutDatum CtxTx era - - -- | A transaction output that specifies the whole datum instead of the - -- datum hash. Note that the datum map will not be updated with this datum, - -- it only exists at the transaction output. - -- - TxOutDatumInline :: BabbageEraOnwards era - -> HashableScriptData - -> TxOutDatum ctx era - -deriving instance Eq (TxOutDatum ctx era) deriving instance Show (TxOutDatum ctx era) pattern TxOutDatumInTx @@ -988,7 +1026,8 @@ pattern TxOutDatumInTx w d <- TxOutDatumInTx' w _ d TxOutDatumInTx w d = TxOutDatumInTx' w (hashScriptDataBytes d) d {-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutDatumInTx', TxOutDatumInline #-} -{-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutDatumInTx , TxOutDatumInline #-} + +{-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutDatumInTx, TxOutDatumInline #-} parseHash :: SerialiseAsRawBytes (Hash a) => AsType (Hash a) -> Parsec.Parser (Hash a) parseHash asType = do @@ -1003,7 +1042,8 @@ parseHash asType = do data TxFee era where TxFeeExplicit :: ShelleyBasedEra era -> L.Coin -> TxFee era -deriving instance Eq (TxFee era) +deriving instance Eq (TxFee era) + deriving instance Show (TxFee era) defaultTxFee :: ShelleyBasedEra era -> TxFee era @@ -1014,32 +1054,32 @@ defaultTxFee w = TxFeeExplicit w mempty -- -- | This was formerly known as the TTL. --- data TxValidityUpperBound era where TxValidityUpperBound :: ShelleyBasedEra era -> Maybe SlotNo -> TxValidityUpperBound era -deriving instance Eq (TxValidityUpperBound era) +deriving instance Eq (TxValidityUpperBound era) + deriving instance Show (TxValidityUpperBound era) -defaultTxValidityUpperBound :: () +defaultTxValidityUpperBound + :: () => ShelleyBasedEra era -> TxValidityUpperBound era defaultTxValidityUpperBound sbe = TxValidityUpperBound sbe Nothing data TxValidityLowerBound era where - TxValidityNoLowerBound :: TxValidityLowerBound era - TxValidityLowerBound :: AllegraEraOnwards era -> SlotNo -> TxValidityLowerBound era -deriving instance Eq (TxValidityLowerBound era) +deriving instance Eq (TxValidityLowerBound era) + deriving instance Show (TxValidityLowerBound era) -- ---------------------------------------------------------------------------- @@ -1047,16 +1087,15 @@ deriving instance Show (TxValidityLowerBound era) -- data TxMetadataInEra era where - TxMetadataNone :: TxMetadataInEra era - TxMetadataInEra :: ShelleyBasedEra era -> TxMetadata -> TxMetadataInEra era -deriving instance Eq (TxMetadataInEra era) +deriving instance Eq (TxMetadataInEra era) + deriving instance Show (TxMetadataInEra era) -- ---------------------------------------------------------------------------- @@ -1064,16 +1103,15 @@ deriving instance Show (TxMetadataInEra era) -- data TxAuxScripts era where - TxAuxScriptsNone :: TxAuxScripts era - TxAuxScripts :: AllegraEraOnwards era -> [ScriptInEra era] -> TxAuxScripts era -deriving instance Eq (TxAuxScripts era) +deriving instance Eq (TxAuxScripts era) + deriving instance Show (TxAuxScripts era) -- ---------------------------------------------------------------------------- @@ -1081,16 +1119,15 @@ deriving instance Show (TxAuxScripts era) -- data TxExtraKeyWitnesses era where - TxExtraKeyWitnessesNone :: TxExtraKeyWitnesses era - TxExtraKeyWitnesses :: AlonzoEraOnwards era -> [Hash PaymentKey] -> TxExtraKeyWitnesses era -deriving instance Eq (TxExtraKeyWitnesses era) +deriving instance Eq (TxExtraKeyWitnesses era) + deriving instance Show (TxExtraKeyWitnesses era) -- ---------------------------------------------------------------------------- @@ -1098,16 +1135,15 @@ deriving instance Show (TxExtraKeyWitnesses era) -- data TxWithdrawals build era where - TxWithdrawalsNone :: TxWithdrawals build era - TxWithdrawals :: ShelleyBasedEra era -> [(StakeAddress, L.Coin, BuildTxWith build (Witness WitCtxStake era))] -> TxWithdrawals build era -deriving instance Eq (TxWithdrawals build era) +deriving instance Eq (TxWithdrawals build era) + deriving instance Show (TxWithdrawals build era) -- ---------------------------------------------------------------------------- @@ -1115,17 +1151,16 @@ deriving instance Show (TxWithdrawals build era) -- data TxCertificates build era where - TxCertificatesNone :: TxCertificates build era - TxCertificates :: ShelleyBasedEra era -> [Certificate era] -> BuildTxWith build (Map StakeCredential (Witness WitCtxStake era)) -> TxCertificates build era -deriving instance Eq (TxCertificates build era) +deriving instance Eq (TxCertificates build era) + deriving instance Show (TxCertificates build era) -- ---------------------------------------------------------------------------- @@ -1136,7 +1171,8 @@ data TxUpdateProposal era where TxUpdateProposalNone :: TxUpdateProposal era TxUpdateProposal :: ShelleyToBabbageEra era -> UpdateProposal -> TxUpdateProposal era -deriving instance Eq (TxUpdateProposal era) +deriving instance Eq (TxUpdateProposal era) + deriving instance Show (TxUpdateProposal era) -- ---------------------------------------------------------------------------- @@ -1144,16 +1180,17 @@ deriving instance Show (TxUpdateProposal era) -- data TxMintValue build era where + TxMintNone :: TxMintValue build era + TxMintValue + :: MaryEraOnwards era + -> Value + -> BuildTxWith + build + (Map PolicyId (ScriptWitness WitCtxMint era)) + -> TxMintValue build era - TxMintNone :: TxMintValue build era - - TxMintValue :: MaryEraOnwards era - -> Value - -> BuildTxWith build - (Map PolicyId (ScriptWitness WitCtxMint era)) - -> TxMintValue build era +deriving instance Eq (TxMintValue build era) -deriving instance Eq (TxMintValue build era) deriving instance Show (TxMintValue build era) -- ---------------------------------------------------------------------------- @@ -1164,13 +1201,14 @@ data TxVotingProcedures build era where TxVotingProceduresNone :: TxVotingProcedures build era TxVotingProcedures :: L.VotingProcedures (ShelleyLedgerEra era) - -> BuildTxWith build (Map (Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)) + -> BuildTxWith + build + (Map (Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)) -> TxVotingProcedures build era - deriving instance Eq (TxVotingProcedures build era) -deriving instance Show (TxVotingProcedures build era) +deriving instance Show (TxVotingProcedures build era) -- ---------------------------------------------------------------------------- -- Proposals within transactions (era-dependent) @@ -1184,10 +1222,9 @@ data TxProposalProcedures build era where -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) -> TxProposalProcedures build era - deriving instance Eq (TxProposalProcedures build era) -deriving instance Show (TxProposalProcedures build era) +deriving instance Show (TxProposalProcedures build era) -- ---------------------------------------------------------------------------- -- Transaction body content @@ -1196,39 +1233,41 @@ deriving instance Show (TxProposalProcedures build era) -- If you extend this type, consider updating: -- - the 'makeShelleyTransactionBody' function of the relevant era below, and -- - the @friendly*@ family of functions in cardano-cli. -data TxBodyContent build era = - TxBodyContent { - txIns :: TxIns build era, - txInsCollateral :: TxInsCollateral era, - txInsReference :: TxInsReference build era, - txOuts :: [TxOut CtxTx era], - txTotalCollateral :: TxTotalCollateral era, - txReturnCollateral :: TxReturnCollateral CtxTx era, - txFee :: TxFee era, - txValidityLowerBound :: TxValidityLowerBound era, - txValidityUpperBound :: TxValidityUpperBound era, - txMetadata :: TxMetadataInEra era, - txAuxScripts :: TxAuxScripts era, - txExtraKeyWits :: TxExtraKeyWitnesses era, - txProtocolParams :: BuildTxWith build (Maybe (LedgerProtocolParameters era)), - txWithdrawals :: TxWithdrawals build era, - txCertificates :: TxCertificates build era, - txUpdateProposal :: TxUpdateProposal era, - txMintValue :: TxMintValue build era, - txScriptValidity :: TxScriptValidity era, - txProposalProcedures :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)), - txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)), - -- | Current treasury value - txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin), - -- | Treasury donation to perform - txTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) - } - deriving (Eq, Show) - -defaultTxBodyContent :: () +data TxBodyContent build era + = TxBodyContent + { txIns :: TxIns build era + , txInsCollateral :: TxInsCollateral era + , txInsReference :: TxInsReference build era + , txOuts :: [TxOut CtxTx era] + , txTotalCollateral :: TxTotalCollateral era + , txReturnCollateral :: TxReturnCollateral CtxTx era + , txFee :: TxFee era + , txValidityLowerBound :: TxValidityLowerBound era + , txValidityUpperBound :: TxValidityUpperBound era + , txMetadata :: TxMetadataInEra era + , txAuxScripts :: TxAuxScripts era + , txExtraKeyWits :: TxExtraKeyWitnesses era + , txProtocolParams :: BuildTxWith build (Maybe (LedgerProtocolParameters era)) + , txWithdrawals :: TxWithdrawals build era + , txCertificates :: TxCertificates build era + , txUpdateProposal :: TxUpdateProposal era + , txMintValue :: TxMintValue build era + , txScriptValidity :: TxScriptValidity era + , txProposalProcedures :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + , txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) + , txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin) + -- ^ Current treasury value + , txTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) + -- ^ Treasury donation to perform + } + deriving (Eq, Show) + +defaultTxBodyContent + :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era -defaultTxBodyContent era = TxBodyContent +defaultTxBodyContent era = + TxBodyContent { txIns = [] , txInsCollateral = TxInsCollateralNone , txInsReference = TxInsReferenceNone @@ -1254,91 +1293,103 @@ defaultTxBodyContent era = TxBodyContent } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era -setTxIns v txBodyContent = txBodyContent { txIns = v } +setTxIns v txBodyContent = txBodyContent {txIns = v} -modTxIns :: (TxIns build era -> TxIns build era) -> TxBodyContent build era -> TxBodyContent build era -modTxIns f txBodyContent = txBodyContent { txIns = f (txIns txBodyContent) } +modTxIns + :: (TxIns build era -> TxIns build era) -> TxBodyContent build era -> TxBodyContent build era +modTxIns f txBodyContent = txBodyContent {txIns = f (txIns txBodyContent)} -addTxIn :: (TxIn, BuildTxWith build (Witness WitCtxTxIn era)) -> TxBodyContent build era -> TxBodyContent build era -addTxIn txIn = modTxIns (txIn:) +addTxIn + :: (TxIn, BuildTxWith build (Witness WitCtxTxIn era)) + -> TxBodyContent build era + -> TxBodyContent build era +addTxIn txIn = modTxIns (txIn :) setTxInsCollateral :: TxInsCollateral era -> TxBodyContent build era -> TxBodyContent build era -setTxInsCollateral v txBodyContent = txBodyContent { txInsCollateral = v } +setTxInsCollateral v txBodyContent = txBodyContent {txInsCollateral = v} setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era -setTxInsReference v txBodyContent = txBodyContent { txInsReference = v } +setTxInsReference v txBodyContent = txBodyContent {txInsReference = v} setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era -setTxOuts v txBodyContent = txBodyContent { txOuts = v } +setTxOuts v txBodyContent = txBodyContent {txOuts = v} -modTxOuts :: ([TxOut CtxTx era] -> [TxOut CtxTx era]) -> TxBodyContent build era -> TxBodyContent build era -modTxOuts f txBodyContent = txBodyContent { txOuts = f (txOuts txBodyContent) } +modTxOuts + :: ([TxOut CtxTx era] -> [TxOut CtxTx era]) -> TxBodyContent build era -> TxBodyContent build era +modTxOuts f txBodyContent = txBodyContent {txOuts = f (txOuts txBodyContent)} addTxOut :: TxOut CtxTx era -> TxBodyContent build era -> TxBodyContent build era -addTxOut txOut = modTxOuts (txOut:) +addTxOut txOut = modTxOuts (txOut :) setTxTotalCollateral :: TxTotalCollateral era -> TxBodyContent build era -> TxBodyContent build era -setTxTotalCollateral v txBodyContent = txBodyContent { txTotalCollateral = v } +setTxTotalCollateral v txBodyContent = txBodyContent {txTotalCollateral = v} -setTxReturnCollateral :: TxReturnCollateral CtxTx era -> TxBodyContent build era -> TxBodyContent build era -setTxReturnCollateral v txBodyContent = txBodyContent { txReturnCollateral = v } +setTxReturnCollateral + :: TxReturnCollateral CtxTx era -> TxBodyContent build era -> TxBodyContent build era +setTxReturnCollateral v txBodyContent = txBodyContent {txReturnCollateral = v} setTxFee :: TxFee era -> TxBodyContent build era -> TxBodyContent build era -setTxFee v txBodyContent = txBodyContent { txFee = v } +setTxFee v txBodyContent = txBodyContent {txFee = v} -setTxValidityLowerBound :: TxValidityLowerBound era -> TxBodyContent build era -> TxBodyContent build era -setTxValidityLowerBound v txBodyContent = txBodyContent { txValidityLowerBound = v } +setTxValidityLowerBound + :: TxValidityLowerBound era -> TxBodyContent build era -> TxBodyContent build era +setTxValidityLowerBound v txBodyContent = txBodyContent {txValidityLowerBound = v} -setTxValidityUpperBound :: TxValidityUpperBound era -> TxBodyContent build era -> TxBodyContent build era -setTxValidityUpperBound v txBodyContent = txBodyContent { txValidityUpperBound = v } +setTxValidityUpperBound + :: TxValidityUpperBound era -> TxBodyContent build era -> TxBodyContent build era +setTxValidityUpperBound v txBodyContent = txBodyContent {txValidityUpperBound = v} setTxMetadata :: TxMetadataInEra era -> TxBodyContent build era -> TxBodyContent build era -setTxMetadata v txBodyContent = txBodyContent { txMetadata = v } +setTxMetadata v txBodyContent = txBodyContent {txMetadata = v} setTxAuxScripts :: TxAuxScripts era -> TxBodyContent build era -> TxBodyContent build era -setTxAuxScripts v txBodyContent = txBodyContent { txAuxScripts = v } +setTxAuxScripts v txBodyContent = txBodyContent {txAuxScripts = v} setTxExtraKeyWits :: TxExtraKeyWitnesses era -> TxBodyContent build era -> TxBodyContent build era -setTxExtraKeyWits v txBodyContent = txBodyContent { txExtraKeyWits = v } +setTxExtraKeyWits v txBodyContent = txBodyContent {txExtraKeyWits = v} -setTxProtocolParams :: BuildTxWith build (Maybe (LedgerProtocolParameters era)) -> TxBodyContent build era -> TxBodyContent build era -setTxProtocolParams v txBodyContent = txBodyContent { txProtocolParams = v } +setTxProtocolParams + :: BuildTxWith build (Maybe (LedgerProtocolParameters era)) + -> TxBodyContent build era + -> TxBodyContent build era +setTxProtocolParams v txBodyContent = txBodyContent {txProtocolParams = v} setTxWithdrawals :: TxWithdrawals build era -> TxBodyContent build era -> TxBodyContent build era -setTxWithdrawals v txBodyContent = txBodyContent { txWithdrawals = v } +setTxWithdrawals v txBodyContent = txBodyContent {txWithdrawals = v} setTxCertificates :: TxCertificates build era -> TxBodyContent build era -> TxBodyContent build era -setTxCertificates v txBodyContent = txBodyContent { txCertificates = v } +setTxCertificates v txBodyContent = txBodyContent {txCertificates = v} setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era -setTxUpdateProposal v txBodyContent = txBodyContent { txUpdateProposal = v } +setTxUpdateProposal v txBodyContent = txBodyContent {txUpdateProposal = v} setTxMintValue :: TxMintValue build era -> TxBodyContent build era -> TxBodyContent build era -setTxMintValue v txBodyContent = txBodyContent { txMintValue = v } +setTxMintValue v txBodyContent = txBodyContent {txMintValue = v} setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era -setTxScriptValidity v txBodyContent = txBodyContent { txScriptValidity = v } +setTxScriptValidity v txBodyContent = txBodyContent {txScriptValidity = v} -setTxCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era -setTxCurrentTreasuryValue v txBodyContent = txBodyContent { txCurrentTreasuryValue = v } +setTxCurrentTreasuryValue + :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era +setTxCurrentTreasuryValue v txBodyContent = txBodyContent {txCurrentTreasuryValue = v} -setTxTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era -setTxTreasuryDonation v txBodyContent = txBodyContent { txTreasuryDonation = v } +setTxTreasuryDonation + :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era +setTxTreasuryDonation v txBodyContent = txBodyContent {txTreasuryDonation = v} getTxIdByron :: Byron.ATxAux ByteString -> TxId -getTxIdByron (Byron.ATxAux { Byron.aTaTx = txbody }) = - TxId - . fromMaybe impossible - . Crypto.hashFromBytesShort - . Byron.abstractHashToShort - . Byron.hashDecoded - $ txbody - where - impossible = - error "getTxIdByron: byron and shelley hash sizes do not match" +getTxIdByron (Byron.ATxAux {Byron.aTaTx = txbody}) = + TxId + . fromMaybe impossible + . Crypto.hashFromBytesShort + . Byron.abstractHashToShort + . Byron.hashDecoded + $ txbody + where + impossible = + error "getTxIdByron: byron and shelley hash sizes do not match" -- | Calculate the transaction identifier for a 'TxBody'. --- getTxId :: TxBody era -> TxId getTxId (ShelleyTxBody sbe tx _ _ _ _) = shelleyBasedEraConstraints sbe $ getTxIdShelley sbe tx @@ -1348,27 +1399,27 @@ getTxIdShelley => Ledger.EraTxBody (ShelleyLedgerEra era) => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxId getTxIdShelley _ tx = - TxId - . Crypto.castHash - . (\(Ledger.TxId txhash) -> SafeHash.extractHash txhash) - $ Ledger.txIdTxBody tx + TxId + . Crypto.castHash + . (\(Ledger.TxId txhash) -> SafeHash.extractHash txhash) + $ Ledger.txIdTxBody tx -- ---------------------------------------------------------------------------- -- Constructing transaction bodies -- -data TxBodyError = - TxBodyEmptyTxIns - | TxBodyEmptyTxInsCollateral - | TxBodyEmptyTxOuts - | TxBodyOutputNegative !Quantity !TxOutInAnyEra - | TxBodyOutputOverflow !Quantity !TxOutInAnyEra - | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] - | TxBodyMintAdaError - | TxBodyInIxOverflow !TxIn - | TxBodyMissingProtocolParams - | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError - deriving (Eq, Show) +data TxBodyError + = TxBodyEmptyTxIns + | TxBodyEmptyTxInsCollateral + | TxBodyEmptyTxOuts + | TxBodyOutputNegative !Quantity !TxOutInAnyEra + | TxBodyOutputOverflow !Quantity !TxOutInAnyEra + | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] + | TxBodyMintAdaError + | TxBodyInIxOverflow !TxIn + | TxBodyMissingProtocolParams + | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError + deriving (Eq, Show) instance Error TxBodyError where prettyError = \case @@ -1379,34 +1430,42 @@ instance Error TxBodyError where TxBodyEmptyTxOuts -> "Transaction body has no outputs" TxBodyOutputNegative (Quantity q) txout -> - "Negative quantity (" <> pretty q <> ") in transaction output: " <> - pretty txout + "Negative quantity (" + <> pretty q + <> ") in transaction output: " + <> pretty txout TxBodyOutputOverflow (Quantity q) txout -> - "Quantity too large (" <> pretty q <> " >= 2^64) in transaction output: " <> - pretty txout + "Quantity too large (" + <> pretty q + <> " >= 2^64) in transaction output: " + <> pretty txout TxBodyMetadataError [(k, err)] -> "Error in metadata entry " <> pretty k <> ": " <> prettyError err TxBodyMetadataError errs -> mconcat [ "Error in metadata entries: " - , mconcat $ List.intersperse "; " - [ pretty k <> ": " <> prettyError err - | (k, err) <- errs - ] + , mconcat $ + List.intersperse + "; " + [ pretty k <> ": " <> prettyError err + | (k, err) <- errs + ] ] TxBodyMintAdaError -> "Transaction cannot mint ada, only non-ada assets" TxBodyMissingProtocolParams -> - "Transaction uses Plutus scripts but does not provide the protocol " <> - "parameters to hash" + "Transaction uses Plutus scripts but does not provide the protocol " + <> "parameters to hash" TxBodyInIxOverflow txin -> - "Transaction input index is too big, " <> - "acceptable value is up to 2^32-1, " <> - "in input " <> pretty txin + "Transaction input index is too big, " + <> "acceptable value is up to 2^32-1, " + <> "in input " + <> pretty txin TxBodyProtocolParamsConversionError ppces -> "Errors in protocol parameters conversion: " <> prettyError ppces -createTransactionBody :: () +createTransactionBody + :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) @@ -1445,7 +1504,9 @@ createTransactionBody sbe bc = pure $ Endo $ A.mintTxBodyL w .~ convMintValue apiMintValue setScriptIntegrityHash <- monoidForEraInEonA era $ \w -> - pure $ Endo $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData + pure $ + Endo $ + A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData setCollateralInputs <- monoidForEraInEonA era $ \w -> pure $ Endo $ A.collateralInputsTxBodyL w .~ collTxIns @@ -1464,10 +1525,10 @@ createTransactionBody sbe bc = let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData - & A.certsTxBodyL sbe .~ certs + & A.certsTxBodyL sbe .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) & appEndo - ( mconcat + ( mconcat [ setUpdateProposal , setInvalidBefore , setMint @@ -1478,14 +1539,15 @@ createTransactionBody sbe bc = , setCollateralReturn , setTotalCollateral ] - ) + ) -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe (ledgerTxBody ^. A.txBodyL) scripts sData txAuxData apiScriptValidity -getScriptIntegrityHash :: () +getScriptIntegrityHash + :: () => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) -> Set Plutus.Language -> TxBodyScriptData era @@ -1499,63 +1561,67 @@ validateTxBodyContent :: ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError () -validateTxBodyContent sbe txBodContent@TxBodyContent { - txIns, - txInsCollateral, - txOuts, - txProtocolParams, - txMintValue, - txMetadata} = - let witnesses = collectTxBodyScriptWitnesses sbe txBodContent - languages = Set.fromList - [ toAlonzoLanguage (AnyPlutusScriptVersion v) - | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses - ] - in case sbe of - ShelleyBasedEraShelley -> do - validateTxIns txIns - guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts sbe txOuts - validateMetadata txMetadata - ShelleyBasedEraAllegra -> do - validateTxIns txIns - guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts sbe txOuts - validateMetadata txMetadata - ShelleyBasedEraMary -> do - validateTxIns txIns - guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts sbe txOuts - validateMetadata txMetadata - validateMintValue txMintValue - ShelleyBasedEraAlonzo -> do - validateTxIns txIns - guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts sbe txOuts - validateMetadata txMetadata - validateMintValue txMintValue - validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages - ShelleyBasedEraBabbage -> do - validateTxIns txIns - guardShelleyTxInsOverflow (map fst txIns) - validateTxOuts sbe txOuts - validateMetadata txMetadata - validateMintValue txMintValue - validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages - ShelleyBasedEraConway -> do - validateTxIns txIns - validateTxOuts sbe txOuts - validateMetadata txMetadata - validateMintValue txMintValue - validateTxInsCollateral txInsCollateral languages - validateProtocolParameters txProtocolParams languages +validateTxBodyContent + sbe + txBodContent@TxBodyContent + { txIns + , txInsCollateral + , txOuts + , txProtocolParams + , txMintValue + , txMetadata + } = + let witnesses = collectTxBodyScriptWitnesses sbe txBodContent + languages = + Set.fromList + [ toAlonzoLanguage (AnyPlutusScriptVersion v) + | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses + ] + in case sbe of + ShelleyBasedEraShelley -> do + validateTxIns txIns + guardShelleyTxInsOverflow (map fst txIns) + validateTxOuts sbe txOuts + validateMetadata txMetadata + ShelleyBasedEraAllegra -> do + validateTxIns txIns + guardShelleyTxInsOverflow (map fst txIns) + validateTxOuts sbe txOuts + validateMetadata txMetadata + ShelleyBasedEraMary -> do + validateTxIns txIns + guardShelleyTxInsOverflow (map fst txIns) + validateTxOuts sbe txOuts + validateMetadata txMetadata + validateMintValue txMintValue + ShelleyBasedEraAlonzo -> do + validateTxIns txIns + guardShelleyTxInsOverflow (map fst txIns) + validateTxOuts sbe txOuts + validateMetadata txMetadata + validateMintValue txMintValue + validateTxInsCollateral txInsCollateral languages + validateProtocolParameters txProtocolParams languages + ShelleyBasedEraBabbage -> do + validateTxIns txIns + guardShelleyTxInsOverflow (map fst txIns) + validateTxOuts sbe txOuts + validateMetadata txMetadata + validateMintValue txMintValue + validateTxInsCollateral txInsCollateral languages + validateProtocolParameters txProtocolParams languages + ShelleyBasedEraConway -> do + validateTxIns txIns + validateTxOuts sbe txOuts + validateMetadata txMetadata + validateMintValue txMintValue + validateTxInsCollateral txInsCollateral languages + validateProtocolParameters txProtocolParams languages validateMetadata :: TxMetadataInEra era -> Either TxBodyError () validateMetadata txMetadata = case txMetadata of - TxMetadataNone -> return () + TxMetadataNone -> return () TxMetadataInEra _ m -> first TxBodyMetadataError (validateTxMetadata m) validateProtocolParameters @@ -1564,17 +1630,18 @@ validateProtocolParameters -> Either TxBodyError () validateProtocolParameters txProtocolParams languages = case txProtocolParams of - BuildTxWith Nothing | not (Set.null languages) - -> Left TxBodyMissingProtocolParams - _ -> return () --TODO alonzo: validate protocol params for the Alonzo era. - -- All the necessary params must be provided. - + BuildTxWith Nothing + | not (Set.null languages) -> + Left TxBodyMissingProtocolParams + _ -> return () -- TODO alonzo: validate protocol params for the Alonzo era. + -- All the necessary params must be provided. validateTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] -> Either TxBodyError () validateTxIns txIns = - sequence_ [ inputIndexDoesNotExceedMax txIns - , txBodyContentHasTxIns txIns - ] + sequence_ + [ inputIndexDoesNotExceedMax txIns + , txBodyContentHasTxIns txIns + ] validateTxInsCollateral :: TxInsCollateral era -> Set Plutus.Language -> Either TxBodyError () @@ -1593,40 +1660,41 @@ validateTxOuts sbe txOuts = do [ do positiveOutput era (txOutValueToValue v) txout outputDoesNotExceedMax era (txOutValueToValue v) txout - | txout@(TxOut _ v _ _) <- txOuts - ] + | txout@(TxOut _ v _ _) <- txOuts + ] validateMintValue :: TxMintValue build era -> Either TxBodyError () validateMintValue txMintValue = case txMintValue of - TxMintNone -> return () + TxMintNone -> return () TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError - inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = - for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) -> - guard (fromIntegral txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin + for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) -> + guard (fromIntegral txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin -outputDoesNotExceedMax :: () +outputDoesNotExceedMax + :: () => CardanoEra era -> Value -> TxOut CtxTx era -> Either TxBodyError () outputDoesNotExceedMax era v txout = - case [ q | (_,q) <- valueToList v, q > maxTxOut ] of - [] -> Right () - q:_ -> Left (TxBodyOutputOverflow q (txOutInAnyEra era txout)) + case [q | (_, q) <- valueToList v, q > maxTxOut] of + [] -> Right () + q : _ -> Left (TxBodyOutputOverflow q (txOutInAnyEra era txout)) -positiveOutput :: () +positiveOutput + :: () => CardanoEra era -> Value -> TxOut CtxTx era -> Either TxBodyError () positiveOutput era v txout = - case [ q | (_, q) <- valueToList v, q < 0 ] of - [] -> Right () - q:_ -> Left (TxBodyOutputNegative q (txOutInAnyEra era txout)) + case [q | (_, q) <- valueToList v, q < 0] of + [] -> Right () + q : _ -> Left (TxBodyOutputNegative q (txOutInAnyEra era txout)) txBodyContentHasTxIns :: TxIns BuildTx era -> Either TxBodyError () txBodyContentHasTxIns txIns = guard (not (null txIns)) ?! TxBodyEmptyTxIns @@ -1637,7 +1705,8 @@ maxShelleyTxInIx = fromIntegral $ maxBound @Word16 maxTxOut :: Quantity maxTxOut = fromIntegral (maxBound :: Word64) -createAndValidateTransactionBody :: () +createAndValidateTransactionBody + :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) @@ -1645,6 +1714,7 @@ createAndValidateTransactionBody = makeShelleyTransactionBody pattern TxBody :: TxBodyContent ViewTx era -> TxBody era pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent) + {-# COMPLETE TxBody #-} getTxBodyContent :: TxBody era -> TxBodyContent ViewTx era @@ -1660,32 +1730,32 @@ fromLedgerTxBody -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> TxBodyContent ViewTx era fromLedgerTxBody sbe scriptValidity body scriptdata mAux = - TxBodyContent - { txIns = fromLedgerTxIns sbe body - , txInsCollateral = fromLedgerTxInsCollateral sbe body - , txInsReference = fromLedgerTxInsReference sbe body - , txOuts = fromLedgerTxOuts sbe body scriptdata - , txTotalCollateral = fromLedgerTxTotalCollateral sbe body - , txReturnCollateral = fromLedgerTxReturnCollateral sbe body - , txFee = fromLedgerTxFee sbe body - , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe (A.TxBody body) - , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe (A.TxBody body) - , txWithdrawals = fromLedgerTxWithdrawals sbe body - , txCertificates = fromLedgerTxCertificates sbe body - , txUpdateProposal = maybeFromLedgerTxUpdateProposal sbe body - , txMintValue = fromLedgerTxMintValue sbe body - , txExtraKeyWits = fromLedgerTxExtraKeyWitnesses sbe body - , txProtocolParams = ViewTx - , txMetadata - , txAuxScripts - , txScriptValidity = scriptValidity - , txProposalProcedures = fromLedgerProposalProcedures sbe body - , txVotingProcedures = fromLedgerVotingProcedures sbe body - , txCurrentTreasuryValue = fromLedgerCurrentTreasuryValue sbe body - , txTreasuryDonation = fromLedgerTreasuryDonation sbe body - } - where - (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux + TxBodyContent + { txIns = fromLedgerTxIns sbe body + , txInsCollateral = fromLedgerTxInsCollateral sbe body + , txInsReference = fromLedgerTxInsReference sbe body + , txOuts = fromLedgerTxOuts sbe body scriptdata + , txTotalCollateral = fromLedgerTxTotalCollateral sbe body + , txReturnCollateral = fromLedgerTxReturnCollateral sbe body + , txFee = fromLedgerTxFee sbe body + , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe (A.TxBody body) + , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe (A.TxBody body) + , txWithdrawals = fromLedgerTxWithdrawals sbe body + , txCertificates = fromLedgerTxCertificates sbe body + , txUpdateProposal = maybeFromLedgerTxUpdateProposal sbe body + , txMintValue = fromLedgerTxMintValue sbe body + , txExtraKeyWits = fromLedgerTxExtraKeyWitnesses sbe body + , txProtocolParams = ViewTx + , txMetadata + , txAuxScripts + , txScriptValidity = scriptValidity + , txProposalProcedures = fromLedgerProposalProcedures sbe body + , txVotingProcedures = fromLedgerVotingProcedures sbe body + , txCurrentTreasuryValue = fromLedgerCurrentTreasuryValue sbe body + , txTreasuryDonation = fromLedgerTreasuryDonation sbe body + } + where + (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux fromLedgerProposalProcedures :: ShelleyBasedEra era @@ -1693,69 +1763,74 @@ fromLedgerProposalProcedures -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era)) fromLedgerProposalProcedures sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> - conwayEraOnwardsConstraints w - $ Featured w - $ TxProposalProcedures - (body ^. L.proposalProceduresTxBodyL) - ViewTx + conwayEraOnwardsConstraints w $ + Featured w $ + TxProposalProcedures + (body ^. L.proposalProceduresTxBodyL) + ViewTx -fromLedgerVotingProcedures :: () +fromLedgerVotingProcedures + :: () => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe (Featured ConwayEraOnwards era (TxVotingProcedures ViewTx era)) fromLedgerVotingProcedures sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> - conwayEraOnwardsConstraints w - $ Featured w - $ TxVotingProcedures + conwayEraOnwardsConstraints w $ + Featured w $ + TxVotingProcedures (body ^. L.votingProceduresTxBodyL) ViewTx -fromLedgerCurrentTreasuryValue :: () +fromLedgerCurrentTreasuryValue + :: () => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe (Featured ConwayEraOnwards era Coin) fromLedgerCurrentTreasuryValue sbe body = caseShelleyToBabbageOrConwayEraOnwards (const Nothing) - (\cOnwards -> conwayEraOnwardsConstraints cOnwards $ - case body ^. L.currentTreasuryValueTxBodyL of - SNothing -> Nothing - SJust currentTreasuryValue -> Just $ Featured cOnwards currentTreasuryValue) + ( \cOnwards -> conwayEraOnwardsConstraints cOnwards $ + case body ^. L.currentTreasuryValueTxBodyL of + SNothing -> Nothing + SJust currentTreasuryValue -> Just $ Featured cOnwards currentTreasuryValue + ) sbe -fromLedgerTreasuryDonation :: () +fromLedgerTreasuryDonation + :: () => ShelleyBasedEra era -> L.TxBody (ShelleyLedgerEra era) -> Maybe (Featured ConwayEraOnwards era Coin) fromLedgerTreasuryDonation sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> - conwayEraOnwardsConstraints w - $ Featured w (body ^. L.treasuryDonationTxBodyL) + conwayEraOnwardsConstraints w $ + Featured w (body ^. L.treasuryDonationTxBodyL) fromLedgerTxIns - :: forall era. - ShelleyBasedEra era + :: forall era + . ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) - -> [(TxIn,BuildTxWith ViewTx (Witness WitCtxTxIn era))] + -> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn era))] fromLedgerTxIns sbe body = - [ (fromShelleyTxIn input, ViewTx) - | input <- Set.toList (inputs_ sbe body) ] - where - inputs_ :: ShelleyBasedEra era - -> Ledger.TxBody (ShelleyLedgerEra era) - -> Set (Ledger.TxIn StandardCrypto) - inputs_ ShelleyBasedEraShelley = view L.inputsTxBodyL - inputs_ ShelleyBasedEraAllegra = view L.inputsTxBodyL - inputs_ ShelleyBasedEraMary = view L.inputsTxBodyL - inputs_ ShelleyBasedEraAlonzo = view L.inputsTxBodyL - inputs_ ShelleyBasedEraBabbage = view L.inputsTxBodyL - inputs_ ShelleyBasedEraConway = view L.inputsTxBodyL - + [ (fromShelleyTxIn input, ViewTx) + | input <- Set.toList (inputs_ sbe body) + ] + where + inputs_ + :: ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) + -> Set (Ledger.TxIn StandardCrypto) + inputs_ ShelleyBasedEraShelley = view L.inputsTxBodyL + inputs_ ShelleyBasedEraAllegra = view L.inputsTxBodyL + inputs_ ShelleyBasedEraMary = view L.inputsTxBodyL + inputs_ ShelleyBasedEraAlonzo = view L.inputsTxBodyL + inputs_ ShelleyBasedEraBabbage = view L.inputsTxBodyL + inputs_ ShelleyBasedEraConway = view L.inputsTxBodyL fromLedgerTxInsCollateral - :: forall era. - ShelleyBasedEra era + :: forall era + . ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsCollateral era fromLedgerTxInsCollateral sbe body = @@ -1773,28 +1848,25 @@ fromLedgerTxInsReference sbe txBody = sbe fromLedgerTxOuts - :: forall era. - ShelleyBasedEra era + :: forall era + . ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxBodyScriptData era -> [TxOut CtxTx era] fromLedgerTxOuts sbe body scriptdata = case sbe of ShelleyBasedEraShelley -> - [ fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL) ] - + [fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL)] ShelleyBasedEraAllegra -> - [ fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL) ] - + [fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL)] ShelleyBasedEraMary -> - [ fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL) ] - + [fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL)] ShelleyBasedEraAlonzo -> [ fromAlonzoTxOut AlonzoEraOnwardsAlonzo txout - | txout <- toList (body ^. L.outputsTxBodyL) ] - + | txout <- toList (body ^. L.outputsTxBodyL) + ] ShelleyBasedEraBabbage -> [ fromBabbageTxOut BabbageEraOnwardsBabbage @@ -1803,7 +1875,6 @@ fromLedgerTxOuts sbe body scriptdata = | let txdatums = selectTxDatums scriptdata , txouts <- toList (body ^. L.outputsTxBodyL) ] - ShelleyBasedEraConway -> [ fromBabbageTxOut BabbageEraOnwardsConway @@ -1819,8 +1890,8 @@ selectTxDatums selectTxDatums TxBodyNoScriptData = Map.empty selectTxDatums (TxBodyScriptData _ (Alonzo.TxDats' datums) _) = datums - -fromAlonzoTxOut :: () +fromAlonzoTxOut + :: () => AlonzoEraOnwards era -> L.TxOut (ShelleyLedgerEra era) -> TxOut CtxTx era @@ -1831,10 +1902,12 @@ fromAlonzoTxOut w txOut = (TxOutValueShelleyBased sbe (txOut ^. L.valueTxOutL)) TxOutDatumNone ReferenceScriptNone - where - sbe = alonzoEraOnwardsToShelleyBasedEra w + where + sbe = alonzoEraOnwardsToShelleyBasedEra w -fromBabbageTxOut :: forall era. () +fromBabbageTxOut + :: forall era + . () => BabbageEraOnwards era -> Map (L.DataHash StandardCrypto) (L.Data (ShelleyLedgerEra era)) -> L.TxOut (ShelleyLedgerEra era) @@ -1845,29 +1918,28 @@ fromBabbageTxOut w txdatums txout = (fromShelleyAddr shelleyBasedEra (txout ^. L.addrTxOutL)) (TxOutValueShelleyBased sbe (txout ^. L.valueTxOutL)) babbageTxOutDatum - (case txout ^. L.referenceScriptTxOutL of - SNothing -> ReferenceScriptNone - SJust rScript -> fromShelleyScriptToReferenceScript shelleyBasedEra rScript + ( case txout ^. L.referenceScriptTxOutL of + SNothing -> ReferenceScriptNone + SJust rScript -> fromShelleyScriptToReferenceScript shelleyBasedEra rScript ) - where - sbe = babbageEraOnwardsToShelleyBasedEra w - - -- NOTE: This is different to 'fromBabbageTxOutDatum' as it may resolve - -- 'DatumHash' values using the datums included in the transaction. - babbageTxOutDatum :: TxOutDatum CtxTx era - babbageTxOutDatum = - babbageEraOnwardsConstraints w $ - case txout ^. L.datumTxOutL of - L.NoDatum -> TxOutDatumNone - L.DatumHash dh -> resolveDatumInTx dh - L.Datum d -> TxOutDatumInline w $ binaryDataToScriptData w d - - resolveDatumInTx :: L.DataHash StandardCrypto -> TxOutDatum CtxTx era - resolveDatumInTx dh - | Just d <- Map.lookup dh txdatums - = TxOutDatumInTx' (babbageEraOnwardsToAlonzoEraOnwards w) (ScriptDataHash dh) (fromAlonzoData d) - | otherwise = TxOutDatumHash (babbageEraOnwardsToAlonzoEraOnwards w) (ScriptDataHash dh) - + where + sbe = babbageEraOnwardsToShelleyBasedEra w + + -- NOTE: This is different to 'fromBabbageTxOutDatum' as it may resolve + -- 'DatumHash' values using the datums included in the transaction. + babbageTxOutDatum :: TxOutDatum CtxTx era + babbageTxOutDatum = + babbageEraOnwardsConstraints w $ + case txout ^. L.datumTxOutL of + L.NoDatum -> TxOutDatumNone + L.DatumHash dh -> resolveDatumInTx dh + L.Datum d -> TxOutDatumInline w $ binaryDataToScriptData w d + + resolveDatumInTx :: L.DataHash StandardCrypto -> TxOutDatum CtxTx era + resolveDatumInTx dh + | Just d <- Map.lookup dh txdatums = + TxOutDatumInTx' (babbageEraOnwardsToAlonzoEraOnwards w) (ScriptDataHash dh) (fromAlonzoData d) + | otherwise = TxOutDatumHash (babbageEraOnwardsToAlonzoEraOnwards w) (ScriptDataHash dh) fromLedgerTxTotalCollateral :: ShelleyBasedEra era @@ -1876,10 +1948,10 @@ fromLedgerTxTotalCollateral fromLedgerTxTotalCollateral sbe txbody = caseShelleyToAlonzoOrBabbageEraOnwards (const TxTotalCollateralNone) - (\w -> - case txbody ^. L.totalCollateralTxBodyL of - SNothing -> TxTotalCollateralNone - SJust totColl -> TxTotalCollateral w totColl + ( \w -> + case txbody ^. L.totalCollateralTxBodyL of + SNothing -> TxTotalCollateralNone + SJust totColl -> TxTotalCollateral w totColl ) sbe @@ -1890,19 +1962,19 @@ fromLedgerTxReturnCollateral fromLedgerTxReturnCollateral sbe txbody = caseShelleyToAlonzoOrBabbageEraOnwards (const TxReturnCollateralNone) - (\w -> - case txbody ^. L.collateralReturnTxBodyL of - SNothing -> TxReturnCollateralNone - SJust collReturnOut -> TxReturnCollateral w $ fromShelleyTxOut sbe collReturnOut + ( \w -> + case txbody ^. L.collateralReturnTxBodyL of + SNothing -> TxReturnCollateralNone + SJust collReturnOut -> TxReturnCollateral w $ fromShelleyTxOut sbe collReturnOut ) sbe fromLedgerTxFee :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxFee era fromLedgerTxFee sbe body = - shelleyBasedEraConstraints sbe - $ TxFeeExplicit sbe - $ body ^. L.feeTxBodyL + shelleyBasedEraConstraints sbe $ + TxFeeExplicit sbe $ + body ^. L.feeTxBodyL fromLedgerTxValidityLowerBound :: ShelleyBasedEra era @@ -1911,11 +1983,11 @@ fromLedgerTxValidityLowerBound fromLedgerTxValidityLowerBound sbe body = caseShelleyEraOnlyOrAllegraEraOnwards (const TxValidityNoLowerBound) - (\w -> - let mInvalidBefore = body ^. A.invalidBeforeTxBodyL w in - case mInvalidBefore of - Nothing -> TxValidityNoLowerBound - Just s -> TxValidityLowerBound w s + ( \w -> + let mInvalidBefore = body ^. A.invalidBeforeTxBodyL w + in case mInvalidBefore of + Nothing -> TxValidityNoLowerBound + Just s -> TxValidityLowerBound w s ) sbe @@ -1942,18 +2014,18 @@ fromLedgerAuxiliaryData ShelleyBasedEraMary (L.AllegraTxAuxData ms ss) = ) fromLedgerAuxiliaryData ShelleyBasedEraAlonzo txAuxData = ( fromShelleyMetadata (L.atadMetadata txAuxData) - , fromShelleyBasedScript ShelleyBasedEraAlonzo <$> - toList (L.getAlonzoTxAuxDataScripts txAuxData) + , fromShelleyBasedScript ShelleyBasedEraAlonzo + <$> toList (L.getAlonzoTxAuxDataScripts txAuxData) ) fromLedgerAuxiliaryData ShelleyBasedEraBabbage txAuxData = ( fromShelleyMetadata (L.atadMetadata txAuxData) - , fromShelleyBasedScript ShelleyBasedEraBabbage <$> - toList (L.getAlonzoTxAuxDataScripts txAuxData) + , fromShelleyBasedScript ShelleyBasedEraBabbage + <$> toList (L.getAlonzoTxAuxDataScripts txAuxData) ) fromLedgerAuxiliaryData ShelleyBasedEraConway txAuxData = ( fromShelleyMetadata (L.atadMetadata txAuxData) - , fromShelleyBasedScript ShelleyBasedEraConway <$> - toList (L.getAlonzoTxAuxDataScripts txAuxData) + , fromShelleyBasedScript ShelleyBasedEraConway + <$> toList (L.getAlonzoTxAuxDataScripts txAuxData) ) fromLedgerTxAuxiliaryData @@ -1963,38 +2035,38 @@ fromLedgerTxAuxiliaryData fromLedgerTxAuxiliaryData _ Nothing = (TxMetadataNone, TxAuxScriptsNone) fromLedgerTxAuxiliaryData sbe (Just auxData) = (metadata, auxdata) + where + metadata = if null ms then TxMetadataNone else TxMetadataInEra sbe $ TxMetadata ms - where - metadata = if null ms then TxMetadataNone else TxMetadataInEra sbe $ TxMetadata ms - - auxdata = - caseShelleyEraOnlyOrAllegraEraOnwards - (const TxAuxScriptsNone) - (\w -> + auxdata = + caseShelleyEraOnlyOrAllegraEraOnwards + (const TxAuxScriptsNone) + ( \w -> case ss of - [] -> TxAuxScriptsNone - _ -> TxAuxScripts w ss - ) - sbe - - (ms, ss) = fromLedgerAuxiliaryData sbe auxData + [] -> TxAuxScriptsNone + _ -> TxAuxScripts w ss + ) + sbe + (ms, ss) = fromLedgerAuxiliaryData sbe auxData -fromLedgerTxExtraKeyWitnesses :: ShelleyBasedEra era - -> Ledger.TxBody (ShelleyLedgerEra era) - -> TxExtraKeyWitnesses era +fromLedgerTxExtraKeyWitnesses + :: ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) + -> TxExtraKeyWitnesses era fromLedgerTxExtraKeyWitnesses sbe body = caseShelleyToMaryOrAlonzoEraOnwards (const TxExtraKeyWitnessesNone) - (\w -> - let keyhashes = body ^. L.reqSignerHashesTxBodyL in - if Set.null keyhashes - then TxExtraKeyWitnessesNone - else - TxExtraKeyWitnesses w - [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) - | keyhash <- Set.toList $ body ^. L.reqSignerHashesTxBodyL - ] + ( \w -> + let keyhashes = body ^. L.reqSignerHashesTxBodyL + in if Set.null keyhashes + then TxExtraKeyWitnessesNone + else + TxExtraKeyWitnesses + w + [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) + | keyhash <- Set.toList $ body ^. L.reqSignerHashesTxBodyL + ] ) sbe @@ -2004,10 +2076,10 @@ fromLedgerTxWithdrawals -> TxWithdrawals ViewTx era fromLedgerTxWithdrawals sbe body = shelleyBasedEraConstraints sbe $ - let withdrawals = body ^. L.withdrawalsTxBodyL in - if null (L.unWithdrawals withdrawals) - then TxWithdrawalsNone - else TxWithdrawals sbe $ fromShelleyWithdrawal withdrawals + let withdrawals = body ^. L.withdrawalsTxBodyL + in if null (L.unWithdrawals withdrawals) + then TxWithdrawalsNone + else TxWithdrawals sbe $ fromShelleyWithdrawal withdrawals fromLedgerTxCertificates :: ShelleyBasedEra era @@ -2015,21 +2087,22 @@ fromLedgerTxCertificates -> TxCertificates ViewTx era fromLedgerTxCertificates sbe body = shelleyBasedEraConstraints sbe $ - let certificates = body ^. L.certsTxBodyL in - if null certificates - then TxCertificatesNone - else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx + let certificates = body ^. L.certsTxBodyL + in if null certificates + then TxCertificatesNone + else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx -maybeFromLedgerTxUpdateProposal :: () +maybeFromLedgerTxUpdateProposal + :: () => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxUpdateProposal era maybeFromLedgerTxUpdateProposal sbe body = caseShelleyToBabbageOrConwayEraOnwards - (\w -> - case body ^. L.updateTxBodyL of - SNothing -> TxUpdateProposalNone - SJust p -> TxUpdateProposal w (fromLedgerUpdate sbe p) + ( \w -> + case body ^. L.updateTxBodyL of + SNothing -> TxUpdateProposalNone + SJust p -> TxUpdateProposal w (fromLedgerUpdate sbe p) ) (const TxUpdateProposalNone) sbe @@ -2042,50 +2115,50 @@ fromLedgerTxMintValue sbe body = case sbe of ShelleyBasedEraShelley -> TxMintNone ShelleyBasedEraAllegra -> TxMintNone - ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary - ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo + ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary + ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage - ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway - where - toMintValue txBody maInEra - | L.isZero mint = TxMintNone - | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx - where - mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL) - - -makeByronTransactionBody :: () + ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway + where + toMintValue txBody maInEra + | L.isZero mint = TxMintNone + | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx + where + mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL) + +makeByronTransactionBody + :: () => TxIns BuildTx ByronEra -> [TxOut CtxTx ByronEra] -> Either TxBodyError (Annotated Byron.Tx ByteString) makeByronTransactionBody txIns txOuts = do - ins' <- NonEmpty.nonEmpty (map fst txIns) ?! TxBodyEmptyTxIns - for_ ins' $ \txin@(TxIn _ (TxIx txix)) -> - guard (fromIntegral txix <= maxByronTxInIx) ?! TxBodyInIxOverflow txin - let ins'' = fmap toByronTxIn ins' - - outs' <- NonEmpty.nonEmpty txOuts ?! TxBodyEmptyTxOuts - outs'' <- traverse - (\out -> toByronTxOut out ?! classifyRangeError out) - outs' - return $ - CBOR.reAnnotate CBOR.byronProtVer $ - Annotated - (Byron.UnsafeTx ins'' outs'' (Byron.mkAttributes ())) - () - where - maxByronTxInIx :: Word - maxByronTxInIx = fromIntegral (maxBound :: Word32) + ins' <- NonEmpty.nonEmpty (map fst txIns) ?! TxBodyEmptyTxIns + for_ ins' $ \txin@(TxIn _ (TxIx txix)) -> + guard (fromIntegral txix <= maxByronTxInIx) ?! TxBodyInIxOverflow txin + let ins'' = fmap toByronTxIn ins' + + outs' <- NonEmpty.nonEmpty txOuts ?! TxBodyEmptyTxOuts + outs'' <- + traverse + (\out -> toByronTxOut out ?! classifyRangeError out) + outs' + return $ + CBOR.reAnnotate CBOR.byronProtVer $ + Annotated + (Byron.UnsafeTx ins'' outs'' (Byron.mkAttributes ())) + () + where + maxByronTxInIx :: Word + maxByronTxInIx = fromIntegral (maxBound :: Word32) classifyRangeError :: TxOut CtxTx ByronEra -> TxBodyError classifyRangeError txout = case txout of - TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutValueByron value) _ _ + TxOut (AddressInEra ByronAddressInAnyEra ByronAddress {}) (TxOutValueByron value) _ _ | value < 0 -> TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) | otherwise -> TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValueShelleyBased w _) _ _ -> case w of {} - TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> case sbe of {} + TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress {}) _ _ _ -> case sbe of {} convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) convTxIns txIns = Set.fromList (map (toShelleyTxIn . fst) txIns) @@ -2112,37 +2185,38 @@ convTotalCollateral txTotalCollateral = TxTotalCollateral _ totCollLovelace -> SJust totCollLovelace convTxOuts - :: forall ctx era ledgerera. ShelleyLedgerEra era ~ ledgerera + :: forall ctx era ledgerera + . ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era -> [TxOut ctx era] -> Seq.StrictSeq (Ledger.TxOut ledgerera) convTxOuts sbe txOuts = Seq.fromList $ map (toShelleyTxOutAny sbe) txOuts - convCertificates :: ShelleyBasedEra era -> TxCertificates build era -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era)) convCertificates _ = \case - TxCertificatesNone -> Seq.empty + TxCertificatesNone -> Seq.empty TxCertificates _ cs _ -> Seq.fromList (map toShelleyCertificate cs) - convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto convWithdrawals txWithdrawals = case txWithdrawals of - TxWithdrawalsNone -> L.Withdrawals Map.empty + TxWithdrawalsNone -> L.Withdrawals Map.empty TxWithdrawals _ ws -> toShelleyWithdrawal ws convTransactionFee :: ShelleyBasedEra era -> TxFee era -> Ledger.Coin convTransactionFee _ (TxFeeExplicit _ fee) = fee -convValidityLowerBound :: () +convValidityLowerBound + :: () => TxValidityLowerBound era -> Maybe SlotNo convValidityLowerBound = \case - TxValidityNoLowerBound -> Nothing + TxValidityNoLowerBound -> Nothing TxValidityLowerBound _ s -> Just s -convValidityUpperBound :: () +convValidityUpperBound + :: () => ShelleyBasedEra era -> TxValidityUpperBound era -> Maybe SlotNo @@ -2150,7 +2224,8 @@ convValidityUpperBound _ = \case TxValidityUpperBound _ ms -> ms -- | Convert transaction update proposal into ledger update proposal -convTxUpdateProposal :: () +convTxUpdateProposal + :: () => ShelleyBasedEra era -> TxUpdateProposal era -> Either TxBodyError (StrictMaybe (Ledger.Update (ShelleyLedgerEra era))) @@ -2163,18 +2238,21 @@ convTxUpdateProposal sbe = \case convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto convMintValue txMintValue = case txMintValue of - TxMintNone -> mempty + TxMintNone -> mempty TxMintValue _ v _ -> case toMaryValue v of MaryValue _ ma -> ma -convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto) +convExtraKeyWitnesses + :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto) convExtraKeyWitnesses txExtraKeyWits = case txExtraKeyWits of - TxExtraKeyWitnessesNone -> Set.empty - TxExtraKeyWitnesses _ khs -> Set.fromList - [ Shelley.asWitness kh - | PaymentKeyHash kh <- khs ] + TxExtraKeyWitnessesNone -> Set.empty + TxExtraKeyWitnesses _ khs -> + Set.fromList + [ Shelley.asWitness kh + | PaymentKeyHash kh <- khs + ] convScripts :: ShelleyLedgerEra era ~ ledgerera @@ -2187,7 +2265,8 @@ convScripts scriptWitnesses = ] -- ScriptData collectively refers to datums and/or redeemers -convScriptData :: () +convScriptData + :: () => ShelleyBasedEra era -> [TxOut CtxTx era] -> [(ScriptWitnessIndex, AnyScriptWitness era)] @@ -2195,36 +2274,50 @@ convScriptData :: () convScriptData sbe txOuts scriptWitnesses = caseShelleyToMaryOrAlonzoEraOnwards (const TxBodyNoScriptData) - (\w -> - let redeemers = - Alonzo.Redeemers $ - Map.fromList - [ (i, (toAlonzoData d, toAlonzoExUnits e)) - | (idx, AnyScriptWitness - (PlutusScriptWitness _ _ _ _ d e)) <- scriptWitnesses - , Just i <- [fromScriptWitnessIndex w idx] - ] - - datums = - Alonzo.TxDats $ - Map.fromList - [ (L.hashData d', d') - | d <- scriptdata - , let d' = toAlonzoData d - ] - - scriptdata :: [HashableScriptData] - scriptdata = - [ d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts ] - ++ [ d | (_, AnyScriptWitness - (PlutusScriptWitness - _ _ _ (ScriptDatumForTxIn d) _ _)) <- scriptWitnesses + ( \w -> + let redeemers = + Alonzo.Redeemers $ + Map.fromList + [ (i, (toAlonzoData d, toAlonzoExUnits e)) + | ( idx + , AnyScriptWitness + (PlutusScriptWitness _ _ _ _ d e) + ) <- + scriptWitnesses + , Just i <- [fromScriptWitnessIndex w idx] + ] + + datums = + Alonzo.TxDats $ + Map.fromList + [ (L.hashData d', d') + | d <- scriptdata + , let d' = toAlonzoData d ] - in TxBodyScriptData w datums redeemers + + scriptdata :: [HashableScriptData] + scriptdata = + [d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts] + ++ [ d + | ( _ + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn d) + _ + _ + ) + ) <- + scriptWitnesses + ] + in TxBodyScriptData w datums redeemers ) sbe -convPParamsToScriptIntegrityHash :: () +convPParamsToScriptIntegrityHash + :: () => AlonzoEraOnwards era -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) -> Alonzo.Redeemers (ShelleyLedgerEra era) @@ -2251,7 +2344,8 @@ convReferenceInputs txInsReference = TxInsReferenceNone -> mempty TxInsReference _ refTxins -> Set.fromList $ map toShelleyTxIn refTxins -convProposalProcedures :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) +convProposalProcedures + :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty convProposalProcedures (TxProposalProcedures procedures _) = procedures @@ -2263,12 +2357,13 @@ convVotingProcedures txVotingProcedures = guardShelleyTxInsOverflow :: [TxIn] -> Either TxBodyError () guardShelleyTxInsOverflow txIns = do - for_ txIns $ \txin@(TxIn _ (TxIx txix)) -> - guard (txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin + for_ txIns $ \txin@(TxIn _ (TxIx txix)) -> + guard (txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin -- | A helper function that constructs a TxBody with all of the fields that are common for -- all eras -mkCommonTxBody :: () +mkCommonTxBody + :: () => ShelleyBasedEra era -> TxIns BuildTx era -> [TxOut ctx era] @@ -2277,162 +2372,175 @@ mkCommonTxBody :: () -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> A.TxBody era mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData = - shelleyBasedEraConstraints sbe $ A.TxBody $ - L.mkBasicTxBody - & L.inputsTxBodyL .~ convTxIns txIns - & L.outputsTxBodyL .~ convTxOuts sbe txOuts - & L.feeTxBodyL .~ convTransactionFee sbe txFee - & L.withdrawalsTxBodyL .~ convWithdrawals txWithdrawals - & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData - - -makeShelleyTransactionBody :: forall era. () + shelleyBasedEraConstraints sbe $ + A.TxBody $ + L.mkBasicTxBody + & L.inputsTxBodyL .~ convTxIns txIns + & L.outputsTxBodyL .~ convTxOuts sbe txOuts + & L.feeTxBodyL .~ convTransactionFee sbe txFee + & L.withdrawalsTxBodyL .~ convWithdrawals txWithdrawals + & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData + +makeShelleyTransactionBody + :: forall era + . () => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -makeShelleyTransactionBody sbe@ShelleyBasedEraShelley - txbodycontent@TxBodyContent { - txIns, - txOuts, - txFee, - txValidityUpperBound, - txMetadata, - txWithdrawals, - txCertificates, - txUpdateProposal - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraShelley + txbodycontent@TxBodyContent + { txIns + , txOuts + , txFee + , txValidityUpperBound + , txMetadata + , txWithdrawals + , txCertificates + , txUpdateProposal + } = do let s2b = ShelleyToBabbageEraShelley validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal let txbody = ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.updateTxBodyL s2b .~ update - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - ) ^. A.txBodyL + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.updateTxBodyL s2b .~ update + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts_ TxBodyNoScriptData txAuxData TxScriptValidityNone - where + where scripts_ :: [Ledger.Script StandardShelley] - scripts_ = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses sbe txbodycontent - ] + scripts_ = + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- + collectTxBodyScriptWitnesses sbe txbodycontent + ] txAuxData :: Maybe (L.TxAuxData StandardShelley) txAuxData = toAuxiliaryData sbe txMetadata TxAuxScriptsNone - -makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra - txbodycontent@TxBodyContent { - txIns, - txOuts, - txFee, - txValidityLowerBound, - txValidityUpperBound, - txMetadata, - txAuxScripts, - txWithdrawals, - txCertificates, - txUpdateProposal - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraAllegra + txbodycontent@TxBodyContent + { txIns + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txWithdrawals + , txCertificates + , txUpdateProposal + } = do let aOn = AllegraEraOnwardsAllegra let s2b = ShelleyToBabbageEraAllegra validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal let txbody = - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & A.updateTxBodyL s2b .~ update - ) ^. A.txBodyL + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts_ TxBodyNoScriptData txAuxData TxScriptValidityNone - where + where scripts_ :: [Ledger.Script StandardAllegra] - scripts_ = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses sbe txbodycontent - ] + scripts_ = + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- + collectTxBodyScriptWitnesses sbe txbodycontent + ] txAuxData :: Maybe (L.TxAuxData StandardAllegra) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - -makeShelleyTransactionBody sbe@ShelleyBasedEraMary - txbodycontent@TxBodyContent { - txIns, - txOuts, - txFee, - txValidityLowerBound, - txValidityUpperBound, - txMetadata, - txAuxScripts, - txWithdrawals, - txCertificates, - txUpdateProposal, - txMintValue - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraMary + txbodycontent@TxBodyContent + { txIns + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue + } = do let aOn = AllegraEraOnwardsMary let s2b = ShelleyToBabbageEraMary let mOn = MaryEraOnwardsMary validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal let txbody = - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & A.updateTxBodyL s2b .~ update - & A.mintTxBodyL mOn .~ convMintValue txMintValue - ) ^. A.txBodyL + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + & A.mintTxBodyL mOn .~ convMintValue txMintValue + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts TxBodyNoScriptData txAuxData TxScriptValidityNone - where + where scripts :: [Ledger.Script StandardMary] - scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses sbe txbodycontent - ] + scripts = + List.nub $ + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- + collectTxBodyScriptWitnesses sbe txbodycontent + ] txAuxData :: Maybe (L.TxAuxData StandardMary) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - -makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo - txbodycontent@TxBodyContent { - txIns, - txInsCollateral, - txOuts, - txFee, - txValidityLowerBound, - txValidityUpperBound, - txMetadata, - txAuxScripts, - txExtraKeyWits, - txProtocolParams, - txWithdrawals, - txCertificates, - txUpdateProposal, - txMintValue, - txScriptValidity - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraAlonzo + txbodycontent@TxBodyContent + { txIns + , txInsCollateral + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txExtraKeyWits + , txProtocolParams + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue + , txScriptValidity + } = do let aOn = AllegraEraOnwardsAlonzo let s2b = ShelleyToBabbageEraAlonzo let mOn = MaryEraOnwardsAlonzo @@ -2441,36 +2549,40 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsAlonzo txProtocolParams redeemers datums languages let txbody = - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.collateralInputsTxBodyL azOn .~ convCollateralTxIns txInsCollateral - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & A.updateTxBodyL s2b .~ update - & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits - & A.mintTxBodyL mOn .~ convMintValue txMintValue - & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash - -- TODO Alonzo: support optional network id in TxBodyContent - -- & L.networkIdTxBodyL .~ SNothing - ) ^. A.txBodyL + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn .~ convCollateralTxIns txInsCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash + -- TODO Alonzo: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts (TxBodyScriptData AlonzoEraOnwardsAlonzo datums redeemers) txAuxData txScriptValidity - where + where azOn = AlonzoEraOnwardsAlonzo witnesses :: [(ScriptWitnessIndex, AnyScriptWitness AlonzoEra)] witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardAlonzo] - scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) <- witnesses - ] + scripts = + List.nub $ + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- witnesses + ] datums :: Alonzo.TxDats StandardAlonzo datums = @@ -2482,19 +2594,32 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo scriptdata :: [HashableScriptData] scriptdata = - [ d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts ] - ++ [ d | (_, AnyScriptWitness - (PlutusScriptWitness - _ _ _ (ScriptDatumForTxIn d) _ _)) <- witnesses - ] + [d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts] + ++ [ d + | ( _ + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn d) + _ + _ + ) + ) <- + witnesses + ] redeemers :: Alonzo.Redeemers StandardAlonzo redeemers = Alonzo.Redeemers $ Map.fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) - | (idx, AnyScriptWitness - (PlutusScriptWitness _ _ _ _ d e)) <- witnesses + | ( idx + , AnyScriptWitness + (PlutusScriptWitness _ _ _ _ d e) + ) <- + witnesses , Just i <- [fromScriptWitnessIndex azOn idx] ] @@ -2507,28 +2632,28 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo txAuxData :: Maybe (L.TxAuxData StandardAlonzo) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - -makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage - txbodycontent@TxBodyContent { - txIns, - txInsCollateral, - txInsReference, - txReturnCollateral, - txTotalCollateral, - txOuts, - txFee, - txValidityLowerBound, - txValidityUpperBound, - txMetadata, - txAuxScripts, - txExtraKeyWits, - txProtocolParams, - txWithdrawals, - txCertificates, - txUpdateProposal, - txMintValue, - txScriptValidity - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraBabbage + txbodycontent@TxBodyContent + { txIns + , txInsCollateral + , txInsReference + , txReturnCollateral + , txTotalCollateral + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txExtraKeyWits + , txProtocolParams + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue + , txScriptValidity + } = do let aOn = AllegraEraOnwardsBabbage let mOn = MaryEraOnwardsBabbage let bOn = BabbageEraOnwardsBabbage @@ -2538,43 +2663,50 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsBabbage txProtocolParams redeemers datums languages let txbody = - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.collateralInputsTxBodyL azOn .~ - case txInsCollateral of - TxInsCollateralNone -> Set.empty - TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference - & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral - & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & A.updateTxBodyL s2b .~ update - & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits - & A.mintTxBodyL mOn .~ convMintValue txMintValue - & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash - -- TODO Babbage: support optional network id in TxBodyContent - -- & L.networkIdTxBodyL .~ SNothing - ) ^. A.txBodyL + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn + .~ case txInsCollateral of + TxInsCollateralNone -> Set.empty + TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) + & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference + & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral + & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash + -- TODO Babbage: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts - (TxBodyScriptData AlonzoEraOnwardsBabbage - datums redeemers) + ( TxBodyScriptData + AlonzoEraOnwardsBabbage + datums + redeemers + ) txAuxData txScriptValidity - where + where azOn = AlonzoEraOnwardsBabbage witnesses :: [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)] witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardBabbage] - scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) <- witnesses - ] + scripts = + List.nub $ + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- witnesses + ] -- Note these do not include inline datums! datums :: Alonzo.TxDats StandardBabbage @@ -2588,62 +2720,75 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage scriptdata :: [HashableScriptData] scriptdata = - [ d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts ] - ++ [ d | (_, AnyScriptWitness - (PlutusScriptWitness - _ _ _ (ScriptDatumForTxIn d) _ _)) <- witnesses - ] + [d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts] + ++ [ d + | ( _ + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn d) + _ + _ + ) + ) <- + witnesses + ] redeemers :: Alonzo.Redeemers StandardBabbage redeemers = Alonzo.Redeemers $ Map.fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) - | (idx, AnyScriptWitness - (PlutusScriptWitness _ _ _ _ d e)) <- witnesses + | ( idx + , AnyScriptWitness + (PlutusScriptWitness _ _ _ _ d e) + ) <- + witnesses , Just i <- [fromScriptWitnessIndex azOn idx] ] languages :: Set Plutus.Language languages = - Set.fromList $ catMaybes - [ getScriptLanguage sw - | (_, AnyScriptWitness sw) <- witnesses - ] + Set.fromList $ + catMaybes + [ getScriptLanguage sw + | (_, AnyScriptWitness sw) <- witnesses + ] getScriptLanguage :: ScriptWitness witctx era -> Maybe Plutus.Language getScriptLanguage (PlutusScriptWitness _ v _ _ _ _) = Just $ toAlonzoLanguage (AnyPlutusScriptVersion v) - getScriptLanguage SimpleScriptWitness{} = Nothing + getScriptLanguage SimpleScriptWitness {} = Nothing txAuxData :: Maybe (L.TxAuxData StandardBabbage) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - - -makeShelleyTransactionBody sbe@ShelleyBasedEraConway - txbodycontent@TxBodyContent { - txIns, - txInsCollateral, - txInsReference, - txReturnCollateral, - txTotalCollateral, - txOuts, - txFee, - txValidityLowerBound, - txValidityUpperBound, - txMetadata, - txAuxScripts, - txExtraKeyWits, - txProtocolParams, - txWithdrawals, - txCertificates, - txMintValue, - txScriptValidity, - txProposalProcedures, - txVotingProcedures, - txCurrentTreasuryValue, - txTreasuryDonation - } = do +makeShelleyTransactionBody + sbe@ShelleyBasedEraConway + txbodycontent@TxBodyContent + { txIns + , txInsCollateral + , txInsReference + , txReturnCollateral + , txTotalCollateral + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txExtraKeyWits + , txProtocolParams + , txWithdrawals + , txCertificates + , txMintValue + , txScriptValidity + , txProposalProcedures + , txVotingProcedures + , txCurrentTreasuryValue + , txTreasuryDonation + } = do let aOn = AllegraEraOnwardsConway let cOn = ConwayEraOnwardsConway let mOn = MaryEraOnwardsConway @@ -2652,46 +2797,55 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsConway txProtocolParams redeemers datums languages let txbody = - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & A.collateralInputsTxBodyL azOn .~ - case txInsCollateral of - TxInsCollateralNone -> Set.empty - TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference - & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral - & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral - & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits - & A.mintTxBodyL mOn .~ convMintValue txMintValue - & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash - & A.votingProceduresTxBodyL cOn .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured txVotingProcedures) - & A.proposalProceduresTxBodyL cOn .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) - & A.currentTreasuryValueTxBodyL cOn .~ (Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue)) - & A.treasuryDonationTxBodyL cOn .~ (maybe (L.Coin 0) unFeatured txTreasuryDonation) - -- TODO Conway: support optional network id in TxBodyContent - -- & L.networkIdTxBodyL .~ SNothing - ) ^. A.txBodyL + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn + .~ case txInsCollateral of + TxInsCollateralNone -> Set.empty + TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) + & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference + & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral + & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash + & A.votingProceduresTxBodyL cOn + .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured txVotingProcedures) + & A.proposalProceduresTxBodyL cOn + .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) + & A.currentTreasuryValueTxBodyL cOn + .~ (Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue)) + & A.treasuryDonationTxBodyL cOn .~ (maybe (L.Coin 0) unFeatured txTreasuryDonation) + -- TODO Conway: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) + ^. A.txBodyL return $ - ShelleyTxBody sbe + ShelleyTxBody + sbe txbody scripts - (TxBodyScriptData AlonzoEraOnwardsConway - datums redeemers) + ( TxBodyScriptData + AlonzoEraOnwardsConway + datums + redeemers + ) txAuxData txScriptValidity - where + where azOn = AlonzoEraOnwardsConway witnesses :: [(ScriptWitnessIndex, AnyScriptWitness ConwayEra)] witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardConway] - scripts = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness - | (_, AnyScriptWitness scriptwitness) <- witnesses - ] + scripts = + catMaybes + [ toShelleyScript <$> scriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- witnesses + ] -- Note these do not include inline datums! datums :: Alonzo.TxDats StandardConway @@ -2704,58 +2858,69 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway scriptdata :: [HashableScriptData] scriptdata = - [ d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts ] - ++ [ d | (_, AnyScriptWitness - (PlutusScriptWitness - _ _ _ (ScriptDatumForTxIn d) _ _)) <- witnesses - ] + [d | TxOut _ _ (TxOutDatumInTx _ d) _ <- txOuts] + ++ [ d + | ( _ + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn d) + _ + _ + ) + ) <- + witnesses + ] redeemers :: Alonzo.Redeemers StandardConway redeemers = Alonzo.Redeemers $ Map.fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) - | (idx, AnyScriptWitness - (PlutusScriptWitness _ _ _ _ d e)) <- witnesses + | ( idx + , AnyScriptWitness + (PlutusScriptWitness _ _ _ _ d e) + ) <- + witnesses , Just i <- [fromScriptWitnessIndex azOn idx] ] languages :: Set Plutus.Language languages = - Set.fromList $ catMaybes - [ getScriptLanguage sw - | (_, AnyScriptWitness sw) <- witnesses - ] + Set.fromList $ + catMaybes + [ getScriptLanguage sw + | (_, AnyScriptWitness sw) <- witnesses + ] getScriptLanguage :: ScriptWitness witctx era -> Maybe Plutus.Language getScriptLanguage (PlutusScriptWitness _ v _ _ _ _) = Just $ toAlonzoLanguage (AnyPlutusScriptVersion v) - getScriptLanguage SimpleScriptWitness{} = Nothing + getScriptLanguage SimpleScriptWitness {} = Nothing txAuxData :: Maybe (L.TxAuxData StandardConway) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts - -- | A variant of 'toShelleyTxOutAny that is used only internally to this module -- that works with a 'TxOut' in any context (including CtxTx) by ignoring -- embedded datums (taking only their hash). --- -toShelleyTxOutAny :: forall ctx era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> TxOut ctx era - -> Ledger.TxOut ledgerera +toShelleyTxOutAny + :: forall ctx era ledgerera + . ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> TxOut ctx era + -> Ledger.TxOut ledgerera toShelleyTxOutAny _ = \case TxOut _ (TxOutValueByron _) _ _ -> -- TODO: Temporary until we have basic tx -- construction functionality error "toShelleyTxOutAny: Expected a Shelley value" - TxOut addr (TxOutValueShelleyBased sbe value) txoutdata refScript -> caseShelleyToMaryOrAlonzoEraOnwards - (const $ L.mkBasicTxOut (toShelleyAddr addr) value - ) - (\case + (const $ L.mkBasicTxOut (toShelleyAddr addr) value) + ( \case AlonzoEraOnwardsAlonzo -> L.mkBasicTxOut (toShelleyAddr addr) value & L.dataHashTxOutL .~ toAlonzoTxOutDatumHash txoutdata @@ -2770,16 +2935,14 @@ toShelleyTxOutAny _ = \case ) sbe - -- ---------------------------------------------------------------------------- -- Script witnesses within the tx body -- -- | A 'ScriptWitness' in any 'WitCtx'. This lets us handle heterogeneous -- collections of script witnesses from multiple contexts. --- data AnyScriptWitness era where - AnyScriptWitness :: ScriptWitness witctx era -> AnyScriptWitness era + AnyScriptWitness :: ScriptWitness witctx era -> AnyScriptWitness era deriving instance Show (AnyScriptWitness era) @@ -2788,26 +2951,19 @@ deriving instance Show (AnyScriptWitness era) -- need or can use script witnesses: inputs, minted assets, withdrawals and -- certificates. These are simple numeric indices, enumerated from zero. -- Thus the indices are not stable if the transaction body is modified. --- -data ScriptWitnessIndex = - - -- | The n'th transaction input, in the order of the 'TxId's. - ScriptWitnessIndexTxIn !Word32 - - -- | The n'th minting 'PolicyId', in the order of the 'PolicyId's. - | ScriptWitnessIndexMint !Word32 - - -- | The n'th certificate, in the list order of the certificates. - | ScriptWitnessIndexCertificate !Word32 - - -- | The n'th withdrawal, in the order of the 'StakeAddress's. - | ScriptWitnessIndexWithdrawal !Word32 - - -- | The n'th vote, in the order of the votes. - | ScriptWitnessIndexVoting !Word32 - - -- | The n'th proposal, in the order of the proposals. - | ScriptWitnessIndexProposing !Word32 +data ScriptWitnessIndex + = -- | The n'th transaction input, in the order of the 'TxId's. + ScriptWitnessIndexTxIn !Word32 + | -- | The n'th minting 'PolicyId', in the order of the 'PolicyId's. + ScriptWitnessIndexMint !Word32 + | -- | The n'th certificate, in the list order of the certificates. + ScriptWitnessIndexCertificate !Word32 + | -- | The n'th withdrawal, in the order of the 'StakeAddress's. + ScriptWitnessIndexWithdrawal !Word32 + | -- | The n'th vote, in the order of the votes. + ScriptWitnessIndexVoting !Word32 + | -- | The n'th proposal, in the order of the proposals. + ScriptWitnessIndexProposing !Word32 deriving (Eq, Ord, Show) instance ToJSON ScriptWitnessIndex where @@ -2842,6 +2998,7 @@ instance ToJSON ScriptWitnessIndex where [ "kind" .= Aeson.String "ScriptWitnessIndexProposing" , "value" .= n ] + renderScriptWitnessIndex :: ScriptWitnessIndex -> String renderScriptWitnessIndex (ScriptWitnessIndexTxIn index) = "transaction input " <> show index <> " (in ascending order of the TxIds)" @@ -2858,43 +3015,44 @@ renderScriptWitnessIndex (ScriptWitnessIndexProposing index) = fromScriptWitnessIndex :: AlonzoEraOnwards era - -> ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + -> ScriptWitnessIndex + -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) fromScriptWitnessIndex aOnwards widx = case aOnwards of AlonzoEraOnwardsAlonzo -> fromScriptWitnessIndexAlonzo widx AlonzoEraOnwardsBabbage -> fromScriptWitnessIndexBabbage widx - AlonzoEraOnwardsConway -> fromScriptWitnessIndexConway widx + AlonzoEraOnwardsConway -> fromScriptWitnessIndexConway widx fromScriptWitnessIndexAlonzo :: ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra AlonzoEra)) fromScriptWitnessIndexAlonzo i = case i of - ScriptWitnessIndexTxIn n -> Just $ L.AlonzoSpending (L.AsIx n) - ScriptWitnessIndexMint n -> Just $ L.AlonzoMinting (L.AsIx n) + ScriptWitnessIndexTxIn n -> Just $ L.AlonzoSpending (L.AsIx n) + ScriptWitnessIndexMint n -> Just $ L.AlonzoMinting (L.AsIx n) ScriptWitnessIndexCertificate n -> Just $ L.AlonzoCertifying (L.AsIx n) - ScriptWitnessIndexWithdrawal n -> Just $ L.AlonzoRewarding (L.AsIx n) - _ -> Nothing + ScriptWitnessIndexWithdrawal n -> Just $ L.AlonzoRewarding (L.AsIx n) + _ -> Nothing fromScriptWitnessIndexBabbage :: ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra BabbageEra)) fromScriptWitnessIndexBabbage i = case i of - ScriptWitnessIndexTxIn n -> Just $ L.AlonzoSpending (L.AsIx n) - ScriptWitnessIndexMint n -> Just $ L.AlonzoMinting (L.AsIx n) + ScriptWitnessIndexTxIn n -> Just $ L.AlonzoSpending (L.AsIx n) + ScriptWitnessIndexMint n -> Just $ L.AlonzoMinting (L.AsIx n) ScriptWitnessIndexCertificate n -> Just $ L.AlonzoCertifying (L.AsIx n) - ScriptWitnessIndexWithdrawal n -> Just $ L.AlonzoRewarding (L.AsIx n) - _ -> Nothing + ScriptWitnessIndexWithdrawal n -> Just $ L.AlonzoRewarding (L.AsIx n) + _ -> Nothing fromScriptWitnessIndexConway :: ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra ConwayEra)) fromScriptWitnessIndexConway i = case i of - ScriptWitnessIndexTxIn n -> Just $ L.ConwaySpending (L.AsIx n) - ScriptWitnessIndexMint n -> Just $ L.ConwayMinting (L.AsIx n) + ScriptWitnessIndexTxIn n -> Just $ L.ConwaySpending (L.AsIx n) + ScriptWitnessIndexMint n -> Just $ L.ConwayMinting (L.AsIx n) ScriptWitnessIndexCertificate n -> Just $ L.ConwayCertifying (L.AsIx n) - ScriptWitnessIndexWithdrawal n -> Just $ L.ConwayRewarding (L.AsIx n) - ScriptWitnessIndexVoting n -> Just $ L.ConwayVoting (L.AsIx n) - ScriptWitnessIndexProposing n -> Just $ L.ConwayProposing (L.AsIx n) + ScriptWitnessIndexWithdrawal n -> Just $ L.ConwayRewarding (L.AsIx n) + ScriptWitnessIndexVoting n -> Just $ L.ConwayVoting (L.AsIx n) + ScriptWitnessIndexProposing n -> Just $ L.ConwayProposing (L.AsIx n) toScriptIndex :: AlonzoEraOnwards era @@ -2904,7 +3062,7 @@ toScriptIndex sbe scriptPurposeIndex = case sbe of AlonzoEraOnwardsAlonzo -> toScriptIndexAlonzo scriptPurposeIndex AlonzoEraOnwardsBabbage -> toScriptIndexAlonzo scriptPurposeIndex - AlonzoEraOnwardsConway -> toScriptIndexConway scriptPurposeIndex + AlonzoEraOnwardsConway -> toScriptIndexConway scriptPurposeIndex toScriptIndexAlonzo :: L.AlonzoPlutusPurpose L.AsIx (ShelleyLedgerEra era) @@ -2928,71 +3086,75 @@ toScriptIndexConway scriptPurposeIndex = L.ConwayVoting (L.AsIx i) -> ScriptWitnessIndexVoting i L.ConwayProposing (L.AsIx i) -> ScriptWitnessIndexProposing i -collectTxBodyScriptWitnesses :: forall era. ShelleyBasedEra era - -> TxBodyContent BuildTx era - -> [(ScriptWitnessIndex, AnyScriptWitness era)] -collectTxBodyScriptWitnesses _ TxBodyContent { - txIns, - txWithdrawals, - txCertificates, - txMintValue, - txVotingProcedures, - txProposalProcedures - } = +collectTxBodyScriptWitnesses + :: forall era + . ShelleyBasedEra era + -> TxBodyContent BuildTx era + -> [(ScriptWitnessIndex, AnyScriptWitness era)] +collectTxBodyScriptWitnesses + _ + TxBodyContent + { txIns + , txWithdrawals + , txCertificates + , txMintValue + , txVotingProcedures + , txProposalProcedures + } = concat - [ scriptWitnessesTxIns txIns - , scriptWitnessesWithdrawals txWithdrawals + [ scriptWitnessesTxIns txIns + , scriptWitnessesWithdrawals txWithdrawals , scriptWitnessesCertificates txCertificates - , scriptWitnessesMinting txMintValue - , scriptWitnessesVoting (maybe TxVotingProceduresNone unFeatured txVotingProcedures) - , scriptWitnessesProposing (maybe TxProposalProceduresNone unFeatured txProposalProcedures) + , scriptWitnessesMinting txMintValue + , scriptWitnessesVoting (maybe TxVotingProceduresNone unFeatured txVotingProcedures) + , scriptWitnessesProposing (maybe TxProposalProceduresNone unFeatured txProposalProcedures) ] - where + where scriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesTxIns txins = - [ (ScriptWitnessIndexTxIn ix, AnyScriptWitness witness) - -- The tx ins are indexed in the map order by txid - | (ix, (_, BuildTxWith (ScriptWitness _ witness))) - <- zip [0..] (orderTxIns txins) - ] + [ (ScriptWitnessIndexTxIn ix, AnyScriptWitness witness) + | -- The tx ins are indexed in the map order by txid + (ix, (_, BuildTxWith (ScriptWitness _ witness))) <- + zip [0 ..] (orderTxIns txins) + ] scriptWitnessesWithdrawals :: TxWithdrawals BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] - scriptWitnessesWithdrawals TxWithdrawalsNone = [] + scriptWitnessesWithdrawals TxWithdrawalsNone = [] scriptWitnessesWithdrawals (TxWithdrawals _ withdrawals) = - [ (ScriptWitnessIndexWithdrawal ix, AnyScriptWitness witness) - -- The withdrawals are indexed in the map order by stake credential - | (ix, (_, _, BuildTxWith (ScriptWitness _ witness))) - <- zip [0..] (orderStakeAddrs withdrawals) - ] + [ (ScriptWitnessIndexWithdrawal ix, AnyScriptWitness witness) + | -- The withdrawals are indexed in the map order by stake credential + (ix, (_, _, BuildTxWith (ScriptWitness _ witness))) <- + zip [0 ..] (orderStakeAddrs withdrawals) + ] scriptWitnessesCertificates :: TxCertificates BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] - scriptWitnessesCertificates TxCertificatesNone = [] + scriptWitnessesCertificates TxCertificatesNone = [] scriptWitnessesCertificates (TxCertificates _ certs (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexCertificate ix, AnyScriptWitness witness) - -- The certs are indexed in list order - | (ix, cert) <- zip [0..] certs - , ScriptWitness _ witness <- maybeToList $ do - stakecred <- selectStakeCredentialWitness cert - Map.lookup stakecred witnesses - ] + [ (ScriptWitnessIndexCertificate ix, AnyScriptWitness witness) + | -- The certs are indexed in list order + (ix, cert) <- zip [0 ..] certs + , ScriptWitness _ witness <- maybeToList $ do + stakecred <- selectStakeCredentialWitness cert + Map.lookup stakecred witnesses + ] scriptWitnessesMinting :: TxMintValue BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] - scriptWitnessesMinting TxMintNone = [] + scriptWitnessesMinting TxMintNone = [] scriptWitnessesMinting (TxMintValue _ value (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexMint ix, AnyScriptWitness witness) - -- The minting policies are indexed in policy id order in the value - | let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) - ] + [ (ScriptWitnessIndexMint ix, AnyScriptWitness witness) + | -- The minting policies are indexed in policy id order in the value + let ValueNestedRep bundle = valueToNestedRep value + , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle + , witness <- maybeToList (Map.lookup policyid witnesses) + ] scriptWitnessesVoting :: TxVotingProcedures BuildTx era @@ -3001,7 +3163,7 @@ collectTxBodyScriptWitnesses _ TxBodyContent { scriptWitnessesVoting (TxVotingProcedures (L.VotingProcedures votes) (BuildTxWith witnesses)) = [ (ScriptWitnessIndexVoting ix, AnyScriptWitness witness) | let voterList = Map.toList votes - , (ix, (voter, _) ) <- zip [0..] voterList + , (ix, (voter, _)) <- zip [0 ..] voterList , witness <- maybeToList (Map.lookup voter witnesses) ] @@ -3012,13 +3174,11 @@ collectTxBodyScriptWitnesses _ TxBodyContent { scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses)) | Map.null mScriptWitnesses = [] | otherwise = - [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) - | let proposalsList = Set.toList $ OSet.toSet proposalProcedures - , (ix, proposal) <- zip [0..] proposalsList - , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) - ] - - + [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) + | let proposalsList = Set.toList $ OSet.toSet proposalProcedures + , (ix, proposal) <- zip [0 ..] proposalsList + , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) + ] -- This relies on the TxId Ord instance being consistent with the -- Ledger.TxId Ord instance via the toShelleyTxId conversion @@ -3035,11 +3195,11 @@ orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) -- TODO: Investigate if we need toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto toShelleyWithdrawal withdrawals = - L.Withdrawals $ - Map.fromList - [ (toShelleyStakeAddr stakeAddr, value) - | (stakeAddr, value, _) <- withdrawals ] - + L.Withdrawals $ + Map.fromList + [ (toShelleyStakeAddr stakeAddr, value) + | (stakeAddr, value, _) <- withdrawals + ] fromShelleyWithdrawal :: L.Withdrawals StandardCrypto @@ -3049,11 +3209,9 @@ fromShelleyWithdrawal (L.Withdrawals withdrawals) = | (stakeAddr, value) <- Map.assocs withdrawals ] - -- | In the Allegra and Mary eras the auxiliary data consists of the tx metadata -- and the axiliary scripts. In the Alonzo and later eras the auxiliary data consists of the tx metadata -- and the axiliary scripts, and the axiliary script data. --- toAuxiliaryData :: ShelleyBasedEra era -> TxMetadataInEra era @@ -3061,24 +3219,24 @@ toAuxiliaryData -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) toAuxiliaryData sbe txMetadata txAuxScripts = let ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> toShelleyMetadata ms' + TxMetadataNone -> Map.empty + TxMetadataInEra _ (TxMetadata ms') -> toShelleyMetadata ms' ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> map toShelleyScript ss' - in case sbe of - ShelleyBasedEraShelley -> - guard (not (Map.null ms)) $> L.ShelleyTxAuxData ms - ShelleyBasedEraAllegra -> - guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) - ShelleyBasedEraMary -> - guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) - ShelleyBasedEraAlonzo -> - guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss - ShelleyBasedEraBabbage -> - guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss - ShelleyBasedEraConway -> - guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + TxAuxScriptsNone -> [] + TxAuxScripts _ ss' -> map toShelleyScript ss' + in case sbe of + ShelleyBasedEraShelley -> + guard (not (Map.null ms)) $> L.ShelleyTxAuxData ms + ShelleyBasedEraAllegra -> + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) + ShelleyBasedEraMary -> + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) + ShelleyBasedEraAlonzo -> + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + ShelleyBasedEraBabbage -> + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + ShelleyBasedEraConway -> + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss -- ---------------------------------------------------------------------------- -- Other utilities helpful with making transaction bodies @@ -3093,17 +3251,17 @@ toAuxiliaryData sbe txMetadata txAuxScripts = -- This gets turned into a UTxO by making a pseudo-transaction for each address, -- with the 0th output being the coin value. So to spend from the initial UTxO -- we need this same 'TxIn' to use as an input to the spending transaction. --- genesisUTxOPseudoTxIn :: NetworkId -> Hash GenesisUTxOKey -> TxIn genesisUTxOPseudoTxIn nw (GenesisUTxOKeyHash kh) = - --TODO: should handle Byron UTxO case too. - fromShelleyTxIn (Shelley.initialFundsPseudoTxIn addr) - where - addr :: L.Addr StandardCrypto - addr = L.Addr - (toShelleyNetwork nw) - (Shelley.KeyHashObj kh) - Shelley.StakeRefNull + -- TODO: should handle Byron UTxO case too. + fromShelleyTxIn (Shelley.initialFundsPseudoTxIn addr) + where + addr :: L.Addr StandardCrypto + addr = + L.Addr + (toShelleyNetwork nw) + (Shelley.KeyHashObj kh) + Shelley.StakeRefNull -- | Calculate the reference inputs size in bytes for provided set of transaction IDs and UTXOs. getReferenceInputsSizeForTxIds @@ -3114,7 +3272,7 @@ getReferenceInputsSizeForTxIds -> Int getReferenceInputsSizeForTxIds beo utxo txIds = babbageEraOnwardsConstraints beo $ do let refScripts = L.getReferenceScriptsNonDistinct utxo (Set.map toShelleyTxIn txIds) - getSum $ foldMap (Sum . SafeHash.originalBytesSize . snd) refScripts + getSum $ foldMap (Sum . SafeHash.originalBytesSize . snd) refScripts calculateExecutionUnitsLovelace :: Ledger.Prices -> ExecutionUnits -> Maybe L.Coin calculateExecutionUnitsLovelace prices eUnits = @@ -3123,10 +3281,9 @@ calculateExecutionUnitsLovelace prices eUnits = -- ---------------------------------------------------------------------------- -- Inline data -- + -- | Conversion of ScriptData to binary data which allows for the storage of data -- onchain within a transaction output. --- - scriptDataToInlineDatum :: L.Era ledgerera => HashableScriptData -> L.Datum ledgerera scriptDataToInlineDatum d = L.Datum . L.dataToBinaryData $ toAlonzoData d @@ -3134,8 +3291,9 @@ scriptDataToInlineDatum d = binaryDataToScriptData :: L.Era ledgerera => BabbageEraOnwards era - -> L.BinaryData ledgerera -> HashableScriptData + -> L.BinaryData ledgerera + -> HashableScriptData binaryDataToScriptData BabbageEraOnwardsBabbage d = fromAlonzoData $ L.binaryDataToData d -binaryDataToScriptData BabbageEraOnwardsConway d = +binaryDataToScriptData BabbageEraOnwardsConway d = fromAlonzoData $ L.binaryDataToData d diff --git a/cardano-api/internal/Cardano/Api/Tx/Sign.hs b/cardano-api/internal/Cardano/Api/Tx/Sign.hs index 882f4fd2b8..c1c5a09367 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Sign.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Sign.hs @@ -10,8 +10,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - - -- The Shelley ledger uses promoted data kinds which we have to use, but we do -- not export any from this API. We also use them unticked as nature intended. {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -19,68 +17,77 @@ {- HLINT ignore "Avoid lambda using `infix`" -} -- | Complete, signed transactions --- -module Cardano.Api.Tx.Sign ( +module Cardano.Api.Tx.Sign + ( -- * Signing transactions - -- * Signing transactions -- | Creating transaction witnesses one by one, or all in one go. - Tx(.., Tx), - Byron.ATxAux(..), - getTxBody, - getByronTxBody, - getTxWitnesses, - getTxWitnessesByron, - ScriptValidity(..), + Tx (.., Tx) + , Byron.ATxAux (..) + , getTxBody + , getByronTxBody + , getTxWitnesses + , getTxWitnessesByron + , ScriptValidity (..) -- ** Signing in one go - ShelleySigningKey(..), - toShelleySigningKey, - signByronTransaction, - signShelleyTransaction, + , ShelleySigningKey (..) + , toShelleySigningKey + , signByronTransaction + , signShelleyTransaction -- ** Incremental signing and separate witnesses - makeSignedByronTransaction, - makeSignedTransaction, - makeSignedTransaction', - KeyWitness(..), - makeByronKeyWitness, - ShelleyWitnessSigningKey(..), - makeShelleyKeyWitness, - WitnessNetworkIdOrByronAddress (..), - makeShelleyBootstrapWitness, - makeShelleySignature, - getShelleyKeyWitnessVerificationKey, - getTxBodyAndWitnesses, + , makeSignedByronTransaction + , makeSignedTransaction + , makeSignedTransaction' + , KeyWitness (..) + , makeByronKeyWitness + , ShelleyWitnessSigningKey (..) + , makeShelleyKeyWitness + , WitnessNetworkIdOrByronAddress (..) + , makeShelleyBootstrapWitness + , makeShelleySignature + , getShelleyKeyWitnessVerificationKey + , getTxBodyAndWitnesses -- * Data family instances - AsType(AsTx, AsByronTx, AsShelleyTx, AsMaryTx, AsAllegraTx, AsAlonzoTx, - AsKeyWitness, AsByronWitness, AsShelleyWitness ,AsTxId, AsTxBody, - AsByronTxBody, AsShelleyTxBody, AsMaryTxBody), - - TxBody(..), - - TxScriptValidity(..), - scriptValidityToIsValid, - isValidToScriptValidity, - txScriptValidityToIsValid, - txScriptValidityToScriptValidity, - - TxBodyScriptData(..), - ) where - -import Cardano.Api.Address -import Cardano.Api.Certificate -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras -import Cardano.Api.HasTypeProxy -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Class -import Cardano.Api.Keys.Shelley -import Cardano.Api.NetworkId -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseTextEnvelope - + , AsType + ( AsTx + , AsByronTx + , AsShelleyTx + , AsMaryTx + , AsAllegraTx + , AsAlonzoTx + , AsKeyWitness + , AsByronWitness + , AsShelleyWitness + , AsTxId + , AsTxBody + , AsByronTxBody + , AsShelleyTxBody + , AsMaryTxBody + ) + , TxBody (..) + , TxScriptValidity (..) + , scriptValidityToIsValid + , isValidToScriptValidity + , txScriptValidityToIsValid + , txScriptValidityToScriptValidity + , TxBodyScriptData (..) + ) +where + +import Cardano.Api.Address +import Cardano.Api.Certificate +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Class +import Cardano.Api.Keys.Shelley +import Cardano.Api.NetworkId +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.DSIGN.Class as Crypto @@ -92,26 +99,23 @@ import qualified Cardano.Crypto.Wallet as Crypto.HD import qualified Cardano.Ledger.Alonzo.Core as L import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe) -import Cardano.Ledger.Binary (Annotated (..)) +import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe) +import Cardano.Ledger.Binary (Annotated (..)) import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Core as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.SafeHash as Ledger - -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map.Strict as Map -import Data.Maybe +import Data.Maybe import qualified Data.Set as Set -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import qualified Data.Vector as Vector -import Lens.Micro - - +import Lens.Micro -- ---------------------------------------------------------------------------- -- Signed transactions @@ -123,119 +127,119 @@ data Tx era where -> L.Tx (ShelleyLedgerEra era) -> Tx era - instance Show (InAnyCardanoEra Tx) where - show (InAnyCardanoEra _ tx) = show tx + show (InAnyCardanoEra _ tx) = show tx instance Eq (InAnyCardanoEra Tx) where - (==) (InAnyCardanoEra eraA txA) (InAnyCardanoEra eraB txB) = - case testEquality eraA eraB of - Nothing -> False - Just Refl -> txA == txB - + (==) (InAnyCardanoEra eraA txA) (InAnyCardanoEra eraB txB) = + case testEquality eraA eraB of + Nothing -> False + Just Refl -> txA == txB instance Show (InAnyShelleyBasedEra Tx) where - show (InAnyShelleyBasedEra _ tx) = show tx + show (InAnyShelleyBasedEra _ tx) = show tx instance Eq (InAnyShelleyBasedEra Tx) where - (==) (InAnyShelleyBasedEra eraA txA) (InAnyShelleyBasedEra eraB txB) = - case testEquality eraA eraB of - Nothing -> False - Just Refl -> txA == txB + (==) (InAnyShelleyBasedEra eraA txA) (InAnyShelleyBasedEra eraB txB) = + case testEquality eraA eraB of + Nothing -> False + Just Refl -> txA == txB -- The GADT in the ShelleyTx case requires a custom instance instance Eq (Tx era) where - (==) (ShelleyTx sbe txA) - (ShelleyTx _ txB) = + (==) + (ShelleyTx sbe txA) + (ShelleyTx _ txB) = shelleyBasedEraConstraints sbe $ txA == txB -- The GADT in the ShelleyTx case requires a custom instance instance Show (Tx era) where - showsPrec p (ShelleyTx ShelleyBasedEraShelley tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraShelley " - . showsPrec 11 tx - - showsPrec p (ShelleyTx ShelleyBasedEraAllegra tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraAllegra " - . showsPrec 11 tx - - showsPrec p (ShelleyTx ShelleyBasedEraMary tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraMary " - . showsPrec 11 tx - - showsPrec p (ShelleyTx ShelleyBasedEraAlonzo tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraAlonzo " - . showsPrec 11 tx - - showsPrec p (ShelleyTx ShelleyBasedEraBabbage tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraBabbage " - . showsPrec 11 tx - - showsPrec p (ShelleyTx ShelleyBasedEraConway tx) = - showParen (p >= 11) $ - showString "ShelleyTx ShelleyBasedEraConway " - . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraShelley tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraShelley " + . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraAllegra tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraAllegra " + . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraMary tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraMary " + . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraAlonzo tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraAlonzo " + . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraBabbage tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraBabbage " + . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraConway tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraConway " + . showsPrec 11 tx instance HasTypeProxy era => HasTypeProxy (Tx era) where - data AsType (Tx era) = AsTx (AsType era) - proxyToAsType _ = AsTx (proxyToAsType (Proxy :: Proxy era)) - - + data AsType (Tx era) = AsTx (AsType era) + proxyToAsType _ = AsTx (proxyToAsType (Proxy :: Proxy era)) {-# DEPRECATED AsByronTx "Use AsTx AsByronEra instead." #-} pattern AsByronTx :: AsType (Tx ByronEra) pattern AsByronTx = AsTx AsByronEra + {-# COMPLETE AsByronTx #-} {-# DEPRECATED AsShelleyTx "Use AsTx AsShelleyEra instead." #-} pattern AsShelleyTx :: AsType (Tx ShelleyEra) pattern AsShelleyTx = AsTx AsShelleyEra + {-# COMPLETE AsShelleyTx #-} pattern AsMaryTx :: AsType (Tx MaryEra) pattern AsMaryTx = AsTx AsMaryEra + {-# COMPLETE AsMaryTx #-} pattern AsAllegraTx :: AsType (Tx AllegraEra) pattern AsAllegraTx = AsTx AsAllegraEra + {-# COMPLETE AsAllegraTx #-} pattern AsAlonzoTx :: AsType (Tx AlonzoEra) pattern AsAlonzoTx = AsTx AsAlonzoEra -{-# COMPLETE AsAlonzoTx #-} +{-# COMPLETE AsAlonzoTx #-} instance IsShelleyBasedEra era => SerialiseAsCBOR (Tx era) where - serialiseToCBOR (ShelleyTx sbe tx) = - shelleyBasedEraConstraints sbe $ serialiseShelleyBasedTx tx + serialiseToCBOR (ShelleyTx sbe tx) = + shelleyBasedEraConstraints sbe $ serialiseShelleyBasedTx tx - deserialiseFromCBOR _ bs = - shelleyBasedEraConstraints (shelleyBasedEra :: ShelleyBasedEra era) - $ deserialiseShelleyBasedTx (ShelleyTx shelleyBasedEra) bs + deserialiseFromCBOR _ bs = + shelleyBasedEraConstraints (shelleyBasedEra :: ShelleyBasedEra era) $ + deserialiseShelleyBasedTx (ShelleyTx shelleyBasedEra) bs -- | The serialisation format for the different Shelley-based eras are not the -- same, but they can be handled generally with one overloaded implementation. --- -serialiseShelleyBasedTx :: forall ledgerera . - L.EraTx ledgerera - => L.Tx ledgerera - -> ByteString +serialiseShelleyBasedTx + :: forall ledgerera + . L.EraTx ledgerera + => L.Tx ledgerera + -> ByteString serialiseShelleyBasedTx = Plain.serialize' -deserialiseShelleyBasedTx :: forall ledgerera tx' . - L.EraTx ledgerera - => (L.Tx ledgerera -> tx') - -> ByteString - -> Either CBOR.DecoderError tx' +deserialiseShelleyBasedTx + :: forall ledgerera tx' + . L.EraTx ledgerera + => (L.Tx ledgerera -> tx') + -> ByteString + -> Either CBOR.DecoderError tx' deserialiseShelleyBasedTx mkTx bs = - mkTx <$> CBOR.decodeFullAnnotator - (L.eraProtVerLow @ledgerera) "Shelley Tx" CBOR.decCBOR (LBS.fromStrict bs) - + mkTx + <$> CBOR.decodeFullAnnotator + (L.eraProtVerLow @ledgerera) + "Shelley Tx" + CBOR.decCBOR + (LBS.fromStrict bs) -- NB: This is called in getTxBodyAndWitnesses which is fine as -- getTxBodyAndWitnesses is only called in the context of a @@ -244,43 +248,43 @@ getTxBody :: Tx era -> TxBody era getTxBody (ShelleyTx sbe tx) = caseShelleyToMaryOrAlonzoEraOnwards ( const $ - let txBody = tx ^. L.bodyTxL - txAuxData = tx ^. L.auxDataTxL + let txBody = tx ^. L.bodyTxL + txAuxData = tx ^. L.auxDataTxL scriptWits = tx ^. L.witsTxL . L.scriptTxWitsL - in ShelleyTxBody sbe txBody - (Map.elems scriptWits) - TxBodyNoScriptData - (strictMaybeToMaybe txAuxData) - TxScriptValidityNone + in ShelleyTxBody + sbe + txBody + (Map.elems scriptWits) + TxBodyNoScriptData + (strictMaybeToMaybe txAuxData) + TxScriptValidityNone ) - (\w -> - let txBody = tx ^. L.bodyTxL - txAuxData = tx ^. L.auxDataTxL - scriptWits = tx ^. L.witsTxL . L.scriptTxWitsL - datsWits = tx ^. L.witsTxL . L.datsTxWitsL - redeemerWits = tx ^. L.witsTxL . L.rdmrsTxWitsL - isValid = tx ^. L.isValidTxL - in ShelleyTxBody sbe txBody - (Map.elems scriptWits) - (TxBodyScriptData w datsWits redeemerWits) - (strictMaybeToMaybe txAuxData) - (TxScriptValidity w (isValidToScriptValidity isValid)) + ( \w -> + let txBody = tx ^. L.bodyTxL + txAuxData = tx ^. L.auxDataTxL + scriptWits = tx ^. L.witsTxL . L.scriptTxWitsL + datsWits = tx ^. L.witsTxL . L.datsTxWitsL + redeemerWits = tx ^. L.witsTxL . L.rdmrsTxWitsL + isValid = tx ^. L.isValidTxL + in ShelleyTxBody + sbe + txBody + (Map.elems scriptWits) + (TxBodyScriptData w datsWits redeemerWits) + (strictMaybeToMaybe txAuxData) + (TxScriptValidity w (isValidToScriptValidity isValid)) ) sbe - - instance IsShelleyBasedEra era => HasTextEnvelope (Tx era) where - textEnvelopeType _ = - case shelleyBasedEra :: ShelleyBasedEra era of - ShelleyBasedEraShelley -> "TxSignedShelley" - ShelleyBasedEraAllegra -> "Tx AllegraEra" - ShelleyBasedEraMary -> "Tx MaryEra" - ShelleyBasedEraAlonzo -> "Tx AlonzoEra" - ShelleyBasedEraBabbage -> "Tx BabbageEra" - ShelleyBasedEraConway -> "Tx ConwayEra" - - + textEnvelopeType _ = + case shelleyBasedEra :: ShelleyBasedEra era of + ShelleyBasedEraShelley -> "TxSignedShelley" + ShelleyBasedEraAllegra -> "Tx AllegraEra" + ShelleyBasedEraMary -> "Tx MaryEra" + ShelleyBasedEraAlonzo -> "Tx AlonzoEra" + ShelleyBasedEraBabbage -> "Tx BabbageEra" + ShelleyBasedEraConway -> "Tx ConwayEra" -- ---------------------------------------------------------------------------- -- Transaction bodies @@ -288,207 +292,256 @@ instance IsShelleyBasedEra era => HasTextEnvelope (Tx era) where -- TODO: We can use Ledger.Tx era here however we would need to rename TxBody -- as technically it is not strictly a transaction body. data TxBody era where - ShelleyTxBody - :: ShelleyBasedEra era - -> Ledger.TxBody (ShelleyLedgerEra era) - - -- We include the scripts along with the tx body, rather than the - -- witnesses set, since they need to be known when building the body. - -> [Ledger.Script (ShelleyLedgerEra era)] - - -- The info for each use of each script: the script input data, both - -- the UTxO input data (called the "datum") and the supplied input - -- data (called the "redeemer") and the execution units. - -> TxBodyScriptData era - - -- The 'L.TxAuxData' consists of one or several things, - -- depending on era: - -- + transaction metadata (in Shelley and later) - -- + auxiliary scripts (in Allegra and later) - -- Note that there is no auxiliary script data as such, because the - -- extra script data has to be passed to scripts and hence is needed - -- for validation. It is thus part of the witness data, not the - -- auxiliary data. - -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - - -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation - - -> TxBody era - -- The 'ShelleyBasedEra' GADT tells us what era we are in. - -- The 'ShelleyLedgerEra' type family maps that to the era type from the - -- ledger lib. The 'Ledger.TxBody' type family maps that to a specific - -- tx body type, which is different for each Shelley-based era. + ShelleyTxBody + :: ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) + -- We include the scripts along with the tx body, rather than the + -- witnesses set, since they need to be known when building the body. + -> [Ledger.Script (ShelleyLedgerEra era)] + -- The info for each use of each script: the script input data, both + -- the UTxO input data (called the "datum") and the supplied input + -- data (called the "redeemer") and the execution units. + -> TxBodyScriptData era + -- The 'L.TxAuxData' consists of one or several things, + -- depending on era: + -- + transaction metadata (in Shelley and later) + -- + auxiliary scripts (in Allegra and later) + -- Note that there is no auxiliary script data as such, because the + -- extra script data has to be passed to scripts and hence is needed + -- for validation. It is thus part of the witness data, not the + -- auxiliary data. + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) + -> TxScriptValidity era + -- ^ Mark script as expected to pass or fail validation + -> TxBody era +-- The 'ShelleyBasedEra' GADT tells us what era we are in. +-- The 'ShelleyLedgerEra' type family maps that to the era type from the +-- ledger lib. The 'Ledger.TxBody' type family maps that to a specific +-- tx body type, which is different for each Shelley-based era. -- The GADT in the ShelleyTxBody case requires a custom instance instance Eq (TxBody era) where - (==) (ShelleyTxBody sbe txbodyA txscriptsA redeemersA txmetadataA scriptValidityA) - (ShelleyTxBody _ txbodyB txscriptsB redeemersB txmetadataB scriptValidityB) = - caseShelleyToMaryOrAlonzoEraOnwards - (const $ txbodyA == txbodyB - && txscriptsA == txscriptsB - && txmetadataA == txmetadataB - ) - (const $ txbodyA == txbodyB - && txscriptsA == txscriptsB - && redeemersA == redeemersB - && txmetadataA == txmetadataB - && scriptValidityA == scriptValidityB - ) sbe - + (==) + (ShelleyTxBody sbe txbodyA txscriptsA redeemersA txmetadataA scriptValidityA) + (ShelleyTxBody _ txbodyB txscriptsB redeemersB txmetadataB scriptValidityB) = + caseShelleyToMaryOrAlonzoEraOnwards + ( const $ + txbodyA == txbodyB + && txscriptsA == txscriptsB + && txmetadataA == txmetadataB + ) + ( const $ + txbodyA == txbodyB + && txscriptsA == txscriptsB + && redeemersA == redeemersB + && txmetadataA == txmetadataB + && scriptValidityA == scriptValidityB + ) + sbe -- The GADT in the ShelleyTxBody case requires a custom instance instance Show (TxBody era) where - showsPrec p (ShelleyTxBody ShelleyBasedEraShelley - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraShelley + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraShelley " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - - showsPrec p (ShelleyTxBody ShelleyBasedEraAllegra - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraAllegra + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraAllegra " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - - showsPrec p (ShelleyTxBody ShelleyBasedEraMary - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraMary + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraMary " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - - showsPrec p (ShelleyTxBody ShelleyBasedEraAlonzo - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraAlonzo + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraAlonzo " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - - showsPrec p (ShelleyTxBody ShelleyBasedEraBabbage - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraBabbage + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraBabbage " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - - showsPrec p (ShelleyTxBody ShelleyBasedEraConway - txbody txscripts redeemers txmetadata scriptValidity) = - showParen (p >= 11) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraConway + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) ( showString "ShelleyTxBody ShelleyBasedEraConway " - . showsPrec 11 txbody - . showChar ' ' - . showsPrec 11 txscripts - . showChar ' ' - . showsPrec 11 redeemers - . showChar ' ' - . showsPrec 11 txmetadata - . showChar ' ' - . showsPrec 11 scriptValidity + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity ) - instance HasTypeProxy era => HasTypeProxy (TxBody era) where - data AsType (TxBody era) = AsTxBody (AsType era) - proxyToAsType _ = AsTxBody (proxyToAsType (Proxy :: Proxy era)) + data AsType (TxBody era) = AsTxBody (AsType era) + proxyToAsType _ = AsTxBody (proxyToAsType (Proxy :: Proxy era)) pattern AsByronTxBody :: AsType (TxBody ByronEra) -pattern AsByronTxBody = AsTxBody AsByronEra +pattern AsByronTxBody = AsTxBody AsByronEra + {-# COMPLETE AsByronTxBody #-} pattern AsShelleyTxBody :: AsType (TxBody ShelleyEra) pattern AsShelleyTxBody = AsTxBody AsShelleyEra + {-# COMPLETE AsShelleyTxBody #-} pattern AsMaryTxBody :: AsType (TxBody MaryEra) pattern AsMaryTxBody = AsTxBody AsMaryEra + {-# COMPLETE AsMaryTxBody #-} instance IsShelleyBasedEra era => SerialiseAsCBOR (TxBody era) where - serialiseToCBOR body = serialiseToCBOR $ signShelleyTransaction shelleyBasedEra body mempty - - deserialiseFromCBOR _ bs = - fst . getTxBodyAndWitnesses - <$> shelleyBasedEraConstraints (shelleyBasedEra :: ShelleyBasedEra era) - (deserialiseShelleyBasedTx (ShelleyTx shelleyBasedEra) bs) - + serialiseToCBOR body = serialiseToCBOR $ signShelleyTransaction shelleyBasedEra body mempty + deserialiseFromCBOR _ bs = + fst . getTxBodyAndWitnesses + <$> shelleyBasedEraConstraints + (shelleyBasedEra :: ShelleyBasedEra era) + (deserialiseShelleyBasedTx (ShelleyTx shelleyBasedEra) bs) instance IsShelleyBasedEra era => HasTextEnvelope (TxBody era) where - textEnvelopeType _ = - case shelleyBasedEra :: ShelleyBasedEra era of - ShelleyBasedEraShelley -> "TxUnsignedShelley" - ShelleyBasedEraAllegra -> "TxBodyAllegra" - ShelleyBasedEraMary -> "TxBodyMary" - ShelleyBasedEraAlonzo -> "TxBodyAlonzo" - ShelleyBasedEraBabbage -> "TxBodyBabbage" - ShelleyBasedEraConway -> "TxBodyConway" + textEnvelopeType _ = + case shelleyBasedEra :: ShelleyBasedEra era of + ShelleyBasedEraShelley -> "TxUnsignedShelley" + ShelleyBasedEraAllegra -> "TxBodyAllegra" + ShelleyBasedEraMary -> "TxBodyMary" + ShelleyBasedEraAlonzo -> "TxBodyAlonzo" + ShelleyBasedEraBabbage -> "TxBodyBabbage" + ShelleyBasedEraConway -> "TxBodyConway" data TxBodyScriptData era where - TxBodyNoScriptData :: TxBodyScriptData era - TxBodyScriptData - :: AlonzoEraOnwardsConstraints era - => AlonzoEraOnwards era - -> Alonzo.TxDats (ShelleyLedgerEra era) - -> Alonzo.Redeemers (ShelleyLedgerEra era) - -> TxBodyScriptData era - -deriving instance Eq (TxBodyScriptData era) -deriving instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Show (TxBodyScriptData era) + TxBodyNoScriptData :: TxBodyScriptData era + TxBodyScriptData + :: AlonzoEraOnwardsConstraints era + => AlonzoEraOnwards era + -> Alonzo.TxDats (ShelleyLedgerEra era) + -> Alonzo.Redeemers (ShelleyLedgerEra era) + -> TxBodyScriptData era + +deriving instance Eq (TxBodyScriptData era) +deriving instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Show (TxBodyScriptData era) -- | Indicates whether a script is expected to fail or pass validation. data ScriptValidity - = ScriptInvalid -- ^ Script is expected to fail validation. - -- Transactions marked as such can include scripts that fail validation. - -- Such transactions may be submitted to the chain, in which case the - -- collateral will be taken upon on chain script validation failure. - - | ScriptValid -- ^ Script is expected to pass validation. - -- Transactions marked as such cannot include scripts that fail validation. - + = -- | Script is expected to fail validation. + -- Transactions marked as such can include scripts that fail validation. + -- Such transactions may be submitted to the chain, in which case the + -- collateral will be taken upon on chain script validation failure. + ScriptInvalid + | -- | Script is expected to pass validation. + -- Transactions marked as such cannot include scripts that fail validation. + ScriptValid deriving (Eq, Show) instance CBOR.EncCBOR ScriptValidity where @@ -508,18 +561,17 @@ isValidToScriptValidity (L.IsValid True) = ScriptValid -- | A representation of whether the era supports tx script validity. -- -- The Alonzo and subsequent eras support script validity. --- data TxScriptValidity era where TxScriptValidityNone :: TxScriptValidity era - -- | Tx script validity is supported in transactions in the 'Alonzo' era onwards. TxScriptValidity :: AlonzoEraOnwards era -> ScriptValidity -> TxScriptValidity era -deriving instance Eq (TxScriptValidity era) +deriving instance Eq (TxScriptValidity era) + deriving instance Show (TxScriptValidity era) txScriptValidityToScriptValidity :: TxScriptValidity era -> ScriptValidity @@ -529,190 +581,174 @@ txScriptValidityToScriptValidity (TxScriptValidity _ scriptValidity) = scriptVal txScriptValidityToIsValid :: TxScriptValidity era -> L.IsValid txScriptValidityToIsValid = scriptValidityToIsValid . txScriptValidityToScriptValidity - - data KeyWitness era where - - ByronKeyWitness - :: Byron.TxInWitness - -> KeyWitness ByronEra - - ShelleyBootstrapWitness - :: ShelleyBasedEra era - -> Shelley.BootstrapWitness StandardCrypto - -> KeyWitness era - - ShelleyKeyWitness - :: ShelleyBasedEra era - -> L.WitVKey Shelley.Witness StandardCrypto - -> KeyWitness era - + ByronKeyWitness + :: Byron.TxInWitness + -> KeyWitness ByronEra + ShelleyBootstrapWitness + :: ShelleyBasedEra era + -> Shelley.BootstrapWitness StandardCrypto + -> KeyWitness era + ShelleyKeyWitness + :: ShelleyBasedEra era + -> L.WitVKey Shelley.Witness StandardCrypto + -> KeyWitness era -- The GADT in the Shelley cases requires a custom instance instance Eq (KeyWitness era) where - (==) (ByronKeyWitness wA) - (ByronKeyWitness wB) = wA == wB - - (==) (ShelleyBootstrapWitness _ wA) - (ShelleyBootstrapWitness _ wB) = + (==) + (ByronKeyWitness wA) + (ByronKeyWitness wB) = wA == wB + (==) + (ShelleyBootstrapWitness _ wA) + (ShelleyBootstrapWitness _ wB) = wA == wB - - (==) (ShelleyKeyWitness _ wA) - (ShelleyKeyWitness _ wB) = + (==) + (ShelleyKeyWitness _ wA) + (ShelleyKeyWitness _ wB) = wA == wB - - (==) _ _ = False + (==) _ _ = False -- The GADT in the ShelleyTx case requires a custom instance ---TODO: once we start providing custom patterns we should do the show in terms +-- TODO: once we start providing custom patterns we should do the show in terms -- of those. It'll be less verbose too! instance Show (KeyWitness era) where - showsPrec p (ByronKeyWitness tx) = - showParen (p >= 11) $ - showString "ByronKeyWitness " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraShelley tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraShelley " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraAllegra tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraAllegra " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraMary tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraMary " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraAlonzo tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraAlonzo " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraBabbage tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraBabbage " - . showsPrec 11 tx - - showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraConway tx) = - showParen (p >= 11) $ - showString "ShelleyBootstrapWitness ShelleyBasedEraConway " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraShelley tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraShelley " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraAllegra tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraAllegra " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraMary tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraMary " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraAlonzo tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraAlonzo " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraBabbage tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraBabbage " - . showsPrec 11 tx - - showsPrec p (ShelleyKeyWitness ShelleyBasedEraConway tx) = - showParen (p >= 11) $ - showString "ShelleyKeyWitness ShelleyBasedEraConway " - . showsPrec 11 tx + showsPrec p (ByronKeyWitness tx) = + showParen (p >= 11) $ + showString "ByronKeyWitness " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraShelley tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraShelley " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraAllegra tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraAllegra " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraMary tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraMary " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraAlonzo tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraAlonzo " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraBabbage tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraBabbage " + . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraConway tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraConway " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraShelley tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraShelley " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraAllegra tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraAllegra " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraMary tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraMary " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraAlonzo tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraAlonzo " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraBabbage tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraBabbage " + . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraConway tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraConway " + . showsPrec 11 tx instance HasTypeProxy era => HasTypeProxy (KeyWitness era) where - data AsType (KeyWitness era) = AsKeyWitness (AsType era) - proxyToAsType _ = AsKeyWitness (proxyToAsType (Proxy :: Proxy era)) + data AsType (KeyWitness era) = AsKeyWitness (AsType era) + proxyToAsType _ = AsKeyWitness (proxyToAsType (Proxy :: Proxy era)) pattern AsByronWitness :: AsType (KeyWitness ByronEra) -pattern AsByronWitness = AsKeyWitness AsByronEra +pattern AsByronWitness = AsKeyWitness AsByronEra + {-# COMPLETE AsByronWitness #-} pattern AsShelleyWitness :: AsType (KeyWitness ShelleyEra) pattern AsShelleyWitness = AsKeyWitness AsShelleyEra + {-# COMPLETE AsShelleyWitness #-} -- This custom instance differs from cardano-ledger -- because we want to be able to tell the difference between -- on disk witnesses for the cli's 'assemble' command. instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where - serialiseToCBOR (ByronKeyWitness wit) = - Plain.serialize' wit - - serialiseToCBOR (ShelleyKeyWitness sbe wit) = - CBOR.serialize' (eraProtVerLow sbe) $ + serialiseToCBOR (ByronKeyWitness wit) = + Plain.serialize' wit + serialiseToCBOR (ShelleyKeyWitness sbe wit) = + CBOR.serialize' (eraProtVerLow sbe) $ encodeShelleyBasedKeyWitness wit - - serialiseToCBOR (ShelleyBootstrapWitness sbe wit) = - CBOR.serialize' (eraProtVerLow sbe) $ + serialiseToCBOR (ShelleyBootstrapWitness sbe wit) = + CBOR.serialize' (eraProtVerLow sbe) $ encodeShelleyBasedBootstrapWitness wit - deserialiseFromCBOR _ bs = - case cardanoEra :: CardanoEra era of - ByronEra -> - ByronKeyWitness <$> Plain.decodeFull' bs - - -- Use the same derialisation impl, but at different types: - ShelleyEra -> decodeShelleyBasedWitness ShelleyBasedEraShelley bs - AllegraEra -> decodeShelleyBasedWitness ShelleyBasedEraAllegra bs - MaryEra -> decodeShelleyBasedWitness ShelleyBasedEraMary bs - AlonzoEra -> decodeShelleyBasedWitness ShelleyBasedEraAlonzo bs - BabbageEra -> decodeShelleyBasedWitness ShelleyBasedEraBabbage bs - ConwayEra -> decodeShelleyBasedWitness ShelleyBasedEraConway bs - + deserialiseFromCBOR _ bs = + case cardanoEra :: CardanoEra era of + ByronEra -> + ByronKeyWitness <$> Plain.decodeFull' bs + -- Use the same derialisation impl, but at different types: + ShelleyEra -> decodeShelleyBasedWitness ShelleyBasedEraShelley bs + AllegraEra -> decodeShelleyBasedWitness ShelleyBasedEraAllegra bs + MaryEra -> decodeShelleyBasedWitness ShelleyBasedEraMary bs + AlonzoEra -> decodeShelleyBasedWitness ShelleyBasedEraAlonzo bs + BabbageEra -> decodeShelleyBasedWitness ShelleyBasedEraBabbage bs + ConwayEra -> decodeShelleyBasedWitness ShelleyBasedEraConway bs encodeShelleyBasedKeyWitness :: CBOR.EncCBOR w => w -> CBOR.Encoding encodeShelleyBasedKeyWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encCBOR wit + CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encCBOR wit encodeShelleyBasedBootstrapWitness :: CBOR.EncCBOR w => w -> CBOR.Encoding encodeShelleyBasedBootstrapWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> CBOR.encCBOR wit + CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> CBOR.encCBOR wit -decodeShelleyBasedWitness :: forall era. - L.Era (ShelleyLedgerEra era) - => ShelleyBasedEra era - -> ByteString - -> Either CBOR.DecoderError (KeyWitness era) +decodeShelleyBasedWitness + :: forall era + . L.Era (ShelleyLedgerEra era) + => ShelleyBasedEra era + -> ByteString + -> Either CBOR.DecoderError (KeyWitness era) decodeShelleyBasedWitness sbe = - CBOR.decodeFullAnnotator (L.eraProtVerLow @(ShelleyLedgerEra era)) - "Shelley Witness" decode + CBOR.decodeFullAnnotator + (L.eraProtVerLow @(ShelleyLedgerEra era)) + "Shelley Witness" + decode . LBS.fromStrict - where - decode :: CBOR.Decoder s (CBOR.Annotator (KeyWitness era)) - decode = do - CBOR.decodeListLenOf 2 - t <- CBOR.decodeWord - case t of - 0 -> fmap (fmap (ShelleyKeyWitness sbe)) CBOR.decCBOR - 1 -> fmap (fmap (ShelleyBootstrapWitness sbe)) CBOR.decCBOR - _ -> CBOR.cborError $ CBOR.DecoderErrorUnknownTag - "Shelley Witness" (fromIntegral t) - + where + decode :: CBOR.Decoder s (CBOR.Annotator (KeyWitness era)) + decode = do + CBOR.decodeListLenOf 2 + t <- CBOR.decodeWord + case t of + 0 -> fmap (fmap (ShelleyKeyWitness sbe)) CBOR.decCBOR + 1 -> fmap (fmap (ShelleyBootstrapWitness sbe)) CBOR.decCBOR + _ -> + CBOR.cborError $ + CBOR.DecoderErrorUnknownTag + "Shelley Witness" + (fromIntegral t) instance IsCardanoEra era => HasTextEnvelope (KeyWitness era) where - textEnvelopeType _ = - case cardanoEra :: CardanoEra era of - ByronEra -> "TxWitnessByron" - ShelleyEra -> "TxWitness ShelleyEra" - AllegraEra -> "TxWitness AllegraEra" - MaryEra -> "TxWitness MaryEra" - AlonzoEra -> "TxWitness AlonzoEra" - BabbageEra -> "TxWitness BabbageEra" - ConwayEra -> "TxWitness ConwayEra" - + textEnvelopeType _ = + case cardanoEra :: CardanoEra era of + ByronEra -> "TxWitnessByron" + ShelleyEra -> "TxWitness ShelleyEra" + AllegraEra -> "TxWitness AllegraEra" + MaryEra -> "TxWitness MaryEra" + AlonzoEra -> "TxWitness AlonzoEra" + BabbageEra -> "TxWitness BabbageEra" + ConwayEra -> "TxWitness ConwayEra" getTxBodyAndWitnesses :: Tx era -> (TxBody era, [KeyWitness era]) getTxBodyAndWitnesses tx = (getTxBody tx, getTxWitnesses tx) @@ -721,38 +757,34 @@ pattern Tx :: TxBody era -> [KeyWitness era] -> Tx era pattern Tx txbody ws <- (getTxBodyAndWitnesses -> (txbody, ws)) where Tx txbody ws = makeSignedTransaction ws txbody -{-# COMPLETE Tx #-} - +{-# COMPLETE Tx #-} -data ShelleyWitnessSigningKey = - WitnessPaymentKey (SigningKey PaymentKey) - | WitnessPaymentExtendedKey (SigningKey PaymentExtendedKey) - | WitnessStakeKey (SigningKey StakeKey) - | WitnessStakeExtendedKey (SigningKey StakeExtendedKey) - | WitnessStakePoolKey (SigningKey StakePoolKey) - | WitnessGenesisKey (SigningKey GenesisKey) - | WitnessGenesisExtendedKey (SigningKey GenesisExtendedKey) - | WitnessGenesisDelegateKey (SigningKey GenesisDelegateKey) - | WitnessGenesisDelegateExtendedKey - (SigningKey GenesisDelegateExtendedKey) - | WitnessGenesisUTxOKey (SigningKey GenesisUTxOKey) - | WitnessCommitteeColdKey (SigningKey CommitteeColdKey) - | WitnessCommitteeColdExtendedKey (SigningKey CommitteeColdExtendedKey) - | WitnessCommitteeHotKey (SigningKey CommitteeHotKey) - | WitnessCommitteeHotExtendedKey (SigningKey CommitteeHotExtendedKey) - | WitnessDRepKey (SigningKey DRepKey) - | WitnessDRepExtendedKey (SigningKey DRepExtendedKey) - +data ShelleyWitnessSigningKey + = WitnessPaymentKey (SigningKey PaymentKey) + | WitnessPaymentExtendedKey (SigningKey PaymentExtendedKey) + | WitnessStakeKey (SigningKey StakeKey) + | WitnessStakeExtendedKey (SigningKey StakeExtendedKey) + | WitnessStakePoolKey (SigningKey StakePoolKey) + | WitnessGenesisKey (SigningKey GenesisKey) + | WitnessGenesisExtendedKey (SigningKey GenesisExtendedKey) + | WitnessGenesisDelegateKey (SigningKey GenesisDelegateKey) + | WitnessGenesisDelegateExtendedKey + (SigningKey GenesisDelegateExtendedKey) + | WitnessGenesisUTxOKey (SigningKey GenesisUTxOKey) + | WitnessCommitteeColdKey (SigningKey CommitteeColdKey) + | WitnessCommitteeColdExtendedKey (SigningKey CommitteeColdExtendedKey) + | WitnessCommitteeHotKey (SigningKey CommitteeHotKey) + | WitnessCommitteeHotExtendedKey (SigningKey CommitteeHotExtendedKey) + | WitnessDRepKey (SigningKey DRepKey) + | WitnessDRepExtendedKey (SigningKey DRepExtendedKey) -- | We support making key witnesses with both normal and extended signing keys. --- -data ShelleySigningKey = - -- | A normal ed25519 signing key - ShelleyNormalSigningKey (Shelley.SignKeyDSIGN StandardCrypto) - - -- | An extended ed25519 signing key - | ShelleyExtendedSigningKey Crypto.HD.XPrv +data ShelleySigningKey + = -- | A normal ed25519 signing key + ShelleyNormalSigningKey (Shelley.SignKeyDSIGN StandardCrypto) + | -- | An extended ed25519 signing key + ShelleyExtendedSigningKey Crypto.HD.XPrv makeShelleySignature :: Crypto.SignableRepresentation tosign @@ -760,212 +792,223 @@ makeShelleySignature -> ShelleySigningKey -> Shelley.SignedDSIGN StandardCrypto tosign makeShelleySignature tosign (ShelleyNormalSigningKey sk) = - Crypto.signedDSIGN () tosign sk - + Crypto.signedDSIGN () tosign sk makeShelleySignature tosign (ShelleyExtendedSigningKey sk) = - fromXSignature $ - Crypto.HD.sign - BS.empty -- passphrase for (unused) in-memory encryption - sk - (Crypto.getSignableRepresentation tosign) - where - fromXSignature :: Crypto.HD.XSignature - -> Shelley.SignedDSIGN StandardCrypto b - fromXSignature = - Crypto.SignedDSIGN + fromXSignature $ + Crypto.HD.sign + BS.empty -- passphrase for (unused) in-memory encryption + sk + (Crypto.getSignableRepresentation tosign) + where + fromXSignature + :: Crypto.HD.XSignature + -> Shelley.SignedDSIGN StandardCrypto b + fromXSignature = + Crypto.SignedDSIGN . fromMaybe impossible . Crypto.rawDeserialiseSigDSIGN . Crypto.HD.unXSignature - impossible = - error "makeShelleyKeyWitnessSignature: byron and shelley signature sizes do not match" + impossible = + error "makeShelleyKeyWitnessSignature: byron and shelley signature sizes do not match" -makeSignedTransaction' :: () +makeSignedTransaction' + :: () => CardanoEra era -> [KeyWitness era] -> TxBody era -> Tx era makeSignedTransaction' _ = makeSignedTransaction -makeSignedByronTransaction :: [KeyWitness era] -> Annotated Byron.Tx ByteString -> Byron.ATxAux ByteString +makeSignedByronTransaction + :: [KeyWitness era] -> Annotated Byron.Tx ByteString -> Byron.ATxAux ByteString makeSignedByronTransaction witnesses txbody = - Byron.annotateTxAux - $ Byron.mkTxAux - (unAnnotated txbody) - (Vector.fromList [ w | ByronKeyWitness w <- witnesses ]) + Byron.annotateTxAux $ + Byron.mkTxAux + (unAnnotated txbody) + (Vector.fromList [w | ByronKeyWitness w <- witnesses]) -- order of signing keys must match txins -signByronTransaction :: NetworkId - -> Annotated Byron.Tx ByteString - -> [SigningKey ByronKey] - -> Byron.ATxAux ByteString +signByronTransaction + :: NetworkId + -> Annotated Byron.Tx ByteString + -> [SigningKey ByronKey] + -> Byron.ATxAux ByteString signByronTransaction nw txbody sks = - makeSignedByronTransaction witnesses txbody - where - witnesses = map (makeByronKeyWitness nw txbody) sks + makeSignedByronTransaction witnesses txbody + where + witnesses = map (makeByronKeyWitness nw txbody) sks -- signing keys is a set -signShelleyTransaction :: () +signShelleyTransaction + :: () => ShelleyBasedEra era -> TxBody era -> [ShelleyWitnessSigningKey] -> Tx era signShelleyTransaction sbe txbody sks = - makeSignedTransaction witnesses txbody - where - witnesses = map (makeShelleyKeyWitness sbe txbody) sks - - - + makeSignedTransaction witnesses txbody + where + witnesses = map (makeShelleyKeyWitness sbe txbody) sks getByronTxBody :: Byron.ATxAux ByteString -> Annotated Byron.Tx ByteString -getByronTxBody (Byron.ATxAux { Byron.aTaTx = txbody }) = txbody - - +getByronTxBody (Byron.ATxAux {Byron.aTaTx = txbody}) = txbody getTxWitnessesByron :: Byron.ATxAux ByteString -> [KeyWitness ByronEra] -getTxWitnessesByron (Byron.ATxAux { Byron.aTaWitness = witnesses }) = - map ByronKeyWitness - . Vector.toList - . unAnnotated - $ witnesses +getTxWitnessesByron (Byron.ATxAux {Byron.aTaWitness = witnesses}) = + map ByronKeyWitness + . Vector.toList + . unAnnotated + $ witnesses getTxWitnesses :: forall era. Tx era -> [KeyWitness era] getTxWitnesses (ShelleyTx sbe tx') = caseShelleyToMaryOrAlonzoEraOnwards (const (getShelleyTxWitnesses tx')) - (const (getAlonzoTxWitnesses tx')) + (const (getAlonzoTxWitnesses tx')) sbe - where - getShelleyTxWitnesses :: forall ledgerera. - L.EraTx ledgerera - => L.EraCrypto ledgerera ~ StandardCrypto - => L.Tx ledgerera - -> [KeyWitness era] - getShelleyTxWitnesses tx = - map (ShelleyBootstrapWitness sbe) (Set.elems (tx ^. L.witsTxL . L.bootAddrTxWitsL)) - ++ map (ShelleyKeyWitness sbe) (Set.elems (tx ^. L.witsTxL . L.addrTxWitsL)) - - getAlonzoTxWitnesses :: forall ledgerera. - L.EraCrypto ledgerera ~ StandardCrypto - => L.EraTx ledgerera - => L.Tx ledgerera - -> [KeyWitness era] - getAlonzoTxWitnesses = getShelleyTxWitnesses - - - -makeSignedTransaction :: forall era. - [KeyWitness era] + where + getShelleyTxWitnesses + :: forall ledgerera + . L.EraTx ledgerera + => L.EraCrypto ledgerera ~ StandardCrypto + => L.Tx ledgerera + -> [KeyWitness era] + getShelleyTxWitnesses tx = + map (ShelleyBootstrapWitness sbe) (Set.elems (tx ^. L.witsTxL . L.bootAddrTxWitsL)) + ++ map (ShelleyKeyWitness sbe) (Set.elems (tx ^. L.witsTxL . L.addrTxWitsL)) + + getAlonzoTxWitnesses + :: forall ledgerera + . L.EraCrypto ledgerera ~ StandardCrypto + => L.EraTx ledgerera + => L.Tx ledgerera + -> [KeyWitness era] + getAlonzoTxWitnesses = getShelleyTxWitnesses + +makeSignedTransaction + :: forall era + . [KeyWitness era] -> TxBody era -> Tx era -makeSignedTransaction witnesses (ShelleyTxBody sbe txbody - txscripts - txscriptdata - txmetadata - scriptValidity - ) = +makeSignedTransaction + witnesses + ( ShelleyTxBody + sbe + txbody + txscripts + txscriptdata + txmetadata + scriptValidity + ) = case sbe of ShelleyBasedEraShelley -> shelleySignedTransaction ShelleyBasedEraAllegra -> shelleySignedTransaction - ShelleyBasedEraMary -> shelleySignedTransaction - ShelleyBasedEraAlonzo -> alonzoSignedTransaction + ShelleyBasedEraMary -> shelleySignedTransaction + ShelleyBasedEraAlonzo -> alonzoSignedTransaction ShelleyBasedEraBabbage -> alonzoSignedTransaction - ShelleyBasedEraConway -> alonzoSignedTransaction - where + ShelleyBasedEraConway -> alonzoSignedTransaction + where txCommon - :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera + :: forall ledgerera + . ShelleyLedgerEra era ~ ledgerera => L.EraCrypto ledgerera ~ StandardCrypto => L.EraTx ledgerera => L.Tx ledgerera txCommon = - L.mkBasicTx txbody - & L.witsTxL .~ - (L.mkBasicTxWits - & L.addrTxWitsL .~ Set.fromList [ w | ShelleyKeyWitness _ w <- witnesses ] - & L.scriptTxWitsL .~ - Map.fromList [ (Ledger.hashScript @ledgerera sw, sw) - | sw <- txscripts ] - & L.bootAddrTxWitsL .~ - Set.fromList [ w | ShelleyBootstrapWitness _ w <- witnesses ] - ) - & L.auxDataTxL .~ maybeToStrictMaybe txmetadata + L.mkBasicTx txbody + & L.witsTxL + .~ ( L.mkBasicTxWits + & L.addrTxWitsL .~ Set.fromList [w | ShelleyKeyWitness _ w <- witnesses] + & L.scriptTxWitsL + .~ Map.fromList + [ (Ledger.hashScript @ledgerera sw, sw) + | sw <- txscripts + ] + & L.bootAddrTxWitsL + .~ Set.fromList [w | ShelleyBootstrapWitness _ w <- witnesses] + ) + & L.auxDataTxL .~ maybeToStrictMaybe txmetadata shelleySignedTransaction - :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera + :: forall ledgerera + . ShelleyLedgerEra era ~ ledgerera => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.EraTx ledgerera => Tx era shelleySignedTransaction = ShelleyTx sbe txCommon alonzoSignedTransaction - :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera + :: forall ledgerera + . ShelleyLedgerEra era ~ ledgerera => Ledger.EraCrypto ledgerera ~ StandardCrypto => L.AlonzoEraTx ledgerera => Tx era alonzoSignedTransaction = - ShelleyTx sbe - (txCommon - & L.witsTxL . L.datsTxWitsL .~ datums - & L.witsTxL . L.rdmrsTxWitsL .~ redeemers - & L.isValidTxL .~ txScriptValidityToIsValid scriptValidity) - where - (datums, redeemers) = - case txscriptdata of - TxBodyScriptData _ ds rs -> (ds, rs) - TxBodyNoScriptData -> (mempty, L.Redeemers mempty) - -makeByronKeyWitness :: forall key. - IsByronKey key - => NetworkId - -> Annotated Byron.Tx ByteString - -> SigningKey key - -> KeyWitness ByronEra + ShelleyTx + sbe + ( txCommon + & L.witsTxL . L.datsTxWitsL .~ datums + & L.witsTxL . L.rdmrsTxWitsL .~ redeemers + & L.isValidTxL .~ txScriptValidityToIsValid scriptValidity + ) + where + (datums, redeemers) = + case txscriptdata of + TxBodyScriptData _ ds rs -> (ds, rs) + TxBodyNoScriptData -> (mempty, L.Redeemers mempty) + +makeByronKeyWitness + :: forall key + . IsByronKey key + => NetworkId + -> Annotated Byron.Tx ByteString + -> SigningKey key + -> KeyWitness ByronEra makeByronKeyWitness nw txbody = - let txhash :: Byron.Hash Byron.Tx - txhash = Byron.hashDecoded txbody - - pm :: Byron.ProtocolMagicId - pm = toByronProtocolMagicId nw - - -- To allow sharing of the txhash computation across many signatures we - -- define and share the txhash outside the lambda for the signing key: - in case byronKeyFormat :: ByronKeyFormat key of - ByronLegacyKeyFormat -> - \(ByronSigningKeyLegacy sk) -> witness sk pm txhash - ByronModernKeyFormat -> - \(ByronSigningKey sk) -> witness sk pm txhash + let txhash :: Byron.Hash Byron.Tx + txhash = Byron.hashDecoded txbody + + pm :: Byron.ProtocolMagicId + pm = toByronProtocolMagicId nw + in -- To allow sharing of the txhash computation across many signatures we + -- define and share the txhash outside the lambda for the signing key: + case byronKeyFormat :: ByronKeyFormat key of + ByronLegacyKeyFormat -> + \(ByronSigningKeyLegacy sk) -> witness sk pm txhash + ByronModernKeyFormat -> + \(ByronSigningKey sk) -> witness sk pm txhash where - witness :: Byron.SigningKey - -> Byron.ProtocolMagicId - -> Byron.Hash Byron.Tx - -> KeyWitness ByronEra - witness sk pm txHash = - ByronKeyWitness $ - Byron.VKWitness - (Byron.toVerification sk) - (Byron.sign pm Byron.SignTx sk (Byron.TxSigData txHash)) + witness + :: Byron.SigningKey + -> Byron.ProtocolMagicId + -> Byron.Hash Byron.Tx + -> KeyWitness ByronEra + witness sk pm txHash = + ByronKeyWitness $ + Byron.VKWitness + (Byron.toVerification sk) + (Byron.sign pm Byron.SignTx sk (Byron.TxSigData txHash)) -- | Either a network ID or a Byron address to be used in constructing a -- Shelley bootstrap witness. data WitnessNetworkIdOrByronAddress - = WitnessNetworkId !NetworkId - -- ^ Network ID. - -- - -- If this value is used in the construction of a Shelley bootstrap witness, - -- the result will not consist of a derivation path. If that is required, - -- specify a 'WitnessByronAddress' value instead. - | WitnessByronAddress !(Address ByronAddr) - -- ^ Byron address. - -- - -- If this value is used in the construction of a Shelley bootstrap witness, - -- both the network ID and derivation path will be extracted from the - -- address and used in the construction of the witness. - -makeShelleyBootstrapWitness :: forall era. () + = -- | Network ID. + -- + -- If this value is used in the construction of a Shelley bootstrap witness, + -- the result will not consist of a derivation path. If that is required, + -- specify a 'WitnessByronAddress' value instead. + WitnessNetworkId !NetworkId + | -- | Byron address. + -- + -- If this value is used in the construction of a Shelley bootstrap witness, + -- both the network ID and derivation path will be extracted from the + -- address and used in the construction of the witness. + WitnessByronAddress !(Address ByronAddr) + +makeShelleyBootstrapWitness + :: forall era + . () => ShelleyBasedEra era -> WitnessNetworkIdOrByronAddress -> TxBody era @@ -975,86 +1018,93 @@ makeShelleyBootstrapWitness sbe nwOrAddr txBody sk = case txBody of ShelleyTxBody _ txbody _ _ _ _ -> makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody sk -makeShelleyBasedBootstrapWitness :: forall era. () +makeShelleyBasedBootstrapWitness + :: forall era + . () => ShelleyBasedEra era -> WitnessNetworkIdOrByronAddress -> Ledger.TxBody (ShelleyLedgerEra era) -> SigningKey ByronKey -> KeyWitness era makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = - ShelleyBootstrapWitness sbe $ - -- Byron era witnesses were weird. This reveals all that weirdness. - Shelley.BootstrapWitness { - Shelley.bwKey = vk, - Shelley.bwSig = signature, - Shelley.bwChainCode = chainCode, - Shelley.bwAttributes = attributes + ShelleyBootstrapWitness sbe $ + -- Byron era witnesses were weird. This reveals all that weirdness. + Shelley.BootstrapWitness + { Shelley.bwKey = vk + , Shelley.bwSig = signature + , Shelley.bwChainCode = chainCode + , Shelley.bwAttributes = attributes } - where - -- Starting with the easy bits: we /can/ convert the Byron verification key - -- to a the pair of a Shelley verification key plus the chain code. - -- - (vk, chainCode) = Shelley.unpackByronVKey (Byron.toVerification sk) + where + -- Starting with the easy bits: we /can/ convert the Byron verification key + -- to a the pair of a Shelley verification key plus the chain code. + -- + (vk, chainCode) = Shelley.unpackByronVKey (Byron.toVerification sk) - -- Now the hairy bits. - -- - -- Byron era signing keys were all /extended/ ed25519 keys. We have to - -- produce a signature using this extended signing key directly. They - -- /cannot/ be converted to a plain (non-extended) signing keys. Since we - -- now support extended signing keys for the Shelley too, we are able to - -- reuse that here. - -- - signature :: Shelley.SignedDSIGN StandardCrypto - (Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody) - signature = makeShelleySignature - txhash - -- Make the signature with the extended key directly: - (ShelleyExtendedSigningKey (Byron.unSigningKey sk)) - - txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody - txhash = shelleyBasedEraConstraints sbe $ Ledger.extractHash (Ledger.hashAnnotated txbody) - --TODO: use Shelley.eraIndTxBodyHash txbody once that function has a - -- suitably general type. - - -- And finally we need to provide the extra suffix bytes necessary to - -- reconstruct the mini-Merkel tree that is a Byron address. The suffix - -- bytes are the serialised address attributes. - attributes = - Plain.serialize' $ - Byron.mkAttributes Byron.AddrAttributes { - Byron.aaVKDerivationPath = derivationPath, - Byron.aaNetworkMagic = networkMagic - } - - -- The 'WitnessNetworkIdOrByronAddress' value converted to an 'Either'. - eitherNwOrAddr :: Either NetworkId (Address ByronAddr) - eitherNwOrAddr = - case nwOrAddr of - WitnessNetworkId nw -> Left nw - WitnessByronAddress addr -> Right addr - - unByronAddr :: Address ByronAddr -> Byron.Address - unByronAddr (ByronAddress addr) = addr - - unAddrAttrs :: Address ByronAddr -> Byron.AddrAttributes - unAddrAttrs = Byron.attrData . Byron.addrAttributes . unByronAddr - - derivationPath :: Maybe Byron.HDAddressPayload - derivationPath = - either - (const Nothing) - (Byron.aaVKDerivationPath . unAddrAttrs) - eitherNwOrAddr - - networkMagic :: Byron.NetworkMagic - networkMagic = - either - toByronNetworkMagic - (Byron.aaNetworkMagic . unAddrAttrs) - eitherNwOrAddr - - -makeShelleyKeyWitness :: forall era. () + -- Now the hairy bits. + -- + -- Byron era signing keys were all /extended/ ed25519 keys. We have to + -- produce a signature using this extended signing key directly. They + -- /cannot/ be converted to a plain (non-extended) signing keys. Since we + -- now support extended signing keys for the Shelley too, we are able to + -- reuse that here. + -- + signature + :: Shelley.SignedDSIGN + StandardCrypto + (Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody) + signature = + makeShelleySignature + txhash + -- Make the signature with the extended key directly: + (ShelleyExtendedSigningKey (Byron.unSigningKey sk)) + + txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody + txhash = shelleyBasedEraConstraints sbe $ Ledger.extractHash (Ledger.hashAnnotated txbody) + -- TODO: use Shelley.eraIndTxBodyHash txbody once that function has a + -- suitably general type. + + -- And finally we need to provide the extra suffix bytes necessary to + -- reconstruct the mini-Merkel tree that is a Byron address. The suffix + -- bytes are the serialised address attributes. + attributes = + Plain.serialize' $ + Byron.mkAttributes + Byron.AddrAttributes + { Byron.aaVKDerivationPath = derivationPath + , Byron.aaNetworkMagic = networkMagic + } + + -- The 'WitnessNetworkIdOrByronAddress' value converted to an 'Either'. + eitherNwOrAddr :: Either NetworkId (Address ByronAddr) + eitherNwOrAddr = + case nwOrAddr of + WitnessNetworkId nw -> Left nw + WitnessByronAddress addr -> Right addr + + unByronAddr :: Address ByronAddr -> Byron.Address + unByronAddr (ByronAddress addr) = addr + + unAddrAttrs :: Address ByronAddr -> Byron.AddrAttributes + unAddrAttrs = Byron.attrData . Byron.addrAttributes . unByronAddr + + derivationPath :: Maybe Byron.HDAddressPayload + derivationPath = + either + (const Nothing) + (Byron.aaVKDerivationPath . unAddrAttrs) + eitherNwOrAddr + + networkMagic :: Byron.NetworkMagic + networkMagic = + either + toByronNetworkMagic + (Byron.aaNetworkMagic . unAddrAttrs) + eitherNwOrAddr + +makeShelleyKeyWitness + :: forall era + . () => ShelleyBasedEra era -> TxBody era -> ShelleyWitnessSigningKey @@ -1064,58 +1114,57 @@ makeShelleyKeyWitness sbe = \case shelleyBasedEraConstraints sbe $ let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody) - - -- To allow sharing of the txhash computation across many signatures we + in -- To allow sharing of the txhash computation across many signatures we -- define and share the txhash outside the lambda for the signing key: - in \wsk -> - let sk = toShelleySigningKey wsk - vk = getShelleyKeyWitnessVerificationKey sk - signature = makeShelleySignature txhash sk - in ShelleyKeyWitness sbe $ - L.WitVKey vk signature - - - - + \wsk -> + let sk = toShelleySigningKey wsk + vk = getShelleyKeyWitnessVerificationKey sk + signature = makeShelleySignature txhash sk + in ShelleyKeyWitness sbe $ + L.WitVKey vk signature toShelleySigningKey :: ShelleyWitnessSigningKey -> ShelleySigningKey toShelleySigningKey key = case key of - WitnessPaymentKey (PaymentSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessStakeKey (StakeSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessStakePoolKey (StakePoolSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessGenesisKey (GenesisSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessPaymentKey (PaymentSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessStakeKey (StakeSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessStakePoolKey (StakePoolSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessGenesisKey (GenesisSigningKey sk) -> ShelleyNormalSigningKey sk WitnessGenesisUTxOKey (GenesisUTxOSigningKey sk) -> ShelleyNormalSigningKey sk WitnessGenesisDelegateKey (GenesisDelegateSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessCommitteeColdKey (CommitteeColdSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessCommitteeHotKey (CommitteeHotSigningKey sk) -> ShelleyNormalSigningKey sk - WitnessDRepKey (DRepSigningKey sk) -> ShelleyNormalSigningKey sk - + WitnessCommitteeColdKey (CommitteeColdSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessCommitteeHotKey (CommitteeHotSigningKey sk) -> ShelleyNormalSigningKey sk + WitnessDRepKey (DRepSigningKey sk) -> ShelleyNormalSigningKey sk -- The cases for extended keys - WitnessPaymentExtendedKey (PaymentExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk - WitnessStakeExtendedKey (StakeExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk - WitnessGenesisExtendedKey (GenesisExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessPaymentExtendedKey (PaymentExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessStakeExtendedKey (StakeExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessGenesisExtendedKey (GenesisExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk WitnessGenesisDelegateExtendedKey (GenesisDelegateExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk - WitnessCommitteeColdExtendedKey (CommitteeColdExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk - WitnessCommitteeHotExtendedKey (CommitteeHotExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk - WitnessDRepExtendedKey (DRepExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessCommitteeColdExtendedKey (CommitteeColdExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessCommitteeHotExtendedKey (CommitteeHotExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk + WitnessDRepExtendedKey (DRepExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk getShelleyKeyWitnessVerificationKey :: ShelleySigningKey -> Shelley.VKey Shelley.Witness StandardCrypto getShelleyKeyWitnessVerificationKey (ShelleyNormalSigningKey sk) = - (Shelley.asWitness :: Shelley.VKey Shelley.Payment StandardCrypto - -> Shelley.VKey Shelley.Witness StandardCrypto) + ( Shelley.asWitness + :: Shelley.VKey Shelley.Payment StandardCrypto + -> Shelley.VKey Shelley.Witness StandardCrypto + ) . (\(PaymentVerificationKey vk) -> vk) . getVerificationKey . PaymentSigningKey $ sk - getShelleyKeyWitnessVerificationKey (ShelleyExtendedSigningKey sk) = - (Shelley.asWitness :: Shelley.VKey Shelley.Payment StandardCrypto - -> Shelley.VKey Shelley.Witness StandardCrypto) + ( Shelley.asWitness + :: Shelley.VKey Shelley.Payment StandardCrypto + -> Shelley.VKey Shelley.Witness StandardCrypto + ) . (\(PaymentVerificationKey vk) -> vk) - . (castVerificationKey :: VerificationKey PaymentExtendedKey - -> VerificationKey PaymentKey) + . ( castVerificationKey + :: VerificationKey PaymentExtendedKey + -> VerificationKey PaymentKey + ) . getVerificationKey . PaymentExtendedSigningKey $ sk diff --git a/cardano-api/internal/Cardano/Api/TxIn.hs b/cardano-api/internal/Cardano/Api/TxIn.hs index aacf77f065..90f4939ecf 100644 --- a/cardano-api/internal/Cardano/Api/TxIn.hs +++ b/cardano-api/internal/Cardano/Api/TxIn.hs @@ -10,60 +10,57 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} - -- | Transaction bodies --- -module Cardano.Api.TxIn ( - -- * Transaction inputs - TxIn(..), - TxIx(..), +module Cardano.Api.TxIn + ( -- * Transaction inputs + TxIn (..) + , TxIx (..) -- * Transaction Ids - TxId(..), - parseTxId, + , TxId (..) + , parseTxId -- * Data family instances - AsType(AsTxId), + , AsType (AsTxId) -- * Internal conversion functions - toByronTxId, - toShelleyTxId, - fromShelleyTxId, - toByronTxIn, - fromByronTxIn, - toShelleyTxIn, - fromShelleyTxIn, - renderTxIn, - ) where - -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseUsing -import Cardano.Api.Utils - + , toByronTxId + , toShelleyTxId + , fromShelleyTxId + , toByronTxIn + , fromByronTxIn + , toShelleyTxIn + , fromShelleyTxIn + , renderTxIn + ) +where + +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseUsing +import Cardano.Api.Utils import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.SafeHash as SafeHash import qualified Cardano.Ledger.Shelley.TxBody as Shelley import qualified Cardano.Ledger.TxIn as Ledger - -import Control.Applicative (some) -import Data.Aeson (withText) +import Control.Applicative (some) +import Data.Aeson (withText) import qualified Data.Aeson as Aeson -import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) +import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) import qualified Data.ByteString.Char8 as BSC -import Data.String -import Data.Text (Text) +import Data.String +import Data.Text (Text) import qualified Data.Text as Text +import Text.Parsec (()) import qualified Text.Parsec as Parsec -import Text.Parsec (()) import qualified Text.Parsec.Language as Parsec import qualified Text.Parsec.String as Parsec import qualified Text.Parsec.Token as Parsec @@ -78,32 +75,31 @@ import qualified Text.Parsec.Token as Parsec newtype TxId = TxId (Shelley.Hash StandardCrypto Shelley.EraIndependentTxBody) -- We use the Shelley representation and convert to/from the Byron one deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex TxId - deriving (ToJSON, FromJSON) via UsingRawBytesHex TxId + deriving (Show, IsString) via UsingRawBytesHex TxId + deriving (ToJSON, FromJSON) via UsingRawBytesHex TxId deriving (ToJSONKey, FromJSONKey) via UsingRawBytesHex TxId instance HasTypeProxy TxId where - data AsType TxId = AsTxId - proxyToAsType _ = AsTxId + data AsType TxId = AsTxId + proxyToAsType _ = AsTxId instance SerialiseAsRawBytes TxId where - serialiseToRawBytes (TxId h) = Crypto.hashToBytes h - deserialiseFromRawBytes AsTxId bs = case Crypto.hashFromBytes bs of - Just a -> Right (TxId a) - Nothing -> Left $ SerialiseAsRawBytesError "Unable to deserialise TxId" + serialiseToRawBytes (TxId h) = Crypto.hashToBytes h + deserialiseFromRawBytes AsTxId bs = case Crypto.hashFromBytes bs of + Just a -> Right (TxId a) + Nothing -> Left $ SerialiseAsRawBytesError "Unable to deserialise TxId" toByronTxId :: TxId -> Byron.TxId toByronTxId (TxId h) = - Byron.unsafeHashFromBytes (Crypto.hashToBytes h) + Byron.unsafeHashFromBytes (Crypto.hashToBytes h) toShelleyTxId :: TxId -> Ledger.TxId StandardCrypto toShelleyTxId (TxId h) = - Ledger.TxId (SafeHash.unsafeMakeSafeHash (Crypto.castHash h)) + Ledger.TxId (SafeHash.unsafeMakeSafeHash (Crypto.castHash h)) fromShelleyTxId :: Ledger.TxId StandardCrypto -> TxId fromShelleyTxId (Ledger.TxId h) = - TxId (Crypto.castHash (SafeHash.extractHash h)) - + TxId (Crypto.castHash (SafeHash.extractHash h)) -- ---------------------------------------------------------------------------- -- Transaction inputs @@ -140,14 +136,12 @@ parseTxIx :: Parsec.Parser TxIx parseTxIx = TxIx . fromIntegral <$> decimal decimal :: Parsec.Parser Integer -Parsec.TokenParser { Parsec.decimal = decimal } = Parsec.haskell - +Parsec.TokenParser {Parsec.decimal = decimal} = Parsec.haskell renderTxIn :: TxIn -> Text renderTxIn (TxIn txId (TxIx ix)) = serialiseToRawBytesHexText txId <> "#" <> Text.pack (show ix) - newtype TxIx = TxIx Word deriving stock (Eq, Ord, Show) deriving newtype (Enum) @@ -157,20 +151,20 @@ fromByronTxIn :: Byron.TxIn -> TxIn fromByronTxIn (Byron.TxInUtxo txId index) = let shortBs = Byron.abstractHashToShort txId mApiHash = Crypto.hashFromBytesShort shortBs - in case mApiHash of - Just apiHash -> TxIn (TxId apiHash) (TxIx . fromIntegral $ toInteger index) - Nothing -> error $ "Error converting Byron era TxId: " <> show txId + in case mApiHash of + Just apiHash -> TxIn (TxId apiHash) (TxIx . fromIntegral $ toInteger index) + Nothing -> error $ "Error converting Byron era TxId: " <> show txId toByronTxIn :: TxIn -> Byron.TxIn toByronTxIn (TxIn txid (TxIx txix)) = - Byron.TxInUtxo (toByronTxId txid) (fromIntegral txix) + Byron.TxInUtxo (toByronTxId txid) (fromIntegral txix) -- | This function may overflow on the transaction index. Call sites must ensure -- that all uses of this function are appropriately guarded. toShelleyTxIn :: TxIn -> Ledger.TxIn StandardCrypto toShelleyTxIn (TxIn txid (TxIx txix)) = - Ledger.TxIn (toShelleyTxId txid) (Ledger.TxIx $ fromIntegral txix) + Ledger.TxIn (toShelleyTxId txid) (Ledger.TxIx $ fromIntegral txix) fromShelleyTxIn :: Ledger.TxIn StandardCrypto -> TxIn fromShelleyTxIn (Ledger.TxIn txid (Ledger.TxIx txix)) = - TxIn (fromShelleyTxId txid) (TxIx (fromIntegral txix)) + TxIn (fromShelleyTxId txid) (TxIx (fromIntegral txix)) diff --git a/cardano-api/internal/Cardano/Api/TxMetadata.hs b/cardano-api/internal/Cardano/Api/TxMetadata.hs index 3f1346c11e..4534456f29 100644 --- a/cardano-api/internal/Cardano/Api/TxMetadata.hs +++ b/cardano-api/internal/Cardano/Api/TxMetadata.hs @@ -4,141 +4,140 @@ {-# LANGUAGE ViewPatterns #-} -- | Metadata embedded in transactions --- -module Cardano.Api.TxMetadata ( - - -- * Types - TxMetadata (TxMetadata), +module Cardano.Api.TxMetadata + ( -- * Types + TxMetadata (TxMetadata) -- * Class - AsTxMetadata (..), + , AsTxMetadata (..) -- * Constructing metadata - TxMetadataValue(..), - makeTransactionMetadata, - mergeTransactionMetadata, - metaTextChunks, - metaBytesChunks, + , TxMetadataValue (..) + , makeTransactionMetadata + , mergeTransactionMetadata + , metaTextChunks + , metaBytesChunks -- * Validating metadata - validateTxMetadata, - TxMetadataRangeError (..), + , validateTxMetadata + , TxMetadataRangeError (..) -- * Conversion to\/from JSON - TxMetadataJsonSchema (..), - metadataFromJson, - metadataToJson, - metadataValueToJsonNoSchema, - TxMetadataJsonError (..), - TxMetadataJsonSchemaError (..), + , TxMetadataJsonSchema (..) + , metadataFromJson + , metadataToJson + , metadataValueToJsonNoSchema + , TxMetadataJsonError (..) + , TxMetadataJsonSchemaError (..) -- * Internal conversion functions - toShelleyMetadata, - fromShelleyMetadata, - toShelleyMetadatum, - fromShelleyMetadatum, + , toShelleyMetadata + , fromShelleyMetadata + , toShelleyMetadatum + , fromShelleyMetadatum -- * Shared parsing utils - parseAll, - pUnsigned, - pSigned, - pBytes, + , parseAll + , pUnsigned + , pSigned + , pBytes -- * Data family instances - AsType(..) - ) where - -import Cardano.Api.Eras -import Cardano.Api.Error -import Cardano.Api.HasTypeProxy -import Cardano.Api.Pretty -import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..)) - + , AsType (..) + ) +where + +import Cardano.Api.Eras +import Cardano.Api.Error +import Cardano.Api.HasTypeProxy +import Cardano.Api.Pretty +import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..)) import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Shelley.TxAuxData as Shelley - import qualified Codec.CBOR.Magic as CBOR -import Control.Applicative (Alternative (..)) -import Control.Monad (guard, when) +import Control.Applicative (Alternative (..)) +import Control.Monad (guard, when) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Text as Aeson.Text import qualified Data.Attoparsec.ByteString.Char8 as Atto -import Data.Bifunctor (bimap, first) -import Data.ByteString (ByteString) +import Data.Bifunctor (bimap, first) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Data (Data) +import Data.Data (Data) import qualified Data.List as List import qualified Data.Map.Lazy as Map.Lazy -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Scientific as Scientific -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Vector as Vector -import Data.Word +import Data.Word -- ---------------------------------------------------------------------------- -- TxMetadata types -- -newtype TxMetadata = TxMetadata { unTxMetadata :: Map Word64 TxMetadataValue } - deriving (Eq, Show) +newtype TxMetadata = TxMetadata {unTxMetadata :: Map Word64 TxMetadataValue} + deriving (Eq, Show) + +data TxMetadataValue + = TxMetaMap [(TxMetadataValue, TxMetadataValue)] + | TxMetaList [TxMetadataValue] + | TxMetaNumber Integer -- -2^64 .. 2^64-1 + | TxMetaBytes ByteString + | TxMetaText Text + deriving (Eq, Ord, Show) -data TxMetadataValue = TxMetaMap [(TxMetadataValue, TxMetadataValue)] - | TxMetaList [TxMetadataValue] - | TxMetaNumber Integer -- -2^64 .. 2^64-1 - | TxMetaBytes ByteString - | TxMetaText Text - deriving (Eq, Ord, Show) - -- Note the order of constructors is the same as the ledger definitions - -- so that the Ord instance is consistent with the ledger one. - -- This is checked by prop_ord_distributive_TxMetadata +-- Note the order of constructors is the same as the ledger definitions +-- so that the Ord instance is consistent with the ledger one. +-- This is checked by prop_ord_distributive_TxMetadata -- | Merge metadata maps. When there are clashing entries the left hand side -- takes precedence. --- instance Semigroup TxMetadata where - TxMetadata m1 <> TxMetadata m2 = TxMetadata (m1 <> m2) + TxMetadata m1 <> TxMetadata m2 = TxMetadata (m1 <> m2) instance Monoid TxMetadata where - mempty = TxMetadata mempty + mempty = TxMetadata mempty instance HasTypeProxy TxMetadata where - data AsType TxMetadata = AsTxMetadata - proxyToAsType _ = AsTxMetadata + data AsType TxMetadata = AsTxMetadata + proxyToAsType _ = AsTxMetadata instance SerialiseAsCBOR TxMetadata where - serialiseToCBOR = - -- This is a workaround. There is a tiny chance that serialization could change - -- for Metadata in the future, depending on the era it is being used in. For now - -- we can pretend like it is the same for all eras starting with Shelley - -- - -- Versioned cbor works only when we have protocol version available during - -- [de]serialization. The only two ways to fix this: - -- - -- - Paramterize TxMetadata with era. This would allow us to get protocol version - -- from the type level - -- - -- - Change SerialiseAsCBOR interface in such a way that it allows major - -- protocol version be supplied as an argument. - CBOR.serialize' CBOR.shelleyProtVer - . toShelleyMetadata - . unTxMetadata - - deserialiseFromCBOR AsTxMetadata bs = - TxMetadata - . fromShelleyMetadata - <$> (CBOR.decodeFullDecoder' CBOR.shelleyProtVer "TxMetadata" CBOR.decCBOR bs - :: Either CBOR.DecoderError (Map Word64 Shelley.Metadatum)) + serialiseToCBOR = + -- This is a workaround. There is a tiny chance that serialization could change + -- for Metadata in the future, depending on the era it is being used in. For now + -- we can pretend like it is the same for all eras starting with Shelley + -- + -- Versioned cbor works only when we have protocol version available during + -- [de]serialization. The only two ways to fix this: + -- + -- - Paramterize TxMetadata with era. This would allow us to get protocol version + -- from the type level + -- + -- - Change SerialiseAsCBOR interface in such a way that it allows major + -- protocol version be supplied as an argument. + CBOR.serialize' CBOR.shelleyProtVer + . toShelleyMetadata + . unTxMetadata + + deserialiseFromCBOR AsTxMetadata bs = + TxMetadata + . fromShelleyMetadata + <$> ( CBOR.decodeFullDecoder' CBOR.shelleyProtVer "TxMetadata" CBOR.decCBOR bs + :: Either CBOR.DecoderError (Map Word64 Shelley.Metadatum) + ) makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata makeTransactionMetadata = TxMetadata @@ -155,11 +154,12 @@ mergeTransactionMetadata merge (TxMetadata m1) (TxMetadata m2) = -- acceptable size. metaTextChunks :: Text -> TxMetadataValue metaTextChunks = - TxMetaList . chunks - txMetadataTextStringMaxByteLength - TxMetaText - (BS.length . Text.encodeUtf8) - utf8SplitAt + TxMetaList + . chunks + txMetadataTextStringMaxByteLength + TxMetaText + (BS.length . Text.encodeUtf8) + utf8SplitAt where fromBuilder = Text.Lazy.toStrict . Text.Builder.toLazyText @@ -171,38 +171,44 @@ metaTextChunks = -- splitAt that counts utf8 bytes. Using builders for slightly more -- efficiency. utf8SplitAt n = - bimap fromBuilder fromBuilder . snd . Text.foldl - (\(len, (left, right)) char -> - -- NOTE: - -- Starting from text >= 2.0.0.0, one can use: - -- - -- Data.Text.Internal.Encoding.Utf8#utf8Length - -- - let sz = BS.length (Text.encodeUtf8 (Text.singleton char)) in - if len + sz > n then - ( n + 1 -- Higher than 'n' to always trigger the predicate - , ( left - , right <> Text.Builder.singleton char - ) - ) - else - ( len + sz - , ( left <> Text.Builder.singleton char - , right - ) - ) - ) - (0, (mempty, mempty)) + bimap fromBuilder fromBuilder + . snd + . Text.foldl + ( \(len, (left, right)) char -> + -- NOTE: + -- Starting from text >= 2.0.0.0, one can use: + -- + -- Data.Text.Internal.Encoding.Utf8#utf8Length + -- + let sz = BS.length (Text.encodeUtf8 (Text.singleton char)) + in if len + sz > n + then + ( n + 1 -- Higher than 'n' to always trigger the predicate + , + ( left + , right <> Text.Builder.singleton char + ) + ) + else + ( len + sz + , + ( left <> Text.Builder.singleton char + , right + ) + ) + ) + (0, (mempty, mempty)) -- | Create a 'TxMetadataValue' from a 'ByteString' as a list of chunks of an -- accaptable size. metaBytesChunks :: ByteString -> TxMetadataValue metaBytesChunks = - TxMetaList . chunks - txMetadataByteStringMaxLength - TxMetaBytes - BS.length - BS.splitAt + TxMetaList + . chunks + txMetadataByteStringMaxLength + TxMetaBytes + BS.length + BS.splitAt -- ---------------------------------------------------------------------------- -- TxMetadata class @@ -220,49 +226,57 @@ toShelleyMetadata = Map.map toShelleyMetadatum toShelleyMetadatum :: TxMetadataValue -> Shelley.Metadatum toShelleyMetadatum (TxMetaNumber x) = Shelley.I x -toShelleyMetadatum (TxMetaBytes x) = Shelley.B x -toShelleyMetadatum (TxMetaText x) = Shelley.S x -toShelleyMetadatum (TxMetaList xs) = Shelley.List - [ toShelleyMetadatum x | x <- xs ] -toShelleyMetadatum (TxMetaMap xs) = Shelley.Map - [ (toShelleyMetadatum k, - toShelleyMetadatum v) - | (k,v) <- xs ] +toShelleyMetadatum (TxMetaBytes x) = Shelley.B x +toShelleyMetadatum (TxMetaText x) = Shelley.S x +toShelleyMetadatum (TxMetaList xs) = + Shelley.List + [toShelleyMetadatum x | x <- xs] +toShelleyMetadatum (TxMetaMap xs) = + Shelley.Map + [ ( toShelleyMetadatum k + , toShelleyMetadatum v + ) + | (k, v) <- xs + ] fromShelleyMetadata :: Map Word64 Shelley.Metadatum -> Map Word64 TxMetadataValue fromShelleyMetadata = Map.Lazy.map fromShelleyMetadatum fromShelleyMetadatum :: Shelley.Metadatum -> TxMetadataValue -fromShelleyMetadatum (Shelley.I x) = TxMetaNumber x -fromShelleyMetadatum (Shelley.B x) = TxMetaBytes x -fromShelleyMetadatum (Shelley.S x) = TxMetaText x -fromShelleyMetadatum (Shelley.List xs) = TxMetaList - [ fromShelleyMetadatum x | x <- xs ] -fromShelleyMetadatum (Shelley.Map xs) = TxMetaMap - [ (fromShelleyMetadatum k, - fromShelleyMetadatum v) - | (k,v) <- xs ] +fromShelleyMetadatum (Shelley.I x) = TxMetaNumber x +fromShelleyMetadatum (Shelley.B x) = TxMetaBytes x +fromShelleyMetadatum (Shelley.S x) = TxMetaText x +fromShelleyMetadatum (Shelley.List xs) = + TxMetaList + [fromShelleyMetadatum x | x <- xs] +fromShelleyMetadatum (Shelley.Map xs) = + TxMetaMap + [ ( fromShelleyMetadatum k + , fromShelleyMetadatum v + ) + | (k, v) <- xs + ] -- | Transform a string-like structure into chunks with a maximum size; Chunks -- are filled from left to right. chunks :: Int - -- ^ Chunk max size (inclusive) + -- ^ Chunk max size (inclusive) -> (str -> chunk) - -- ^ Hoisting + -- ^ Hoisting -> (str -> Int) - -- ^ Measuring + -- ^ Measuring -> (Int -> str -> (str, str)) - -- ^ Splitting + -- ^ Splitting -> str - -- ^ String + -- ^ String -> [chunk] chunks maxLength strHoist strLength strSplitAt str | strLength str > maxLength = - let (h, t) = strSplitAt maxLength str - in strHoist h : chunks maxLength strHoist strLength strSplitAt t + let (h, t) = strSplitAt maxLength str + in strHoist h : chunks maxLength strHoist strLength strSplitAt t | otherwise = - [strHoist str | strLength str > 0] + [strHoist str | strLength str > 0] -- ---------------------------------------------------------------------------- -- Validate tx metadata @@ -270,40 +284,42 @@ chunks maxLength strHoist strLength strSplitAt str -- | Validate transaction metadata. This is for use with existing constructed -- metadata values, e.g. constructed manually or decoded from CBOR directly. --- validateTxMetadata :: TxMetadata -> Either [(Word64, TxMetadataRangeError)] () validateTxMetadata (TxMetadata m) = - -- Collect all errors and do a top-level check to see if there are any. - case [ (k, err) - | (k, v) <- Map.toList m - , err <- validateTxMetadataValue v ] of - [] -> Right () - errs -> Left errs + -- Collect all errors and do a top-level check to see if there are any. + case [ (k, err) + | (k, v) <- Map.toList m + , err <- validateTxMetadataValue v + ] of + [] -> Right () + errs -> Left errs -- collect all errors in a monoidal fold style validateTxMetadataValue :: TxMetadataValue -> [TxMetadataRangeError] validateTxMetadataValue (TxMetaNumber n) = - [ TxMetadataNumberOutOfRange n - | n > fromIntegral (maxBound :: Word64) + [ TxMetadataNumberOutOfRange n + | n > fromIntegral (maxBound :: Word64) || n < negate (fromIntegral (maxBound :: Word64)) - ] + ] validateTxMetadataValue (TxMetaBytes bs) = - [ TxMetadataBytesTooLong len - | let len = BS.length bs - , len > txMetadataByteStringMaxLength - ] + [ TxMetadataBytesTooLong len + | let len = BS.length bs + , len > txMetadataByteStringMaxLength + ] validateTxMetadataValue (TxMetaText txt) = - [ TxMetadataTextTooLong len - | let len = BS.length (Text.encodeUtf8 txt) - , len > txMetadataTextStringMaxByteLength - ] + [ TxMetadataTextTooLong len + | let len = BS.length (Text.encodeUtf8 txt) + , len > txMetadataTextStringMaxByteLength + ] validateTxMetadataValue (TxMetaList xs) = - foldMap validateTxMetadataValue xs - + foldMap validateTxMetadataValue xs validateTxMetadataValue (TxMetaMap kvs) = - foldMap (\(k, v) -> validateTxMetadataValue k - <> validateTxMetadataValue v) - kvs + foldMap + ( \(k, v) -> + validateTxMetadataValue k + <> validateTxMetadataValue v + ) + kvs -- | The maximum byte length of a transaction metadata text string value. txMetadataTextStringMaxByteLength :: Int @@ -313,24 +329,16 @@ txMetadataTextStringMaxByteLength = 64 txMetadataByteStringMaxLength :: Int txMetadataByteStringMaxLength = 64 - -- | An error in transaction metadata due to an out-of-range value. --- -data TxMetadataRangeError = - - -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. - -- +data TxMetadataRangeError + = -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@. TxMetadataNumberOutOfRange !Integer - - -- | The length of a text string metadatum value exceeds the maximum of + | -- | The length of a text string metadatum value exceeds the maximum of -- 64 bytes as UTF8. - -- - | TxMetadataTextTooLong !Int - - -- | The length of a byte string metadatum value exceeds the maximum of + TxMetadataTextTooLong !Int + | -- | The length of a byte string metadatum value exceeds the maximum of -- 64 bytes. - -- - | TxMetadataBytesTooLong !Int + TxMetadataBytesTooLong !Int deriving (Eq, Show, Data) instance Error TxMetadataRangeError where @@ -352,7 +360,6 @@ instance Error TxMetadataRangeError where <> pretty actualLen <> " bytes." - -- ---------------------------------------------------------------------------- -- JSON conversion -- @@ -405,93 +412,94 @@ instance Error TxMetadataRangeError where -- precisely. It also means any tx metadata can be converted into the JSON and -- back without loss. That is we can round-trip the tx metadata via the JSON and -- also round-trip schema-compliant JSON via tx metadata. --- -data TxMetadataJsonSchema = - - -- | Use the \"no schema\" mapping between JSON and tx metadata as - -- described above. - TxMetadataJsonNoSchema - - -- | Use the \"detailed schema\" mapping between JSON and tx metadata as - -- described above. - | TxMetadataJsonDetailedSchema +data TxMetadataJsonSchema + = -- | Use the \"no schema\" mapping between JSON and tx metadata as + -- described above. + TxMetadataJsonNoSchema + | -- | Use the \"detailed schema\" mapping between JSON and tx metadata as + -- described above. + TxMetadataJsonDetailedSchema deriving (Eq, Show) - -- | Convert a value from JSON into tx metadata, using the given choice of -- mapping between JSON and tx metadata. -- -- This may fail with a conversion error if the JSON is outside the supported -- subset for the chosen mapping. See 'TxMetadataJsonSchema' for the details. --- -metadataFromJson :: TxMetadataJsonSchema - -> Aeson.Value - -> Either TxMetadataJsonError TxMetadata +metadataFromJson + :: TxMetadataJsonSchema + -> Aeson.Value + -> Either TxMetadataJsonError TxMetadata metadataFromJson schema = - \case - -- The top level has to be an object - -- with unsigned integer (decimal or hex) keys - Aeson.Object m -> - fmap (TxMetadata . Map.fromList) + \case + -- The top level has to be an object + -- with unsigned integer (decimal or hex) keys + Aeson.Object m -> + fmap (TxMetadata . Map.fromList) . mapM (uncurry metadataKeyPairFromJson) $ KeyMap.toList m - - _ -> Left TxMetadataJsonToplevelNotMap - where - metadataKeyPairFromJson :: Aeson.Key - -> Aeson.Value - -> Either TxMetadataJsonError - (Word64, TxMetadataValue) - metadataKeyPairFromJson k v = do - k' <- convTopLevelKey k - v' <- first (TxMetadataJsonSchemaError k' v) - (metadataValueFromJson v) - first (TxMetadataRangeError k' v) - (validateMetadataValue v') - return (k', v') - - convTopLevelKey :: Aeson.Key -> Either TxMetadataJsonError Word64 - convTopLevelKey (Aeson.toText -> k) = - case parseAll (pUnsigned <* Atto.endOfInput) k of - Just n | n <= fromIntegral (maxBound :: Word64) - -> Right (fromIntegral n) - _ -> Left (TxMetadataJsonToplevelBadKey k) - - validateMetadataValue :: TxMetadataValue -> Either TxMetadataRangeError () - validateMetadataValue v = - case validateTxMetadataValue v of - [] -> Right () - err : _ -> Left err - - metadataValueFromJson :: Aeson.Value - -> Either TxMetadataJsonSchemaError TxMetadataValue - metadataValueFromJson = - case schema of - TxMetadataJsonNoSchema -> metadataValueFromJsonNoSchema - TxMetadataJsonDetailedSchema -> metadataValueFromJsonDetailedSchema - + _ -> Left TxMetadataJsonToplevelNotMap + where + metadataKeyPairFromJson + :: Aeson.Key + -> Aeson.Value + -> Either + TxMetadataJsonError + (Word64, TxMetadataValue) + metadataKeyPairFromJson k v = do + k' <- convTopLevelKey k + v' <- + first + (TxMetadataJsonSchemaError k' v) + (metadataValueFromJson v) + first + (TxMetadataRangeError k' v) + (validateMetadataValue v') + return (k', v') + + convTopLevelKey :: Aeson.Key -> Either TxMetadataJsonError Word64 + convTopLevelKey (Aeson.toText -> k) = + case parseAll (pUnsigned <* Atto.endOfInput) k of + Just n + | n <= fromIntegral (maxBound :: Word64) -> + Right (fromIntegral n) + _ -> Left (TxMetadataJsonToplevelBadKey k) + + validateMetadataValue :: TxMetadataValue -> Either TxMetadataRangeError () + validateMetadataValue v = + case validateTxMetadataValue v of + [] -> Right () + err : _ -> Left err + + metadataValueFromJson + :: Aeson.Value + -> Either TxMetadataJsonSchemaError TxMetadataValue + metadataValueFromJson = + case schema of + TxMetadataJsonNoSchema -> metadataValueFromJsonNoSchema + TxMetadataJsonDetailedSchema -> metadataValueFromJsonDetailedSchema -- | Convert a tx metadata value into JSON , using the given choice of mapping -- between JSON and tx metadata. -- -- This conversion is total but is not necessarily invertible. -- See 'TxMetadataJsonSchema' for the details. --- -metadataToJson :: TxMetadataJsonSchema - -> TxMetadata - -> Aeson.Value +metadataToJson + :: TxMetadataJsonSchema + -> TxMetadata + -> Aeson.Value metadataToJson schema = - \(TxMetadata mdMap) -> + \(TxMetadata mdMap) -> Aeson.object [ (Aeson.fromString (show k), metadataValueToJson v) - | (k, v) <- Map.toList mdMap ] - where - metadataValueToJson :: TxMetadataValue -> Aeson.Value - metadataValueToJson = - case schema of - TxMetadataJsonNoSchema -> metadataValueToJsonNoSchema - TxMetadataJsonDetailedSchema -> metadataValueToJsonDetailedSchema - + | (k, v) <- Map.toList mdMap + ] + where + metadataValueToJson :: TxMetadataValue -> Aeson.Value + metadataValueToJson = + case schema of + TxMetadataJsonNoSchema -> metadataValueToJsonNoSchema + TxMetadataJsonDetailedSchema -> metadataValueToJsonDetailedSchema -- ---------------------------------------------------------------------------- -- JSON conversion using the the "no schema" style @@ -499,82 +507,89 @@ metadataToJson schema = metadataValueToJsonNoSchema :: TxMetadataValue -> Aeson.Value metadataValueToJsonNoSchema = conv - where - conv :: TxMetadataValue -> Aeson.Value - conv (TxMetaNumber n) = Aeson.Number (fromInteger n) - conv (TxMetaBytes bs) = Aeson.String (bytesPrefix - <> Text.decodeLatin1 (Base16.encode bs)) - - conv (TxMetaText txt) = Aeson.String txt - conv (TxMetaList vs) = Aeson.Array (Vector.fromList (map conv vs)) - conv (TxMetaMap kvs) = Aeson.object - [ (convKey k, conv v) - | (k, v) <- kvs ] - - -- Metadata allows any value as a key, not just string as JSON does. - -- For simple types we just convert them to string directly. - -- For structured keys we render them as JSON and use that as the string. - convKey :: TxMetadataValue -> Aeson.Key - convKey (TxMetaNumber n) = Aeson.fromString (show n) - convKey (TxMetaBytes bs) = Aeson.fromText $ bytesPrefix - <> Text.decodeLatin1 (Base16.encode bs) - convKey (TxMetaText txt) = Aeson.fromText txt - convKey v = Aeson.fromText - . Text.Lazy.toStrict - . Aeson.Text.encodeToLazyText - . conv - $ v - -metadataValueFromJsonNoSchema :: Aeson.Value - -> Either TxMetadataJsonSchemaError - TxMetadataValue + where + conv :: TxMetadataValue -> Aeson.Value + conv (TxMetaNumber n) = Aeson.Number (fromInteger n) + conv (TxMetaBytes bs) = + Aeson.String + ( bytesPrefix + <> Text.decodeLatin1 (Base16.encode bs) + ) + conv (TxMetaText txt) = Aeson.String txt + conv (TxMetaList vs) = Aeson.Array (Vector.fromList (map conv vs)) + conv (TxMetaMap kvs) = + Aeson.object + [ (convKey k, conv v) + | (k, v) <- kvs + ] + + -- Metadata allows any value as a key, not just string as JSON does. + -- For simple types we just convert them to string directly. + -- For structured keys we render them as JSON and use that as the string. + convKey :: TxMetadataValue -> Aeson.Key + convKey (TxMetaNumber n) = Aeson.fromString (show n) + convKey (TxMetaBytes bs) = + Aeson.fromText $ + bytesPrefix + <> Text.decodeLatin1 (Base16.encode bs) + convKey (TxMetaText txt) = Aeson.fromText txt + convKey v = + Aeson.fromText + . Text.Lazy.toStrict + . Aeson.Text.encodeToLazyText + . conv + $ v + +metadataValueFromJsonNoSchema + :: Aeson.Value + -> Either + TxMetadataJsonSchemaError + TxMetadataValue metadataValueFromJsonNoSchema = conv - where - conv :: Aeson.Value - -> Either TxMetadataJsonSchemaError TxMetadataValue - conv Aeson.Null = Left TxMetadataJsonNullNotAllowed - conv Aeson.Bool{} = Left TxMetadataJsonBoolNotAllowed - - conv (Aeson.Number d) = - case Scientific.floatingOrInteger d :: Either Double Integer of - Left n -> Left (TxMetadataJsonNumberNotInteger n) - Right n -> Right (TxMetaNumber n) - - conv (Aeson.String s) - | Just s' <- Text.stripPrefix bytesPrefix s - , let bs' = Text.encodeUtf8 s' - , Right bs <- Base16.decode bs' - , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') - = Right (TxMetaBytes bs) - - conv (Aeson.String s) = Right (TxMetaText s) - - conv (Aeson.Array vs) = - fmap TxMetaList + where + conv + :: Aeson.Value + -> Either TxMetadataJsonSchemaError TxMetadataValue + conv Aeson.Null = Left TxMetadataJsonNullNotAllowed + conv Aeson.Bool {} = Left TxMetadataJsonBoolNotAllowed + conv (Aeson.Number d) = + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (TxMetadataJsonNumberNotInteger n) + Right n -> Right (TxMetaNumber n) + conv (Aeson.String s) + | Just s' <- Text.stripPrefix bytesPrefix s + , let bs' = Text.encodeUtf8 s' + , Right bs <- Base16.decode bs' + , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') = + Right (TxMetaBytes bs) + conv (Aeson.String s) = Right (TxMetaText s) + conv (Aeson.Array vs) = + fmap TxMetaList . traverse conv $ Vector.toList vs - - conv (Aeson.Object kvs) = - fmap - ( TxMetaMap - . sortCanonicalForCbor - ) - . traverse (\(k,v) -> (,) (convKey k) <$> conv v) - . fmap (first Aeson.toText) + conv (Aeson.Object kvs) = + fmap + ( TxMetaMap + . sortCanonicalForCbor + ) + . traverse + ((\(k, v) -> (,) (convKey k) <$> conv v) . first Aeson.toText) $ KeyMap.toList kvs - convKey :: Text -> TxMetadataValue - convKey s = - fromMaybe (TxMetaText s) $ - parseAll ((fmap TxMetaNumber pSigned <* Atto.endOfInput) - <|> (fmap TxMetaBytes pBytes <* Atto.endOfInput)) s + convKey :: Text -> TxMetadataValue + convKey s = + fromMaybe (TxMetaText s) $ + parseAll + ( (fmap TxMetaNumber pSigned <* Atto.endOfInput) + <|> (fmap TxMetaBytes pBytes <* Atto.endOfInput) + ) + s -- | JSON strings that are base16 encoded and prefixed with 'bytesPrefix' will -- be encoded as CBOR bytestrings. bytesPrefix :: Text bytesPrefix = "0x" - -- | Sorts the list by the first value in the tuple using the rules for canonical CBOR (RFC 7049 section 3.9) -- -- This function is used when transforming data from JSON. In principle the JSON standard and aeson library @@ -583,116 +598,118 @@ bytesPrefix = "0x" -- sorted according to the value of their byte representation. -- -- Details described here: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9 -sortCanonicalForCbor :: [(TxMetadataValue, TxMetadataValue)] - -> [(TxMetadataValue, TxMetadataValue)] +sortCanonicalForCbor + :: [(TxMetadataValue, TxMetadataValue)] + -> [(TxMetadataValue, TxMetadataValue)] sortCanonicalForCbor = map snd - . List.sortOn fst - . map (\e@(k, _) -> (CBOR.uintegerFromBytes $ serialiseKey k, e)) - where - serialiseKey = CBOR.serialize' CBOR.shelleyProtVer . toShelleyMetadatum + . List.sortOn fst + . map (\e@(k, _) -> (CBOR.uintegerFromBytes $ serialiseKey k, e)) + where + serialiseKey = CBOR.serialize' CBOR.shelleyProtVer . toShelleyMetadatum -- ---------------------------------------------------------------------------- -- JSON conversion using the "detailed schema" style -- metadataValueToJsonDetailedSchema :: TxMetadataValue -> Aeson.Value -metadataValueToJsonDetailedSchema = conv - where - conv :: TxMetadataValue -> Aeson.Value - conv (TxMetaNumber n) = singleFieldObject "int" - . Aeson.Number - $ fromInteger n - conv (TxMetaBytes bs) = singleFieldObject "bytes" - . Aeson.String - $ Text.decodeLatin1 (Base16.encode bs) - conv (TxMetaText txt) = singleFieldObject "string" - . Aeson.String - $ txt - conv (TxMetaList vs) = singleFieldObject "list" - . Aeson.Array - $ Vector.fromList (map conv vs) - conv (TxMetaMap kvs) = singleFieldObject "map" - . Aeson.Array - $ Vector.fromList - [ Aeson.object [ ("k", conv k), ("v", conv v) ] - | (k, v) <- kvs ] - - singleFieldObject name v = Aeson.object [(name, v)] - -metadataValueFromJsonDetailedSchema :: Aeson.Value - -> Either TxMetadataJsonSchemaError - TxMetadataValue +metadataValueToJsonDetailedSchema = conv + where + conv :: TxMetadataValue -> Aeson.Value + conv (TxMetaNumber n) = + singleFieldObject "int" + . Aeson.Number + $ fromInteger n + conv (TxMetaBytes bs) = + singleFieldObject "bytes" + . Aeson.String + $ Text.decodeLatin1 (Base16.encode bs) + conv (TxMetaText txt) = + singleFieldObject "string" + . Aeson.String + $ txt + conv (TxMetaList vs) = + singleFieldObject "list" + . Aeson.Array + $ Vector.fromList (map conv vs) + conv (TxMetaMap kvs) = + singleFieldObject "map" + . Aeson.Array + $ Vector.fromList + [ Aeson.object [("k", conv k), ("v", conv v)] + | (k, v) <- kvs + ] + + singleFieldObject name v = Aeson.object [(name, v)] + +metadataValueFromJsonDetailedSchema + :: Aeson.Value + -> Either + TxMetadataJsonSchemaError + TxMetadataValue metadataValueFromJsonDetailedSchema = conv - where - conv :: Aeson.Value - -> Either TxMetadataJsonSchemaError TxMetadataValue - conv (Aeson.Object m) = - case KeyMap.toList m of - [("int", Aeson.Number d)] -> - case Scientific.floatingOrInteger d :: Either Double Integer of - Left n -> Left (TxMetadataJsonNumberNotInteger n) - Right n -> Right (TxMetaNumber n) - - [("bytes", Aeson.String s)] - | Right bs <- Base16.decode (Text.encodeUtf8 s) - -> Right (TxMetaBytes bs) - - [("string", Aeson.String s)] -> Right (TxMetaText s) - - [("list", Aeson.Array vs)] -> - fmap TxMetaList + where + conv + :: Aeson.Value + -> Either TxMetadataJsonSchemaError TxMetadataValue + conv (Aeson.Object m) = + case KeyMap.toList m of + [("int", Aeson.Number d)] -> + case Scientific.floatingOrInteger d :: Either Double Integer of + Left n -> Left (TxMetadataJsonNumberNotInteger n) + Right n -> Right (TxMetaNumber n) + [("bytes", Aeson.String s)] + | Right bs <- Base16.decode (Text.encodeUtf8 s) -> + Right (TxMetaBytes bs) + [("string", Aeson.String s)] -> Right (TxMetaText s) + [("list", Aeson.Array vs)] -> + fmap TxMetaList . traverse conv $ Vector.toList vs - - [("map", Aeson.Array kvs)] -> - fmap TxMetaMap + [("map", Aeson.Array kvs)] -> + fmap TxMetaMap . traverse convKeyValuePair $ Vector.toList kvs - - [(key, v)] | key `elem` ["int", "bytes", "string", "list", "map"] -> + [(key, v)] + | key `elem` ["int", "bytes", "string", "list", "map"] -> Left (TxMetadataJsonTypeMismatch (Aeson.toText key) v) - - kvs -> Left (TxMetadataJsonBadObject (first Aeson.toText <$> kvs)) - - conv v = Left (TxMetadataJsonNotObject v) - - convKeyValuePair :: Aeson.Value - -> Either TxMetadataJsonSchemaError - (TxMetadataValue, TxMetadataValue) - convKeyValuePair (Aeson.Object m) - | KeyMap.size m == 2 - , Just k <- KeyMap.lookup "k" m - , Just v <- KeyMap.lookup "v" m - = (,) <$> conv k <*> conv v - - convKeyValuePair v = Left (TxMetadataJsonBadMapPair v) - + kvs -> Left (TxMetadataJsonBadObject (first Aeson.toText <$> kvs)) + conv v = Left (TxMetadataJsonNotObject v) + + convKeyValuePair + :: Aeson.Value + -> Either + TxMetadataJsonSchemaError + (TxMetadataValue, TxMetadataValue) + convKeyValuePair (Aeson.Object m) + | KeyMap.size m == 2 + , Just k <- KeyMap.lookup "k" m + , Just v <- KeyMap.lookup "v" m = + (,) <$> conv k <*> conv v + convKeyValuePair v = Left (TxMetadataJsonBadMapPair v) -- ---------------------------------------------------------------------------- -- Shared JSON conversion error types -- -data TxMetadataJsonError = - TxMetadataJsonToplevelNotMap - | TxMetadataJsonToplevelBadKey !Text - | TxMetadataJsonSchemaError !Word64 !Aeson.Value !TxMetadataJsonSchemaError - | TxMetadataRangeError !Word64 !Aeson.Value !TxMetadataRangeError +data TxMetadataJsonError + = TxMetadataJsonToplevelNotMap + | TxMetadataJsonToplevelBadKey !Text + | TxMetadataJsonSchemaError !Word64 !Aeson.Value !TxMetadataJsonSchemaError + | TxMetadataRangeError !Word64 !Aeson.Value !TxMetadataRangeError deriving (Eq, Show, Data) -data TxMetadataJsonSchemaError = - -- Only used for 'TxMetadataJsonNoSchema' - TxMetadataJsonNullNotAllowed - | TxMetadataJsonBoolNotAllowed - - -- Used by both mappings - | TxMetadataJsonNumberNotInteger !Double - - -- Only used for 'TxMetadataJsonDetailedSchema' - | TxMetadataJsonNotObject !Aeson.Value - | TxMetadataJsonBadObject ![(Text, Aeson.Value)] - | TxMetadataJsonBadMapPair !Aeson.Value - | TxMetadataJsonTypeMismatch !Text !Aeson.Value +data TxMetadataJsonSchemaError + = -- Only used for 'TxMetadataJsonNoSchema' + TxMetadataJsonNullNotAllowed + | TxMetadataJsonBoolNotAllowed + | -- Used by both mappings + TxMetadataJsonNumberNotInteger !Double + | -- Only used for 'TxMetadataJsonDetailedSchema' + TxMetadataJsonNotObject !Aeson.Value + | TxMetadataJsonBadObject ![(Text, Aeson.Value)] + | TxMetadataJsonBadMapPair !Aeson.Value + | TxMetadataJsonTypeMismatch !Text !Aeson.Value deriving (Eq, Show, Data) instance Error TxMetadataJsonError where @@ -744,24 +761,24 @@ instance Error TxMetadataJsonSchemaError where , pretty (LBS.unpack (Aeson.encode v)) ] - -- ---------------------------------------------------------------------------- -- Shared parsing utils -- parseAll :: Atto.Parser a -> Text -> Maybe a -parseAll p = either (const Nothing) Just - . Atto.parseOnly p - . Text.encodeUtf8 +parseAll p = + either (const Nothing) Just + . Atto.parseOnly p + . Text.encodeUtf8 pUnsigned :: Atto.Parser Integer pUnsigned = do - bs <- Atto.takeWhile1 Atto.isDigit - -- no redundant leading 0s allowed, or we cannot round-trip properly - guard (not (BS.length bs > 1 && BSC.head bs == '0')) - return $! BS.foldl' step 0 bs - where - step a w = a * 10 + fromIntegral (w - 48) + bs <- Atto.takeWhile1 Atto.isDigit + -- no redundant leading 0s allowed, or we cannot round-trip properly + guard (not (BS.length bs > 1 && BSC.head bs == '0')) + return $! BS.foldl' step 0 bs + where + step a w = a * 10 + fromIntegral (w - 48) pSigned :: Atto.Parser Integer pSigned = Atto.signed pUnsigned @@ -770,9 +787,10 @@ pBytes :: Atto.Parser ByteString pBytes = do _ <- Atto.string "0x" remaining <- Atto.takeByteString - when (BSC.any hexUpper remaining) $ fail ("Unexpected uppercase hex characters in " <> show remaining) + when (BSC.any hexUpper remaining) $ + fail ("Unexpected uppercase hex characters in " <> show remaining) case Base16.decode remaining of Right bs -> return bs _ -> fail ("Expecting base16 encoded string, found: " <> show remaining) - where - hexUpper c = c >= 'A' && c <= 'F' + where + hexUpper c = c >= 'A' && c <= 'F' diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index d1fb5a871b..f0afd2619b 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -11,7 +11,6 @@ #endif -- | Internal utils for the other Api modules --- module Cardano.Api.Utils ( (?!) , (?!.) @@ -29,39 +28,38 @@ module Cardano.Api.Utils -- ** CLI option parsing , bounded , unsafeBoundedRational - ) where + ) +where -import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Shelley () - -import Control.Exception (bracket) -import Control.Monad (when) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Shelley () +import Control.Exception (bracket) +import Control.Monad (when) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS -import Data.Maybe -import Data.Text (Text) +import Data.Maybe +import Data.Text (Text) import qualified Data.Text as Text -import Data.Typeable -import GHC.IO.Handle.FD (openFileBlocking) -import GHC.Stack -import Options.Applicative (ReadM) +import Data.Typeable +import GHC.IO.Handle.FD (openFileBlocking) +import GHC.Stack +import Options.Applicative (ReadM) import qualified Options.Applicative as Opt -import Options.Applicative.Builder (eitherReader) -import System.IO (IOMode (ReadMode), hClose) +import Options.Applicative.Builder (eitherReader) +import System.IO (IOMode (ReadMode), hClose) import qualified Text.Parsec as Parsec import qualified Text.Parsec.String as Parsec import qualified Text.ParserCombinators.Parsec.Error as Parsec import qualified Text.Read as Read - (?!) :: Maybe a -> e -> Either e a Nothing ?! e = Left e -Just x ?! _ = Right x +Just x ?! _ = Right x (?!.) :: Either e a -> (e -> e') -> Either e' a -Left e ?!. f = Left (f e) +Left e ?!. f = Left (f e) Right x ?!. _ = Right x {-# NOINLINE noInlineMaybeToStrictMaybe #-} @@ -71,8 +69,12 @@ noInlineMaybeToStrictMaybe (Just x) = SJust x formatParsecError :: Parsec.ParseError -> String formatParsecError err = - Parsec.showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of input" + Parsec.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of input" $ Parsec.errorMessages err runParsecParser :: Parsec.Parser a -> Text -> Aeson.Parser a @@ -96,25 +98,27 @@ parseFilePath :: String -> String -> Opt.Parser FilePath parseFilePath optname desc = Opt.strOption ( Opt.long optname - <> Opt.metavar "FILEPATH" - <> Opt.help desc - <> Opt.completer (Opt.bashCompleter "file") + <> Opt.metavar "FILEPATH" + <> Opt.help desc + <> Opt.completer (Opt.bashCompleter "file") ) readFileBlocking :: FilePath -> IO BS.ByteString -readFileBlocking path = bracket - (openFileBlocking path ReadMode) - hClose - (\fp -> do - -- An arbitrary block size. - let blockSize = 4096 - let go acc = do - next <- BS.hGet fp blockSize - if BS.null next - then pure acc - else go (acc <> Builder.byteString next) - contents <- go mempty - pure $ LBS.toStrict $ Builder.toLazyByteString contents) +readFileBlocking path = + bracket + (openFileBlocking path ReadMode) + hClose + ( \fp -> do + -- An arbitrary block size. + let blockSize = 4096 + let go acc = do + next <- BS.hGet fp blockSize + if BS.null next + then pure acc + else go (acc <> Builder.byteString next) + contents <- go mempty + pure $ LBS.toStrict $ Builder.toLazyByteString contents + ) textShow :: Show a => a -> Text textShow = Text.pack . show @@ -128,17 +132,18 @@ bounded t = eitherReader $ \s -> do -- | Aids type inference. Use this function to ensure the value is a function -- that modifies a value. -modifyWith :: () +modifyWith + :: () => (a -> a) -> (a -> a) modifyWith = id - - -- | Convert Rational to a bounded rational. Throw an exception when the rational is out of bounds. -unsafeBoundedRational :: forall r. (HasCallStack, Typeable r, BoundedRational r) - => Rational - -> r +unsafeBoundedRational + :: forall r + . (HasCallStack, Typeable r, BoundedRational r) + => Rational + -> r unsafeBoundedRational x = fromMaybe (error errMessage) $ boundRational x - where - errMessage = show (typeRep (Proxy @r)) <> " is out of bounds: " <> show x + where + errMessage = show (typeRep (Proxy @r)) <> " is out of bounds: " <> show x diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index 76caadfc05..74389e7e41 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -8,16 +8,15 @@ {-# LANGUAGE ViewPatterns #-} -- | Currency values --- module Cardano.Api.Value - ( L.Coin(..) + ( L.Coin (..) -- * Multi-asset values - , Quantity(..) - , PolicyId(..) + , Quantity (..) + , PolicyId (..) , scriptPolicyId - , AssetName(..) - , AssetId(..) + , AssetName (..) + , AssetId (..) , Value , selectAsset , valueFromList @@ -35,8 +34,8 @@ module Cardano.Api.Value , valueToLovelace -- ** Alternative nested representation - , ValueNestedRep(..) - , ValueNestedBundle(..) + , ValueNestedRep (..) + , ValueNestedBundle (..) , valueToNestedRep , valueFromNestedRep @@ -54,55 +53,54 @@ module Cardano.Api.Value , toLedgerValue -- * Data family instances - , AsType(..) - ) where - -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Case -import Cardano.Api.Error (displayError) -import Cardano.Api.HasTypeProxy + , AsType (..) + ) +where + +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eras.Case +import Cardano.Api.Error (displayError) +import Cardano.Api.HasTypeProxy import qualified Cardano.Api.Ledger.Lens as A -import Cardano.Api.Script -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseUsing -import Cardano.Api.Utils (failEitherWith) - +import Cardano.Api.Script +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseUsing +import Cardano.Api.Utils (failEitherWith) import qualified Cardano.Chain.Common as Byron import qualified Cardano.Ledger.Allegra.Core as L import qualified Cardano.Ledger.Coin as L -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Mary.TxOut as Mary (scaledMinDeposit) -import Cardano.Ledger.Mary.Value (MaryValue (..)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Mary.TxOut as Mary (scaledMinDeposit) +import Cardano.Ledger.Mary.Value (MaryValue (..)) import qualified Cardano.Ledger.Mary.Value as Mary - -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, object, parseJSON, toJSON, withObject) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, object, parseJSON, toJSON, withObject) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap -import Data.Aeson.Types (Parser, ToJSONKey) -import Data.ByteString (ByteString) +import Data.Aeson.Types (Parser, ToJSONKey) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Short as Short -import Data.Data (Data) -import Data.Function ((&)) -import Data.Group (invert) +import Data.Data (Data) +import Data.Function ((&)) +import Data.Group (invert) import qualified Data.List as List import qualified Data.Map.Merge.Strict as Map -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.String (IsString (..)) -import Data.Text (Text) +import Data.String (IsString (..)) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Lens.Micro ((%~)) +import Lens.Micro ((%~)) toByronLovelace :: L.Coin -> Maybe Byron.Lovelace toByronLovelace (L.Coin x) = - case Byron.integerToLovelace x of - Left _ -> Nothing - Right x' -> Just x' + case Byron.integerToLovelace x of + Left _ -> Nothing + Right x' -> Just x' fromByronLovelace :: Byron.Lovelace -> L.Coin fromByronLovelace = L.Coin . Byron.lovelaceToInteger @@ -110,7 +108,6 @@ fromByronLovelace = L.Coin . Byron.lovelaceToInteger fromShelleyDeltaLovelace :: L.DeltaCoin -> L.Coin fromShelleyDeltaLovelace (L.DeltaCoin d) = L.Coin d - -- ---------------------------------------------------------------------------- -- Multi asset Value -- @@ -131,60 +128,62 @@ lovelaceToQuantity (L.Coin x) = Quantity x quantityToLovelace :: Quantity -> L.Coin quantityToLovelace (Quantity x) = L.Coin x - -newtype PolicyId = PolicyId { unPolicyId :: ScriptHash } +newtype PolicyId = PolicyId {unPolicyId :: ScriptHash} deriving stock (Eq, Ord) deriving (Show, IsString, ToJSON, FromJSON) via UsingRawBytesHex PolicyId instance HasTypeProxy PolicyId where - data AsType PolicyId = AsPolicyId - proxyToAsType _ = AsPolicyId + data AsType PolicyId = AsPolicyId + proxyToAsType _ = AsPolicyId instance SerialiseAsRawBytes PolicyId where - serialiseToRawBytes (PolicyId sh) = serialiseToRawBytes sh - deserialiseFromRawBytes AsPolicyId bs = - PolicyId <$> deserialiseFromRawBytes AsScriptHash bs + serialiseToRawBytes (PolicyId sh) = serialiseToRawBytes sh + deserialiseFromRawBytes AsPolicyId bs = + PolicyId <$> deserialiseFromRawBytes AsScriptHash bs scriptPolicyId :: Script lang -> PolicyId scriptPolicyId = PolicyId . hashScript - newtype AssetName = AssetName ByteString deriving stock (Eq, Ord) deriving newtype (Show) - deriving (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving + (ToJSON, FromJSON, ToJSONKey, FromJSONKey) via UsingRawBytesHex AssetName instance IsString AssetName where - fromString s - | let bs = Text.encodeUtf8 (Text.pack s) - , BS.length bs <= 32 = AssetName (BSC.pack s) - | otherwise = error "fromString: AssetName over 32 bytes" + fromString s + | let bs = Text.encodeUtf8 (Text.pack s) + , BS.length bs <= 32 = + AssetName (BSC.pack s) + | otherwise = error "fromString: AssetName over 32 bytes" instance HasTypeProxy AssetName where - data AsType AssetName = AsAssetName - proxyToAsType _ = AsAssetName + data AsType AssetName = AsAssetName + proxyToAsType _ = AsAssetName instance SerialiseAsRawBytes AssetName where - serialiseToRawBytes (AssetName bs) = bs - deserialiseFromRawBytes AsAssetName bs - | BS.length bs <= 32 = Right (AssetName bs) - | otherwise = Left $ SerialiseAsRawBytesError $ - "Unable to deserialise AssetName (the bytestring should be no longer than 32 bytes long " <> - "which corresponds to a hex representation of 64 characters)" - - -data AssetId = AdaAssetId - | AssetId !PolicyId !AssetName + serialiseToRawBytes (AssetName bs) = bs + deserialiseFromRawBytes AsAssetName bs + | BS.length bs <= 32 = Right (AssetName bs) + | otherwise = + Left $ + SerialiseAsRawBytesError $ + "Unable to deserialise AssetName (the bytestring should be no longer than 32 bytes long " + <> "which corresponds to a hex representation of 64 characters)" + +data AssetId + = AdaAssetId + | AssetId !PolicyId !AssetName deriving (Eq, Ord, Show) - newtype Value = Value (Map AssetId Quantity) - deriving Eq + deriving (Eq) instance Show Value where - showsPrec d v = showParen (d > 10) $ - showString "valueFromList " . shows (valueToList v) + showsPrec d v = + showParen (d > 10) $ + showString "valueFromList " . shows (valueToList v) instance Semigroup Value where Value a <> Value b = Value (mergeAssetMaps a b) @@ -192,22 +191,22 @@ instance Semigroup Value where instance Monoid Value where mempty = Value Map.empty - {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs -mergeAssetMaps :: Map AssetId Quantity - -> Map AssetId Quantity - -> Map AssetId Quantity +mergeAssetMaps + :: Map AssetId Quantity + -> Map AssetId Quantity + -> Map AssetId Quantity mergeAssetMaps = - Map.merge - Map.preserveMissing - Map.preserveMissing - (Map.zipWithMaybeMatched mergeQuantity) - where - mergeQuantity :: AssetId -> Quantity -> Quantity -> Maybe Quantity - mergeQuantity _k a b = - case a <> b of - Quantity 0 -> Nothing - c -> Just c + Map.merge + Map.preserveMissing + Map.preserveMissing + (Map.zipWithMaybeMatched mergeQuantity) + where + mergeQuantity :: AssetId -> Quantity -> Quantity -> Maybe Quantity + mergeQuantity _k a b = + case a <> b of + Quantity 0 -> Nothing + c -> Just c instance ToJSON Value where toJSON = toJSON . valueToNestedRep @@ -215,24 +214,24 @@ instance ToJSON Value where instance FromJSON Value where parseJSON v = valueFromNestedRep <$> parseJSON v - selectAsset :: Value -> (AssetId -> Quantity) selectAsset (Value m) a = Map.findWithDefault mempty a m valueFromList :: [(AssetId, Quantity)] -> Value -valueFromList = Value - . Map.filter (/= 0) - . Map.fromListWith (<>) +valueFromList = + Value + . Map.filter (/= 0) + . Map.fromListWith (<>) valueToList :: Value -> [(AssetId, Quantity)] valueToList (Value m) = Map.toList m -- | This lets you write @a - b@ as @a <> negateValue b@. --- negateValue :: Value -> Value negateValue (Value m) = Value (Map.map negate m) -negateLedgerValue :: ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> L.Value (ShelleyLedgerEra era) +negateLedgerValue + :: ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> L.Value (ShelleyLedgerEra era) negateLedgerValue sbe v = caseShelleyToAllegraOrMaryEraOnwards (\_ -> v & A.adaAssetL sbe %~ L.Coin . negate . L.unCoin) @@ -256,27 +255,28 @@ coinToValue = lovelaceToValue -- jky -- -- See also 'selectLovelace' to select the L.Coin quantity from the Value, -- ignoring other assets. --- valueToLovelace :: Value -> Maybe L.Coin valueToLovelace v = - case valueToList v of - [] -> Just (L.Coin 0) - [(AdaAssetId, q)] -> Just (quantityToLovelace q) - _ -> Nothing + case valueToList v of + [] -> Just (L.Coin 0) + [(AdaAssetId, q)] -> Just (quantityToLovelace q) + _ -> Nothing toMaryValue :: Value -> MaryValue StandardCrypto toMaryValue v = - Mary.valueFromList (L.Coin lovelace) other - where - Quantity lovelace = selectAsset v AdaAssetId - other = [ (toMaryPolicyID pid, toMaryAssetName name, q) - | (AssetId pid name, Quantity q) <- valueToList v ] + Mary.valueFromList (L.Coin lovelace) other + where + Quantity lovelace = selectAsset v AdaAssetId + other = + [ (toMaryPolicyID pid, toMaryAssetName name, q) + | (AssetId pid name, Quantity q) <- valueToList v + ] - toMaryPolicyID :: PolicyId -> Mary.PolicyID StandardCrypto - toMaryPolicyID (PolicyId sh) = Mary.PolicyID (toShelleyScriptHash sh) + toMaryPolicyID :: PolicyId -> Mary.PolicyID StandardCrypto + toMaryPolicyID (PolicyId sh) = Mary.PolicyID (toShelleyScriptHash sh) - toMaryAssetName :: AssetName -> Mary.AssetName - toMaryAssetName (AssetName n) = Mary.AssetName $ Short.toShort n + toMaryAssetName :: AssetName -> Mary.AssetName + toMaryAssetName (AssetName n) = Mary.AssetName $ Short.toShort n toLedgerValue :: MaryEraOnwards era -> Value -> L.Value (ShelleyLedgerEra era) toLedgerValue w = maryEraOnwardsConstraints w toMaryValue @@ -290,18 +290,19 @@ fromLedgerValue sbe v = fromMaryValue :: MaryValue StandardCrypto -> Value fromMaryValue (MaryValue (L.Coin lovelace) other) = - Value $ - --TODO: write QC tests to show it's ok to use Map.fromAscList here - Map.fromList $ - [ (AdaAssetId, Quantity lovelace) | lovelace /= 0 ] - ++ [ (AssetId (fromMaryPolicyID pid) (fromMaryAssetName name), Quantity q) - | (pid, name, q) <- Mary.flattenMultiAsset other ] - where - fromMaryPolicyID :: Mary.PolicyID StandardCrypto -> PolicyId - fromMaryPolicyID (Mary.PolicyID sh) = PolicyId (fromShelleyScriptHash sh) - - fromMaryAssetName :: Mary.AssetName -> AssetName - fromMaryAssetName (Mary.AssetName n) = AssetName $ Short.fromShort n + Value $ + -- TODO: write QC tests to show it's ok to use Map.fromAscList here + Map.fromList $ + [(AdaAssetId, Quantity lovelace) | lovelace /= 0] + ++ [ (AssetId (fromMaryPolicyID pid) (fromMaryAssetName name), Quantity q) + | (pid, name, q) <- Mary.flattenMultiAsset other + ] + where + fromMaryPolicyID :: Mary.PolicyID StandardCrypto -> PolicyId + fromMaryPolicyID (Mary.PolicyID sh) = PolicyId (fromShelleyScriptHash sh) + + fromMaryAssetName :: Mary.AssetName -> AssetName + fromMaryAssetName (Mary.AssetName n) = AssetName $ Short.fromShort n -- | Calculate cost of making a UTxO entry for a given 'Value' and -- mininimum UTxO value derived from the 'ProtocolParameters' @@ -315,63 +316,69 @@ calcMinimumDeposit v = -- | An alternative nested representation for 'Value' that groups assets that -- share a 'PolicyId'. --- newtype ValueNestedRep = ValueNestedRep [ValueNestedBundle] deriving (Eq, Ord, Show) -- | A bundle within a 'ValueNestedRep' for a single 'PolicyId', or for the -- special case of ada. --- -data ValueNestedBundle = ValueNestedBundleAda Quantity - | ValueNestedBundle PolicyId (Map AssetName Quantity) +data ValueNestedBundle + = ValueNestedBundleAda Quantity + | ValueNestedBundle PolicyId (Map AssetName Quantity) deriving (Eq, Ord, Show) - valueToNestedRep :: Value -> ValueNestedRep valueToNestedRep v = - -- unflatten all the non-ada assets, and add ada separately - ValueNestedRep $ - [ ValueNestedBundleAda q | let q = selectAsset v AdaAssetId, q /= 0 ] - ++ [ ValueNestedBundle pId qs | (pId, qs) <- Map.toList nonAdaAssets ] - where - nonAdaAssets :: Map PolicyId (Map AssetName Quantity) - nonAdaAssets = - Map.fromListWith (Map.unionWith (<>)) - [ (pId, Map.singleton aName q) - | (AssetId pId aName, q) <- valueToList v ] + -- unflatten all the non-ada assets, and add ada separately + ValueNestedRep $ + [ValueNestedBundleAda q | let q = selectAsset v AdaAssetId, q /= 0] + ++ [ValueNestedBundle pId qs | (pId, qs) <- Map.toList nonAdaAssets] + where + nonAdaAssets :: Map PolicyId (Map AssetName Quantity) + nonAdaAssets = + Map.fromListWith + (Map.unionWith (<>)) + [ (pId, Map.singleton aName q) + | (AssetId pId aName, q) <- valueToList v + ] valueFromNestedRep :: ValueNestedRep -> Value valueFromNestedRep (ValueNestedRep bundles) = - valueFromList - [ (aId, q) - | bundle <- bundles - , (aId, q) <- case bundle of - ValueNestedBundleAda q -> [ (AdaAssetId, q) ] - ValueNestedBundle pId qs -> [ (AssetId pId aName, q) - | (aName, q) <- Map.toList qs ] - ] + valueFromList + [ (aId, q) + | bundle <- bundles + , (aId, q) <- case bundle of + ValueNestedBundleAda q -> [(AdaAssetId, q)] + ValueNestedBundle pId qs -> + [ (AssetId pId aName, q) + | (aName, q) <- Map.toList qs + ] + ] instance ToJSON ValueNestedRep where toJSON (ValueNestedRep bundles) = object $ map toPair bundles - where - toPair :: ValueNestedBundle -> (Aeson.Key, Aeson.Value) - toPair (ValueNestedBundleAda q) = ("lovelace", toJSON q) - toPair (ValueNestedBundle pid assets) = (Aeson.fromText $ renderPolicyId pid, toJSON assets) + where + toPair :: ValueNestedBundle -> (Aeson.Key, Aeson.Value) + toPair (ValueNestedBundleAda q) = ("lovelace", toJSON q) + toPair (ValueNestedBundle pid assets) = (Aeson.fromText $ renderPolicyId pid, toJSON assets) instance FromJSON ValueNestedRep where parseJSON = - withObject "ValueNestedRep" $ \obj -> - ValueNestedRep <$> sequenceA [ parsePid keyValTuple - | keyValTuple <- KeyMap.toList obj ] - where - parsePid :: (Aeson.Key, Aeson.Value) -> Parser ValueNestedBundle - parsePid ("lovelace", q) = ValueNestedBundleAda <$> parseJSON q - parsePid (Aeson.toText -> pid, quantityBundleJson) = do - sHash <- - failEitherWith - (\e -> "Failure when deserialising PolicyId: " ++ displayError e) $ - deserialiseFromRawBytesHex AsScriptHash $ Text.encodeUtf8 pid - ValueNestedBundle (PolicyId sHash) <$> parseJSON quantityBundleJson + withObject "ValueNestedRep" $ \obj -> + ValueNestedRep + <$> sequenceA + [ parsePid keyValTuple + | keyValTuple <- KeyMap.toList obj + ] + where + parsePid :: (Aeson.Key, Aeson.Value) -> Parser ValueNestedBundle + parsePid ("lovelace", q) = ValueNestedBundleAda <$> parseJSON q + parsePid (Aeson.toText -> pid, quantityBundleJson) = do + sHash <- + failEitherWith + (\e -> "Failure when deserialising PolicyId: " ++ displayError e) + $ deserialiseFromRawBytesHex AsScriptHash + $ Text.encodeUtf8 pid + ValueNestedBundle (PolicyId sHash) <$> parseJSON quantityBundleJson -- ---------------------------------------------------------------------------- -- Printing and pretty-printing @@ -390,9 +397,9 @@ renderValueSep sep v = if List.null valueList then "0 lovelace" else Text.intercalate sep (map renderAssetIdQuantityPair valueList) - where - valueList :: [(AssetId, Quantity)] - valueList = valueToList v + where + valueList :: [(AssetId, Quantity)] + valueList = valueToList v renderAssetIdQuantityPair :: (AssetId, Quantity) -> Text renderAssetIdQuantityPair (aId, quant) = diff --git a/cardano-api/internal/Cardano/Api/ValueParser.hs b/cardano-api/internal/Cardano/Api/ValueParser.hs index c6c2738818..de26cec18c 100644 --- a/cardano-api/internal/Cardano/Api/ValueParser.hs +++ b/cardano-api/internal/Cardano/Api/ValueParser.hs @@ -2,26 +2,26 @@ module Cardano.Api.ValueParser ( parseValue , assetName , policyId - ) where - -import Cardano.Api.Error (displayError) -import Cardano.Api.SerialiseRaw -import Cardano.Api.Utils (failEitherWith) -import Cardano.Api.Value - -import Control.Applicative (many, some, (<|>)) + ) +where + +import Cardano.Api.Error (displayError) +import Cardano.Api.SerialiseRaw +import Cardano.Api.Utils (failEitherWith) +import Cardano.Api.Value +import Control.Applicative (many, some, (<|>)) import qualified Data.ByteString.Char8 as BSC import qualified Data.Char as Char -import Data.Functor (void, ($>)) -import Data.List (foldl') +import Data.Functor (void, ($>)) +import Data.List (foldl') import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Word (Word64) -import Text.Parsec as Parsec (notFollowedBy, try, ()) -import Text.Parsec.Char (alphaNum, char, digit, hexDigit, space, spaces, string) -import Text.Parsec.Expr (Assoc (..), Operator (..), buildExpressionParser) -import Text.Parsec.String (Parser) -import Text.ParserCombinators.Parsec.Combinator (many1) +import Data.Word (Word64) +import Text.Parsec as Parsec (notFollowedBy, try, ()) +import Text.Parsec.Char (alphaNum, char, digit, hexDigit, space, spaces, string) +import Text.Parsec.Expr (Assoc (..), Operator (..), buildExpressionParser) +import Text.Parsec.String (Parser) +import Text.ParserCombinators.Parsec.Combinator (many1) -- | Parse a 'Value' from its string representation. parseValue :: Parser Value @@ -35,8 +35,7 @@ evalValueExpr vExpr = ValueExprNegate x -> negateValue (evalValueExpr x) ValueExprLovelace quant -> valueFromList [(AdaAssetId, quant)] ValueExprMultiAsset polId aName quant -> - valueFromList [(AssetId polId aName , quant)] - + valueFromList [(AssetId polId aName, quant)] ------------------------------------------------------------------------------ -- Expression parser @@ -52,35 +51,35 @@ data ValueExpr parseValueExpr :: Parser ValueExpr parseValueExpr = - buildExpressionParser operatorTable valueExprTerm - "multi-asset value expression" - where - operatorTable = - [ [Prefix negateOp] - , [Infix plusOp AssocLeft] - ] + buildExpressionParser operatorTable valueExprTerm + "multi-asset value expression" + where + operatorTable = + [ [Prefix negateOp] + , [Infix plusOp AssocLeft] + ] -- | Parse either a 'ValueExprLovelace' or 'ValueExprMultiAsset'. valueExprTerm :: Parser ValueExpr valueExprTerm = do - q <- try quantity "quantity (word64)" - aId <- try assetIdUnspecified <|> assetIdSpecified "asset id" - _ <- spaces - pure $ case aId of - AdaAssetId -> ValueExprLovelace q - AssetId polId aName -> ValueExprMultiAsset polId aName q - where - -- Parse an asset ID which must be lead by one or more whitespace - -- characters and may be trailed by whitespace characters. - assetIdSpecified :: Parser AssetId - assetIdSpecified = some space *> assetId - - -- Default for if an asset ID is not specified. - assetIdUnspecified :: Parser AssetId - assetIdUnspecified = - spaces - *> notFollowedBy alphaNum - $> AdaAssetId + q <- try quantity "quantity (word64)" + aId <- try assetIdUnspecified <|> assetIdSpecified "asset id" + _ <- spaces + pure $ case aId of + AdaAssetId -> ValueExprLovelace q + AssetId polId aName -> ValueExprMultiAsset polId aName q + where + -- Parse an asset ID which must be lead by one or more whitespace + -- characters and may be trailed by whitespace characters. + assetIdSpecified :: Parser AssetId + assetIdSpecified = some space *> assetId + + -- Default for if an asset ID is not specified. + assetIdUnspecified :: Parser AssetId + assetIdUnspecified = + spaces + *> notFollowedBy alphaNum + $> AdaAssetId ------------------------------------------------------------------------------ -- Primitive parsers @@ -108,16 +107,17 @@ word64 = do decimal :: Parser Integer decimal = do - digits <- many1 digit - return $! foldl' (\x d -> 10*x + toInteger (Char.digitToInt d)) 0 digits + digits <- many1 digit + return $! foldl' (\x d -> 10 * x + toInteger (Char.digitToInt d)) 0 digits -- | Asset name parser. assetName :: Parser AssetName assetName = do hexText <- many hexDigit failEitherWith - (\e -> "AssetName deserisalisation failed: " ++ displayError e) $ - deserialiseFromRawBytesHex AsAssetName $ BSC.pack hexText + (\e -> "AssetName deserisalisation failed: " ++ displayError e) + $ deserialiseFromRawBytesHex AsAssetName + $ BSC.pack hexText -- | Policy ID parser. policyId :: Parser PolicyId @@ -127,12 +127,14 @@ policyId = do ( \e -> fail $ "expecting a 56-hex-digit policy ID, but found " - ++ show (length hexText) ++ " hex digits; " ++ displayError e + ++ show (length hexText) + ++ " hex digits; " + ++ displayError e ) (textToPolicyId hexText) - where - textToPolicyId = - fmap PolicyId + where + textToPolicyId = + fmap PolicyId . deserialiseFromRawBytesHex AsScriptHash . Text.encodeUtf8 . Text.pack @@ -140,31 +142,31 @@ policyId = do -- | Asset ID parser. assetId :: Parser AssetId assetId = - try adaAssetId - <|> nonAdaAssetId - "asset ID" - where - -- Parse the ADA asset ID. - adaAssetId :: Parser AssetId - adaAssetId = string "lovelace" $> AdaAssetId - - -- Parse a multi-asset ID. - nonAdaAssetId :: Parser AssetId - nonAdaAssetId = do - polId <- policyId - fullAssetId polId <|> assetIdNoAssetName polId - - -- Parse a fully specified multi-asset ID with both a policy ID and asset - -- name. - fullAssetId :: PolicyId -> Parser AssetId - fullAssetId polId = do - _ <- period - aName <- assetName "hexadecimal asset name" - pure (AssetId polId aName) - - -- Parse a multi-asset ID that specifies a policy ID, but no asset name. - assetIdNoAssetName :: PolicyId -> Parser AssetId - assetIdNoAssetName polId = pure (AssetId polId "") + try adaAssetId + <|> nonAdaAssetId + "asset ID" + where + -- Parse the ADA asset ID. + adaAssetId :: Parser AssetId + adaAssetId = string "lovelace" $> AdaAssetId + + -- Parse a multi-asset ID. + nonAdaAssetId :: Parser AssetId + nonAdaAssetId = do + polId <- policyId + fullAssetId polId <|> assetIdNoAssetName polId + + -- Parse a fully specified multi-asset ID with both a policy ID and asset + -- name. + fullAssetId :: PolicyId -> Parser AssetId + fullAssetId polId = do + _ <- period + aName <- assetName "hexadecimal asset name" + pure (AssetId polId aName) + + -- Parse a multi-asset ID that specifies a policy ID, but no asset name. + assetIdNoAssetName :: PolicyId -> Parser AssetId + assetIdNoAssetName polId = pure (AssetId polId "") -- | Quantity (word64) parser. quantity :: Parser Quantity diff --git a/cardano-api/internal/Cardano/Api/Via/ShowOf.hs b/cardano-api/internal/Cardano/Api/Via/ShowOf.hs index bca7b3e2fe..b534d7ab1b 100644 --- a/cardano-api/internal/Cardano/Api/Via/ShowOf.hs +++ b/cardano-api/internal/Cardano/Api/Via/ShowOf.hs @@ -1,12 +1,13 @@ module Cardano.Api.Via.ShowOf - ( ShowOf(..) - ) where + ( ShowOf (..) + ) +where -import Data.Aeson +import Data.Aeson import qualified Data.Aeson.Key as Key -import Data.Aeson.Types +import Data.Aeson.Types import qualified Data.Text as Text -import Prettyprinter +import Prettyprinter newtype ShowOf a = ShowOf a diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 46f22bfcd1..996af3c6ed 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -10,1052 +10,1057 @@ -- Most simple tools should be able to work just using this interface, -- however you can go deeper and expose the types from the underlying libraries -- using "Cardano.Api.Byron" or "Cardano.Api.Shelley". --- - -module Cardano.Api ( - -- * Eras - ByronEra, - ShelleyEra, - AllegraEra, - MaryEra, - AlonzoEra, - BabbageEra, - ConwayEra, - CardanoEra(..), - IsCardanoEra(..), - AnyCardanoEra(..), - anyCardanoEra, - InAnyCardanoEra(..), - inAnyCardanoEra, - cardanoEraConstraints, - ToCardanoEra(..), +module Cardano.Api + ( -- * Eras + ByronEra + , ShelleyEra + , AllegraEra + , MaryEra + , AlonzoEra + , BabbageEra + , ConwayEra + , CardanoEra (..) + , IsCardanoEra (..) + , AnyCardanoEra (..) + , anyCardanoEra + , InAnyCardanoEra (..) + , inAnyCardanoEra + , cardanoEraConstraints + , ToCardanoEra (..) -- * Eon support - Eon(..), - EraInEon(..), - - inEonForEraMaybe, - forEraInEon, - forEraInEonMaybe, - forEraMaybeEon, - maybeEon, - monoidForEraInEon, - monoidForEraInEonA, - - - inEonForShelleyBasedEra, - inEonForShelleyBasedEraMaybe, - forShelleyBasedEraInEon, - forShelleyBasedEraInEonMaybe, - forShelleyBasedEraMaybeEon, - - Featured(..), - unFeatured, - asFeaturedInEra, - asFeaturedInShelleyBasedEra, + , Eon (..) + , EraInEon (..) + , inEonForEraMaybe + , forEraInEon + , forEraInEonMaybe + , forEraMaybeEon + , maybeEon + , monoidForEraInEon + , monoidForEraInEonA + , inEonForShelleyBasedEra + , inEonForShelleyBasedEraMaybe + , forShelleyBasedEraInEon + , forShelleyBasedEraInEonMaybe + , forShelleyBasedEraMaybeEon + , Featured (..) + , unFeatured + , asFeaturedInEra + , asFeaturedInShelleyBasedEra -- * Eons -- ** From Byron - - ByronToAlonzoEra(..), - byronToAlonzoEraConstraints, + , ByronToAlonzoEra (..) + , byronToAlonzoEraConstraints -- ** From Shelley - - ShelleyEraOnly(..), - shelleyEraOnlyConstraints, - shelleyEraOnlyToShelleyBasedEra, - - ShelleyToAllegraEra(..), - shelleyToAllegraEraConstraints, - shelleyToAllegraEraToShelleyBasedEra, - - ShelleyToMaryEra(..), - shelleyToMaryEraConstraints, - shelleyToMaryEraToShelleyBasedEra, - - ShelleyToAlonzoEra(..), - shelleyToAlonzoEraConstraints, - shelleyToAlonzoEraToShelleyBasedEra, - - ShelleyToBabbageEra(..), - shelleyToBabbageEraConstraints, - shelleyToBabbageEraToShelleyBasedEra, - - ShelleyBasedEra(..), - IsShelleyBasedEra(..), - AnyShelleyBasedEra(..), - InAnyShelleyBasedEra(..), - inAnyShelleyBasedEra, - shelleyBasedEraConstraints, + , ShelleyEraOnly (..) + , shelleyEraOnlyConstraints + , shelleyEraOnlyToShelleyBasedEra + , ShelleyToAllegraEra (..) + , shelleyToAllegraEraConstraints + , shelleyToAllegraEraToShelleyBasedEra + , ShelleyToMaryEra (..) + , shelleyToMaryEraConstraints + , shelleyToMaryEraToShelleyBasedEra + , ShelleyToAlonzoEra (..) + , shelleyToAlonzoEraConstraints + , shelleyToAlonzoEraToShelleyBasedEra + , ShelleyToBabbageEra (..) + , shelleyToBabbageEraConstraints + , shelleyToBabbageEraToShelleyBasedEra + , ShelleyBasedEra (..) + , IsShelleyBasedEra (..) + , AnyShelleyBasedEra (..) + , InAnyShelleyBasedEra (..) + , inAnyShelleyBasedEra + , shelleyBasedEraConstraints -- ** From Allegra - AllegraEraOnwards(..), + , AllegraEraOnwards (..) -- ** From Mary - MaryEraOnwards(..), - maryEraOnwardsConstraints, - maryEraOnwardsToShelleyBasedEra, + , MaryEraOnwards (..) + , maryEraOnwardsConstraints + , maryEraOnwardsToShelleyBasedEra -- ** From Alonzo - - AlonzoEraOnwards(..), - alonzoEraOnwardsConstraints, - alonzoEraOnwardsToShelleyBasedEra, + , AlonzoEraOnwards (..) + , alonzoEraOnwardsConstraints + , alonzoEraOnwardsToShelleyBasedEra -- ** From Babbage - - BabbageEraOnwards(..), - babbageEraOnwardsConstraints, - babbageEraOnwardsToShelleyBasedEra, + , BabbageEraOnwards (..) + , babbageEraOnwardsConstraints + , babbageEraOnwardsToShelleyBasedEra -- ** From Conway - - ConwayEraOnwards(..), - conwayEraOnwardsConstraints, - conwayEraOnwardsToShelleyBasedEra, + , ConwayEraOnwards (..) + , conwayEraOnwardsConstraints + , conwayEraOnwardsToShelleyBasedEra -- * Era case handling -- ** Case on CardanoEra - caseByronOrShelleyBasedEra, - caseByronToAlonzoOrBabbageEraOnwards, + , caseByronOrShelleyBasedEra + , caseByronToAlonzoOrBabbageEraOnwards -- ** Case on ShelleyBasedEra - caseShelleyEraOnlyOrAllegraEraOnwards, - caseShelleyToAllegraOrMaryEraOnwards, - caseShelleyToMaryOrAlonzoEraOnwards, - caseShelleyToAlonzoOrBabbageEraOnwards, - caseShelleyToBabbageOrConwayEraOnwards, + , caseShelleyEraOnlyOrAllegraEraOnwards + , caseShelleyToAllegraOrMaryEraOnwards + , caseShelleyToMaryOrAlonzoEraOnwards + , caseShelleyToAlonzoOrBabbageEraOnwards + , caseShelleyToBabbageOrConwayEraOnwards -- ** Eon relaxation -- *** for AlonzoEraOnly - shelleyToAlonzoEraToShelleyToBabbageEra, + , shelleyToAlonzoEraToShelleyToBabbageEra -- *** for AlonzoEraOnwards - alonzoEraOnwardsToMaryEraOnwards, + , alonzoEraOnwardsToMaryEraOnwards -- *** for BabbageEraOnwards - babbageEraOnwardsToMaryEraOnwards, - babbageEraOnwardsToAlonzoEraOnwards, + , babbageEraOnwardsToMaryEraOnwards + , babbageEraOnwardsToAlonzoEraOnwards -- *** Assertions on era - requireShelleyBasedEra, + , requireShelleyBasedEra -- ** IO - File(..), - FileDirection(..), - - mapFile, - onlyIn, - onlyOut, - intoFile, - - readByteStringFile, - readLazyByteStringFile, - readTextFile, - - writeByteStringFileWithOwnerPermissions, - writeByteStringFile, - writeByteStringOutput, - - writeLazyByteStringFileWithOwnerPermissions, - writeLazyByteStringFile, - writeLazyByteStringOutput, - - writeTextFileWithOwnerPermissions, - writeTextFile, - writeTextOutput, + , File (..) + , FileDirection (..) + , mapFile + , onlyIn + , onlyOut + , intoFile + , readByteStringFile + , readLazyByteStringFile + , readTextFile + , writeByteStringFileWithOwnerPermissions + , writeByteStringFile + , writeByteStringOutput + , writeLazyByteStringFileWithOwnerPermissions + , writeLazyByteStringFile + , writeLazyByteStringOutput + , writeTextFileWithOwnerPermissions + , writeTextFile + , writeTextOutput -- * Type tags - HasTypeProxy(..), - AsType(..), + , HasTypeProxy (..) + , AsType (..) + -- * Cryptographic key interface -- $keys - Key(..), - SigningKey(..), - VerificationKey(..), - castVerificationKey, - castSigningKey, - generateSigningKey, - generateInsecureSigningKey, + , Key (..) + , SigningKey (..) + , VerificationKey (..) + , castVerificationKey + , castSigningKey + , generateSigningKey + , generateInsecureSigningKey -- ** Hashes + -- | In Cardano most keys are identified by their hash, and hashes are -- used in many other places. - Hash, - castHash, - renderSafeHashAsHex, + , Hash + , castHash + , renderSafeHashAsHex -- * Payment addresses + -- | Constructing and inspecting normal payment addresses - Address, - ByronAddr, - ShelleyAddr, - NetworkId(..), + , Address + , ByronAddr + , ShelleyAddr + , NetworkId (..) + -- ** Byron addresses - makeByronAddress, - ByronKey, - ByronKeyLegacy, + , makeByronAddress + , ByronKey + , ByronKeyLegacy -- ** Shelley addresses - makeShelleyAddress, - PaymentCredential(..), - StakeAddressPointer(..), - StakeAddressReference(..), - PaymentKey, - PaymentExtendedKey, + , makeShelleyAddress + , PaymentCredential (..) + , StakeAddressPointer (..) + , StakeAddressReference (..) + , PaymentKey + , PaymentExtendedKey -- ** Addresses in any era - AddressAny(..), - lexPlausibleAddressString, - parseAddressAny, + , AddressAny (..) + , lexPlausibleAddressString + , parseAddressAny -- ** Addresses in specific eras - AddressInEra(..), - isKeyAddress, - AddressTypeInEra(..), - byronAddressInEra, - shelleyAddressInEra, - anyAddressInShelleyBasedEra, - anyAddressInEra, - toAddressAny, - makeByronAddressInEra, - makeShelleyAddressInEra, + , AddressInEra (..) + , isKeyAddress + , AddressTypeInEra (..) + , byronAddressInEra + , shelleyAddressInEra + , anyAddressInShelleyBasedEra + , anyAddressInEra + , toAddressAny + , makeByronAddressInEra + , makeShelleyAddressInEra -- * Stake addresses + -- | Constructing and inspecting stake addresses - StakeAddress, - StakeCredential, - makeStakeAddress, - stakeAddressCredential, - StakeKey, - StakeExtendedKey, + , StakeAddress + , StakeCredential + , makeStakeAddress + , stakeAddressCredential + , StakeKey + , StakeExtendedKey -- ** Multi-asset values - Quantity(..), - PolicyId(..), - scriptPolicyId, - AssetName(..), - AssetId(..), - Value, - parseValue, - policyId, - selectAsset, - valueFromList, - valueToList, - filterValue, - negateValue, - ValueNestedRep(..), - ValueNestedBundle(..), - valueToNestedRep, - valueFromNestedRep, - renderValue, - renderValuePretty, - toLedgerValue, - fromLedgerValue, + , Quantity (..) + , PolicyId (..) + , scriptPolicyId + , AssetName (..) + , AssetId (..) + , Value + , parseValue + , policyId + , selectAsset + , valueFromList + , valueToList + , filterValue + , negateValue + , ValueNestedRep (..) + , ValueNestedBundle (..) + , valueToNestedRep + , valueFromNestedRep + , renderValue + , renderValuePretty + , toLedgerValue + , fromLedgerValue -- ** Ada \/ Lovelace within multi-asset values - quantityToLovelace, - lovelaceToQuantity, - selectLovelace, - lovelaceToValue, - valueToLovelace, + , quantityToLovelace + , lovelaceToQuantity + , selectLovelace + , lovelaceToValue + , valueToLovelace -- * Blocks -- ** Blocks in the context of an era - Block(..), - pattern Block, - BlockHeader(..), - getBlockHeader, + , Block (..) + , pattern Block + , BlockHeader (..) + , getBlockHeader -- ** Points on the chain - ChainPoint(..), - EpochNo(..), + , ChainPoint (..) + , EpochNo (..) -- ** Tip of the chain - ChainTip(..), - BlockNo(..), - chainTipToChainPoint, + , ChainTip (..) + , BlockNo (..) + , chainTipToChainPoint -- * Building transactions -- * Building transactions + -- | Constructing and inspecting transactions -- ** Transaction bodies - TxBody(..), - createAndValidateTransactionBody, - makeByronTransactionBody, - TxBodyContent(..), - getTxBodyContent, + , TxBody (..) + , createAndValidateTransactionBody + , makeByronTransactionBody + , TxBodyContent (..) + , getTxBodyContent -- ** Transaction body builders - defaultTxBodyContent, - defaultTxFee, - defaultTxValidityUpperBound, - setTxIns, - modTxIns, - addTxIn, - setTxInsCollateral, - setTxInsReference, - setTxOuts, - modTxOuts, - addTxOut, - setTxTotalCollateral, - setTxReturnCollateral, - setTxFee, - setTxValidityLowerBound, - setTxValidityUpperBound, - setTxMetadata, - setTxAuxScripts, - setTxExtraKeyWits, - setTxProtocolParams, - setTxWithdrawals, - setTxCertificates, - setTxUpdateProposal, - setTxMintValue, - setTxScriptValidity, - setTxCurrentTreasuryValue, - setTxTreasuryDonation, - TxBodyError(..), - TxBodyScriptData(..), + , defaultTxBodyContent + , defaultTxFee + , defaultTxValidityUpperBound + , setTxIns + , modTxIns + , addTxIn + , setTxInsCollateral + , setTxInsReference + , setTxOuts + , modTxOuts + , addTxOut + , setTxTotalCollateral + , setTxReturnCollateral + , setTxFee + , setTxValidityLowerBound + , setTxValidityUpperBound + , setTxMetadata + , setTxAuxScripts + , setTxExtraKeyWits + , setTxProtocolParams + , setTxWithdrawals + , setTxCertificates + , setTxUpdateProposal + , setTxMintValue + , setTxScriptValidity + , setTxCurrentTreasuryValue + , setTxTreasuryDonation + , TxBodyError (..) + , TxBodyScriptData (..) -- ** Transaction Ids - TxId(..), - getTxId, - getTxIdByron, + , TxId (..) + , getTxId + , getTxIdByron -- ** Transaction inputs - TxIn(TxIn), - TxIns, - TxIx(TxIx), - renderTxIn, - getReferenceInputsSizeForTxIds, + , TxIn (TxIn) + , TxIns + , TxIx (TxIx) + , renderTxIn + , getReferenceInputsSizeForTxIds -- ** Transaction outputs - CtxTx, CtxUTxO, - TxOut(TxOut), - TxOutValue(..), - TxOutInAnyEra(..), - txOutInAnyEra, - txOutValueToLovelace, - txOutValueToValue, - lovelaceToTxOutValue, - TxOutDatum(..), - parseHash, + , CtxTx + , CtxUTxO + , TxOut (TxOut) + , TxOutValue (..) + , TxOutInAnyEra (..) + , txOutInAnyEra + , txOutValueToLovelace + , txOutValueToValue + , lovelaceToTxOutValue + , TxOutDatum (..) + , parseHash -- ** Other transaction body types - TxInsCollateral(..), - TxInsReference(..), - TxTotalCollateral(..), - TxReturnCollateral(..), - TxFee(..), - TxValidityLowerBound(..), - TxValidityUpperBound(..), - SlotNo(..), - EpochSlots(..), - TxMetadataInEra(..), - TxAuxScripts(..), - TxExtraKeyWitnesses(..), - TxWithdrawals(..), - TxCertificates(..), - TxUpdateProposal(..), - TxMintValue(..), - TxVotingProcedures(..), - TxProposalProcedures(..), + , TxInsCollateral (..) + , TxInsReference (..) + , TxTotalCollateral (..) + , TxReturnCollateral (..) + , TxFee (..) + , TxValidityLowerBound (..) + , TxValidityUpperBound (..) + , SlotNo (..) + , EpochSlots (..) + , TxMetadataInEra (..) + , TxAuxScripts (..) + , TxExtraKeyWitnesses (..) + , TxWithdrawals (..) + , TxCertificates (..) + , TxUpdateProposal (..) + , TxMintValue (..) + , TxVotingProcedures (..) + , TxProposalProcedures (..) -- ** Building vs viewing transactions - BuildTxWith(..), - BuildTx, - ViewTx, + , BuildTxWith (..) + , BuildTx + , ViewTx -- ** Fee calculation - LedgerEpochInfo(..), - toLedgerEpochInfo, - evaluateTransactionFee, - calculateMinTxFee, - estimateTransactionKeyWitnessCount, + , LedgerEpochInfo (..) + , toLedgerEpochInfo + , evaluateTransactionFee + , calculateMinTxFee + , estimateTransactionKeyWitnessCount -- ** Minimum required UTxO calculation - calculateMinimumUTxO, + , calculateMinimumUTxO -- ** Script execution units - evaluateTransactionExecutionUnits, - ScriptExecutionError(..), - TransactionValidityError(..), + , evaluateTransactionExecutionUnits + , ScriptExecutionError (..) + , TransactionValidityError (..) -- ** Transaction balance - evaluateTransactionBalance, + , evaluateTransactionBalance -- ** Building transactions with automated fees and balancing - estimateBalancedTxBody, - estimateOrCalculateBalancedTxBody, - makeTransactionBodyAutoBalance, - AutoBalanceError(..), - BalancedTxBody(..), - FeeEstimationMode(..), - RequiredShelleyKeyWitnesses(..), - RequiredByronKeyWitnesses(..), - TotalReferenceScriptsSize(..), - TxFeeEstimationError(..), - TxBodyErrorAutoBalance(..), - TxScriptValidity(..), - ScriptValidity(..), - txScriptValidityToScriptValidity, + , estimateBalancedTxBody + , estimateOrCalculateBalancedTxBody + , makeTransactionBodyAutoBalance + , AutoBalanceError (..) + , BalancedTxBody (..) + , FeeEstimationMode (..) + , RequiredShelleyKeyWitnesses (..) + , RequiredByronKeyWitnesses (..) + , TotalReferenceScriptsSize (..) + , TxFeeEstimationError (..) + , TxBodyErrorAutoBalance (..) + , TxScriptValidity (..) + , ScriptValidity (..) + , txScriptValidityToScriptValidity -- * Signing transactions + -- | Creating transaction witnesses one by one, or all in one go. - Tx(Tx), - getTxBody, - getTxWitnesses, + , Tx (Tx) + , getTxBody + , getTxWitnesses -- ** Signing in one go - signByronTransaction, - signShelleyTransaction, + , signByronTransaction + , signShelleyTransaction -- ** Incremental signing and separate witnesses - makeSignedByronTransaction, - makeSignedTransaction, - KeyWitness, - makeByronKeyWitness, - ShelleyWitnessSigningKey(..), - makeShelleyKeyWitness, - makeShelleyBootstrapWitness, + , makeSignedByronTransaction + , makeSignedTransaction + , KeyWitness + , makeByronKeyWitness + , ShelleyWitnessSigningKey (..) + , makeShelleyKeyWitness + , makeShelleyBootstrapWitness -- * Transaction metadata + -- | Embedding additional structured data within transactions. - TxMetadata(..), - AsTxMetadata(..), + , TxMetadata (..) + , AsTxMetadata (..) -- ** Constructing metadata - TxMetadataValue(..), - makeTransactionMetadata, - mergeTransactionMetadata, - metaTextChunks, - metaBytesChunks, + , TxMetadataValue (..) + , makeTransactionMetadata + , mergeTransactionMetadata + , metaTextChunks + , metaBytesChunks -- ** Validating metadata - validateTxMetadata, - TxMetadataRangeError (..), + , validateTxMetadata + , TxMetadataRangeError (..) -- ** Conversion to\/from JSON - TxMetadataJsonSchema (..), - metadataFromJson, - metadataToJson, - metadataValueToJsonNoSchema, - TxMetadataJsonError (..), - TxMetadataJsonSchemaError (..), + , TxMetadataJsonSchema (..) + , metadataFromJson + , metadataToJson + , metadataValueToJsonNoSchema + , TxMetadataJsonError (..) + , TxMetadataJsonSchemaError (..) -- * Certificates - Certificate(..), + , Certificate (..) -- ** Registering stake address and delegating + -- | Certificates that are embedded in transactions for registering and -- unregistering stake address, and for setting the stake pool delegation -- choice for a stake address. - StakeAddressRequirements(..), - StakeDelegationRequirements(..), - makeStakeAddressDelegationCertificate, - makeStakeAddressRegistrationCertificate, - makeStakeAddressUnregistrationCertificate, - - makeStakeAddressAndDRepDelegationCertificate, + , StakeAddressRequirements (..) + , StakeDelegationRequirements (..) + , makeStakeAddressDelegationCertificate + , makeStakeAddressRegistrationCertificate + , makeStakeAddressUnregistrationCertificate + , makeStakeAddressAndDRepDelegationCertificate -- ** Registering stake pools + -- | Certificates that are embedded in transactions for registering and -- retiring stake pools. This includes updating the stake pool parameters. - StakePoolRegistrationRequirements(..), - StakePoolRetirementRequirements(..), - makeStakePoolRegistrationCertificate, - makeStakePoolRetirementCertificate, - StakePoolParameters, - StakePoolRelay, - StakePoolMetadataReference, + , StakePoolRegistrationRequirements (..) + , StakePoolRetirementRequirements (..) + , makeStakePoolRegistrationCertificate + , makeStakePoolRetirementCertificate + , StakePoolParameters + , StakePoolRelay + , StakePoolMetadataReference -- * Rewards - DelegationsAndRewards(..), - mergeDelegsAndRewards, + , DelegationsAndRewards (..) + , mergeDelegsAndRewards -- * Stake pool off-chain metadata - StakePoolMetadata, - validateAndHashStakePoolMetadata, - StakePoolMetadataValidationError(..), + , StakePoolMetadata + , validateAndHashStakePoolMetadata + , StakePoolMetadataValidationError (..) -- * Scripts + -- | Both 'PaymentCredential's and 'StakeCredential's can use scripts. -- ** Script languages - SimpleScript', - PlutusScriptV1, - PlutusScriptV2, - PlutusScriptV3, - ScriptLanguage(..), - PlutusScriptVersion(..), - AnyScriptLanguage(..), - AnyPlutusScriptVersion(..), - IsPlutusScriptLanguage(..), - IsScriptLanguage(..), + , SimpleScript' + , PlutusScriptV1 + , PlutusScriptV2 + , PlutusScriptV3 + , ScriptLanguage (..) + , PlutusScriptVersion (..) + , AnyScriptLanguage (..) + , AnyPlutusScriptVersion (..) + , IsPlutusScriptLanguage (..) + , IsScriptLanguage (..) -- ** Scripts in a specific language - Script(..), + , Script (..) -- ** Scripts in any language - ScriptInAnyLang(..), - toScriptInAnyLang, + , ScriptInAnyLang (..) + , toScriptInAnyLang -- ** Scripts in a specific era - ScriptInEra(..), - toScriptInEra, - eraOfScriptInEra, + , ScriptInEra (..) + , toScriptInEra + , eraOfScriptInEra -- ** Use of a script in an era as a witness - WitCtxTxIn, WitCtxMint, WitCtxStake, - WitCtx(..), - ScriptWitness(..), - Witness(..), - KeyWitnessInCtx(..), - ScriptWitnessInCtx(..), - IsScriptWitnessInCtx(..), - ScriptDatum(..), - ScriptRedeemer, - scriptWitnessScript, + , WitCtxTxIn + , WitCtxMint + , WitCtxStake + , WitCtx (..) + , ScriptWitness (..) + , Witness (..) + , KeyWitnessInCtx (..) + , ScriptWitnessInCtx (..) + , IsScriptWitnessInCtx (..) + , ScriptDatum (..) + , ScriptRedeemer + , scriptWitnessScript -- ** Inspecting 'ScriptWitness'es - AnyScriptWitness(..), - ScriptWitnessIndex(..), - renderScriptWitnessIndex, - collectTxBodyScriptWitnesses, - mapTxScriptWitnesses, + , AnyScriptWitness (..) + , ScriptWitnessIndex (..) + , renderScriptWitnessIndex + , collectTxBodyScriptWitnesses + , mapTxScriptWitnesses -- ** Languages supported in each era - ScriptLanguageInEra(..), - scriptLanguageSupportedInEra, - languageOfScriptLanguageInEra, - eraOfScriptLanguageInEra, + , ScriptLanguageInEra (..) + , scriptLanguageSupportedInEra + , languageOfScriptLanguageInEra + , eraOfScriptLanguageInEra -- ** Simple scripts + -- | Making multi-signature and time-lock scripts. - SimpleScript(..), + , SimpleScript (..) -- ** Plutus scripts - PlutusScript, - examplePlutusScriptAlwaysSucceeds, - examplePlutusScriptAlwaysFails, + , PlutusScript + , examplePlutusScriptAlwaysSucceeds + , examplePlutusScriptAlwaysFails -- ** Script data - HashableScriptData, - hashScriptDataBytes, - getOriginalScriptDataBytes, - getScriptData, - unsafeHashableScriptData, - ScriptData(..), + , HashableScriptData + , hashScriptDataBytes + , getOriginalScriptDataBytes + , getScriptData + , unsafeHashableScriptData + , ScriptData (..) -- ** Validation - ScriptDataRangeError (..), - validateScriptData, + , ScriptDataRangeError (..) + , validateScriptData -- ** Conversion to\/from JSON - ScriptDataJsonSchema (..), - scriptDataFromJson, - scriptDataToJson, - ScriptDataJsonError (..), - ScriptDataJsonSchemaError (..), - ScriptDataJsonBytesError(..), - scriptDataJsonToHashable, + , ScriptDataJsonSchema (..) + , scriptDataFromJson + , scriptDataToJson + , ScriptDataJsonError (..) + , ScriptDataJsonSchemaError (..) + , ScriptDataJsonBytesError (..) + , scriptDataJsonToHashable -- ** Script execution units - ExecutionUnits(..), - ExecutionUnitPrices(..), - CostModel(..), - toAlonzoCostModel, - fromAlonzoCostModel, - toAlonzoCostModels, + , ExecutionUnits (..) + , ExecutionUnitPrices (..) + , CostModel (..) + , toAlonzoCostModel + , fromAlonzoCostModel + , toAlonzoCostModels -- ** Script addresses + -- | Making addresses from scripts. - ScriptHash(..), - hashScript, + , ScriptHash (..) + , hashScript -- * Serialisation + -- | Support for serialising data in JSON, CBOR and text files. - InputFormat (..), - InputDecodeError (..), - deserialiseInput, - deserialiseInputAnyOf, - renderInputDecodeError, - - SomeAddressVerificationKey(..), - deserialiseAnyVerificationKey, - deserialiseAnyVerificationKeyBech32, - deserialiseAnyVerificationKeyTextEnvelope, - renderSomeAddressVerificationKey, - mapSomeAddressVerificationKey, + , InputFormat (..) + , InputDecodeError (..) + , deserialiseInput + , deserialiseInputAnyOf + , renderInputDecodeError + , SomeAddressVerificationKey (..) + , deserialiseAnyVerificationKey + , deserialiseAnyVerificationKeyBech32 + , deserialiseAnyVerificationKeyTextEnvelope + , renderSomeAddressVerificationKey + , mapSomeAddressVerificationKey -- ** CBOR - SerialiseAsCBOR, - ToCBOR, - FromCBOR, - serialiseToCBOR, - deserialiseFromCBOR, + , SerialiseAsCBOR + , ToCBOR + , FromCBOR + , serialiseToCBOR + , deserialiseFromCBOR -- ** JSON - ToJSON, - FromJSON, - serialiseToJSON, - deserialiseFromJSON, - JsonDecodeError(..), - readFileJSON, - writeFileJSON, - prettyPrintJSON, + , ToJSON + , FromJSON + , serialiseToJSON + , deserialiseFromJSON + , JsonDecodeError (..) + , readFileJSON + , writeFileJSON + , prettyPrintJSON -- ** Bech32 - SerialiseAsBech32, - serialiseToBech32, - deserialiseFromBech32, - deserialiseAnyOfFromBech32, - Bech32DecodeError(..), - UsingBech32(..), + , SerialiseAsBech32 + , serialiseToBech32 + , deserialiseFromBech32 + , deserialiseAnyOfFromBech32 + , Bech32DecodeError (..) + , UsingBech32 (..) -- ** Addresses + -- | Address serialisation is (sadly) special - SerialiseAddress, - serialiseAddress, - deserialiseAddress, + , SerialiseAddress + , serialiseAddress + , deserialiseAddress -- ** Raw binary + -- | Some types have a natural raw binary format. - SerialiseAsRawBytes, - serialiseToRawBytes, - deserialiseFromRawBytes, - SerialiseAsRawBytesError(..), - serialiseToRawBytesHex, - deserialiseFromRawBytesHex, - serialiseToRawBytesHexText, - RawBytesHexError(..), - UsingRawBytes(..), - UsingRawBytesHex(..), + , SerialiseAsRawBytes + , serialiseToRawBytes + , deserialiseFromRawBytes + , SerialiseAsRawBytesError (..) + , serialiseToRawBytesHex + , deserialiseFromRawBytesHex + , serialiseToRawBytesHexText + , RawBytesHexError (..) + , UsingRawBytes (..) + , UsingRawBytesHex (..) -- ** Text envelope + -- | Support for a envelope file format with text headers and a hex-encoded -- binary payload. - HasTextEnvelope(..), - TextEnvelope(..), - TextEnvelopeType(..), - TextEnvelopeDescr, - TextEnvelopeError(..), - textEnvelopeTypeInEra, - textEnvelopeRawCBOR, - textEnvelopeToJSON, - serialiseToTextEnvelope, - deserialiseFromTextEnvelope, - readFileTextEnvelope, - writeFileTextEnvelope, - readTextEnvelopeFromFile, - readTextEnvelopeOfTypeFromFile, + , HasTextEnvelope (..) + , TextEnvelope (..) + , TextEnvelopeType (..) + , TextEnvelopeDescr + , TextEnvelopeError (..) + , textEnvelopeTypeInEra + , textEnvelopeRawCBOR + , textEnvelopeToJSON + , serialiseToTextEnvelope + , deserialiseFromTextEnvelope + , readFileTextEnvelope + , writeFileTextEnvelope + , readTextEnvelopeFromFile + , readTextEnvelopeOfTypeFromFile -- ** Text envelope CDDL + -- | Support for serialising values in the ledger's CDDL format. -- Note, this will be deprecated in the future in favour of a -- single API. - FromSomeTypeCDDL(..), - readFileTextEnvelopeCddlAnyOf, - deserialiseFromTextEnvelopeCddlAnyOf, - writeTxFileTextEnvelopeCddl, - writeTxWitnessFileTextEnvelopeCddl, - serialiseTxLedgerCddl, - deserialiseTxLedgerCddl, - deserialiseByronTxCddl, - serialiseWitnessLedgerCddl, - deserialiseWitnessLedgerCddl, - TextEnvelopeCddlError(..), + , FromSomeTypeCDDL (..) + , readFileTextEnvelopeCddlAnyOf + , deserialiseFromTextEnvelopeCddlAnyOf + , writeTxFileTextEnvelopeCddl + , writeTxWitnessFileTextEnvelopeCddl + , serialiseTxLedgerCddl + , deserialiseTxLedgerCddl + , deserialiseByronTxCddl + , serialiseWitnessLedgerCddl + , deserialiseWitnessLedgerCddl + , TextEnvelopeCddlError (..) -- *** Reading one of several key types - readKeyFile, - readKeyFileTextEnvelope, - readKeyFileAnyOf, + , readKeyFile + , readKeyFileTextEnvelope + , readKeyFileAnyOf -- *** Read one of several types - FromSomeType(..), - deserialiseFromTextEnvelopeAnyOf, - readFileTextEnvelopeAnyOf, - - + , FromSomeType (..) + , deserialiseFromTextEnvelopeAnyOf + , readFileTextEnvelopeAnyOf -- * Errors - Error(..), - throwErrorAsException, - FileError(..), + , Error (..) + , throwErrorAsException + , FileError (..) -- * Node interaction + -- | Operations that involve talking to a local Cardano node. -- ** Node Config - NodeConfig (..), - NodeConfigFile, - readNodeConfig, + , NodeConfig (..) + , NodeConfigFile + , readNodeConfig + -- ** Genesis Files - ByronGenesisFile, - ShelleyGenesisFile, - AlonzoGenesisFile, - ConwayGenesisFile, + , ByronGenesisFile + , ShelleyGenesisFile + , AlonzoGenesisFile + , ConwayGenesisFile + -- *** Genesis Config - GenesisConfig (..), - readCardanoGenesisConfig, - mkProtocolInfoCardano, + , GenesisConfig (..) + , readCardanoGenesisConfig + , mkProtocolInfoCardano + -- **** Byron Genesis Config - readByronGenesisConfig, + , readByronGenesisConfig + -- **** Shelley Genesis Config - ShelleyConfig (..), - GenesisHashShelley (..), - readShelleyGenesisConfig, - shelleyPraosNonce, + , ShelleyConfig (..) + , GenesisHashShelley (..) + , readShelleyGenesisConfig + , shelleyPraosNonce + -- **** Alonzo Genesis Config - GenesisHashAlonzo (..), - readAlonzoGenesisConfig, + , GenesisHashAlonzo (..) + , readAlonzoGenesisConfig + -- **** Conway Genesis Config - GenesisHashConway (..), - readConwayGenesisConfig, + , GenesisHashConway (..) + , readConwayGenesisConfig + -- *** Environment - Env(..), - genesisConfigToEnv, + , Env (..) + , genesisConfigToEnv -- ** Queries + -- ** Submitting transactions -- ** High level protocol interaction with a Cardano node + -- *** Initialization / Accumulation - envSecurityParam, - LedgerState(..), - initialLedgerState, - encodeLedgerState, - decodeLedgerState, - applyBlock, - ValidationMode(..), + , envSecurityParam + , LedgerState (..) + , initialLedgerState + , encodeLedgerState + , decodeLedgerState + , applyBlock + , ValidationMode (..) -- *** Traversing the block chain - foldBlocks, - FoldStatus(..), - chainSyncClientWithLedgerState, - chainSyncClientPipelinedWithLedgerState, + , foldBlocks + , FoldStatus (..) + , chainSyncClientWithLedgerState + , chainSyncClientPipelinedWithLedgerState -- *** Ledger state conditions - ConditionResult(..), - fromConditionResult, - toConditionResult, - AnyNewEpochState(..), - foldEpochState, - getAnyNewEpochState, + , ConditionResult (..) + , fromConditionResult + , toConditionResult + , AnyNewEpochState (..) + , foldEpochState + , getAnyNewEpochState -- *** Errors - LedgerStateError(..), - FoldBlocksError(..), - GenesisConfigError(..), - InitialLedgerStateError(..), + , LedgerStateError (..) + , FoldBlocksError (..) + , GenesisConfigError (..) + , InitialLedgerStateError (..) -- ** Low level protocol interaction with a Cardano node - connectToLocalNode, - connectToLocalNodeWithVersion, - LocalNodeConnectInfo(..), - ConsensusModeParams(..), - ConsensusProtocol, - ChainDepStateProtocol, - ConsensusBlockForEra, - LocalNodeClientProtocols(..), - LocalNodeClientParams(..), - mkLocalNodeClientParams, - LocalChainSyncClient(..), - -- connectToRemoteNode, + , connectToLocalNode + , connectToLocalNodeWithVersion + , LocalNodeConnectInfo (..) + , ConsensusModeParams (..) + , ConsensusProtocol + , ChainDepStateProtocol + , ConsensusBlockForEra + , LocalNodeClientProtocols (..) + , LocalNodeClientParams (..) + , mkLocalNodeClientParams + , LocalChainSyncClient (..) + -- connectToRemoteNode, -- ** Protocol related types - BlockType(..), - SomeBlockType (..), - reflBlockType, - Protocol(..), - ProtocolInfoArgs(..), - + , BlockType (..) + , SomeBlockType (..) + , reflBlockType + , Protocol (..) + , ProtocolInfoArgs (..) -- *** Chain sync protocol + -- | To construct a @ChainSyncClient@ see @Cardano.Api.Client@ or -- @Cardano.Api.ClientPipelined@. - ChainSyncClient(..), - ChainSyncClientPipelined(..), - BlockInMode(..), - LocalNodeClientProtocolsInMode, + , ChainSyncClient (..) + , ChainSyncClientPipelined (..) + , BlockInMode (..) + , LocalNodeClientProtocolsInMode -- *** Local tx submission - LocalTxSubmissionClient(..), - TxInMode(..), - TxValidationErrorInCardanoMode(..), - SubmitResult(..), - submitTxToNodeLocal, + , LocalTxSubmissionClient (..) + , TxInMode (..) + , TxValidationErrorInCardanoMode (..) + , SubmitResult (..) + , submitTxToNodeLocal -- *** Local state query - LocalStateQueryClient(..), - QueryInMode(..), - SystemStart(..), - QueryInEra(..), - QueryInShelleyBasedEra(..), - QueryUTxOFilter(..), - UTxO(..), - queryNodeLocalState, - executeQueryCardanoMode, - UnsupportedNtcVersionError(..), + , LocalStateQueryClient (..) + , QueryInMode (..) + , SystemStart (..) + , QueryInEra (..) + , QueryInShelleyBasedEra (..) + , QueryUTxOFilter (..) + , UTxO (..) + , queryNodeLocalState + , executeQueryCardanoMode + , UnsupportedNtcVersionError (..) -- *** Local tx monitoring - LocalTxMonitorClient(..), - LocalTxMonitoringQuery(..), - LocalTxMonitoringResult(..), - MempoolSizeAndCapacity(..), - queryTxMonitoringLocal, - - TxIdInMode(..), - - EraHistory(..), - getProgress, - getSlotForRelativeTime, + , LocalTxMonitorClient (..) + , LocalTxMonitoringQuery (..) + , LocalTxMonitoringResult (..) + , MempoolSizeAndCapacity (..) + , queryTxMonitoringLocal + , TxIdInMode (..) + , EraHistory (..) + , getProgress + , getSlotForRelativeTime -- *** Common queries - determineEra, - getLocalChainTip, + , determineEra + , getLocalChainTip -- * Node operation + -- | Support for the steps needed to operate a node -- ** Operational certificates - OperationalCertificate, - OperationalCertificateIssueCounter, - OperationalCertIssueError, - getHotKey, - getKesPeriod, - getOpCertCount, - issueOperationalCertificate, + , OperationalCertificate + , OperationalCertificateIssueCounter + , OperationalCertIssueError + , getHotKey + , getKesPeriod + , getOpCertCount + , issueOperationalCertificate -- * Constitutional Committee keys - CommitteeColdKey, - CommitteeColdExtendedKey, - CommitteeHotKey, - CommitteeHotExtendedKey, + , CommitteeColdKey + , CommitteeColdExtendedKey + , CommitteeHotKey + , CommitteeHotExtendedKey -- * Genesis file + -- | Types and functions needed to inspect or create a genesis file. - GenesisKey, - GenesisExtendedKey, - GenesisDelegateKey, - GenesisDelegateExtendedKey, - GenesisUTxOKey, - genesisUTxOPseudoTxIn, + , GenesisKey + , GenesisExtendedKey + , GenesisDelegateKey + , GenesisDelegateExtendedKey + , GenesisUTxOKey + , genesisUTxOPseudoTxIn -- ** Genesis parameters - GenesisParameters(..), + , GenesisParameters (..) -- * Special transactions + -- | There are various additional things that can be embedded in a -- transaction for special operations. - GenesisKeyDelegationRequirements(..), - MirCertificateRequirements(..), - makeMIRCertificate, - makeGenesisKeyDelegationCertificate, - MIRTarget (..), - MIRPot(..), - selectStakeCredentialWitness, + , GenesisKeyDelegationRequirements (..) + , MirCertificateRequirements (..) + , makeMIRCertificate + , makeGenesisKeyDelegationCertificate + , MIRTarget (..) + , MIRPot (..) + , selectStakeCredentialWitness -- * Protocol parameter updates - UpdateProposal(..), - ProtocolParametersUpdate(..), - makeShelleyUpdateProposal, - PraosNonce, - makePraosNonce, - - NetworkMagic(..), + , UpdateProposal (..) + , ProtocolParametersUpdate (..) + , makeShelleyUpdateProposal + , PraosNonce + , makePraosNonce + , NetworkMagic (..) -- * Protocol parameters - ProtocolParametersConversionError(..), + , ProtocolParametersConversionError (..) -- ** Conversions - toLedgerPParams, - fromLedgerPParams, - toCtxUTxOTxOut, - --TODO: arrange not to export these - fromNetworkMagic, - toNetworkMagic, - fromLedgerTxOuts, - toLedgerUTxO, - runParsecParser, - - SlotsInEpoch(..), - SlotsToEpochEnd(..), - slotToEpoch, + , toLedgerPParams + , fromLedgerPParams + , toCtxUTxOTxOut + -- TODO: arrange not to export these + , fromNetworkMagic + , toNetworkMagic + , fromLedgerTxOuts + , toLedgerUTxO + , runParsecParser + , SlotsInEpoch (..) + , SlotsToEpochEnd (..) + , slotToEpoch -- * Node socket related - SocketPath, + , SocketPath + , NodeToClientVersion (..) - NodeToClientVersion(..), -- ** Queries - executeQueryAnyMode, + , executeQueryAnyMode -- ** Monadic queries - LocalStateQueryExpr, - executeLocalStateQueryExpr, - queryExpr, - - chainPointToSlotNo, - chainPointToHeaderHash, - makeChainTip, - parseFilePath, - writeSecrets, + , LocalStateQueryExpr + , executeLocalStateQueryExpr + , queryExpr + , chainPointToSlotNo + , chainPointToHeaderHash + , makeChainTip + , parseFilePath + , writeSecrets -- * Convenience functions -- ** Transaction construction - constructBalancedTx, + , constructBalancedTx -- ** Queries - QueryConvenienceError(..), - TxCurrentTreasuryValue(..), - queryStateForBalancedTx, - renderQueryConvenienceError, + , QueryConvenienceError (..) + , TxCurrentTreasuryValue (..) + , queryStateForBalancedTx + , renderQueryConvenienceError -- ** Misc - ScriptLockedTxInsError(..), - TxInsExistError(..), - renderNotScriptLockedTxInsError, - renderTxInsExistError, - txInsExistInUTxO, - notScriptLockedTxIns, - textShow, + , ScriptLockedTxInsError (..) + , TxInsExistError (..) + , renderNotScriptLockedTxInsError + , renderTxInsExistError + , txInsExistInUTxO + , notScriptLockedTxIns + , textShow -- ** CLI option parsing - bounded, + , bounded -- ** Query expressions - queryChainBlockNo, - queryChainPoint, - queryCurrentEpochState, - queryCurrentEra, - queryDebugLedgerState, - queryEpoch, - queryConstitutionHash, - queryEraHistory, - queryGenesisParameters, - queryPoolDistribution, - queryPoolState, - queryProtocolParameters, - queryProtocolParametersUpdate, - queryProtocolState, - queryStakeAddresses, - queryStakeDelegDeposits, - queryStakeDistribution, - queryStakePoolParameters, - queryStakePools, - queryStakeSnapshot, - querySystemStart, - queryUtxo, - queryConstitution, - queryGovState, - queryDRepState, - queryDRepStakeDistribution, - queryCommitteeMembersState, - queryStakeVoteDelegatees, + , queryChainBlockNo + , queryChainPoint + , queryCurrentEpochState + , queryCurrentEra + , queryDebugLedgerState + , queryEpoch + , queryConstitutionHash + , queryEraHistory + , queryGenesisParameters + , queryPoolDistribution + , queryPoolState + , queryProtocolParameters + , queryProtocolParametersUpdate + , queryProtocolState + , queryStakeAddresses + , queryStakeDelegDeposits + , queryStakeDistribution + , queryStakePoolParameters + , queryStakePools + , queryStakeSnapshot + , querySystemStart + , queryUtxo + , queryConstitution + , queryGovState + , queryDRepState + , queryDRepStakeDistribution + , queryCommitteeMembersState + , queryStakeVoteDelegatees -- ** Committee State Query - MemberStatus (..), - CommitteeMembersState (..), + , MemberStatus (..) + , CommitteeMembersState (..) + -- ** DReps - DRepKey, - DRepExtendedKey, - DRepMetadata, - DRepMetadataReference, - hashDRepMetadata, + , DRepKey + , DRepExtendedKey + , DRepMetadata + , DRepMetadataReference + , hashDRepMetadata -- ** Governance related certificates - AnchorDataHash(..), - AnchorUrl(..), - CommitteeColdkeyResignationRequirements(..), - CommitteeHotKeyAuthorizationRequirements(..), - DRepRegistrationRequirements(..), - DRepUnregistrationRequirements(..), - DRepUpdateRequirements(..), - makeCommitteeColdkeyResignationCertificate, - makeCommitteeHotKeyAuthorizationCertificate, - makeDrepRegistrationCertificate, - makeDrepUnregistrationCertificate, - makeDrepUpdateCertificate, - - ResolvablePointers(..), - - unsafeBoundedRational, + , AnchorDataHash (..) + , AnchorUrl (..) + , CommitteeColdkeyResignationRequirements (..) + , CommitteeHotKeyAuthorizationRequirements (..) + , DRepRegistrationRequirements (..) + , DRepUnregistrationRequirements (..) + , DRepUpdateRequirements (..) + , makeCommitteeColdkeyResignationCertificate + , makeCommitteeHotKeyAuthorizationCertificate + , makeDrepRegistrationCertificate + , makeDrepUnregistrationCertificate + , makeDrepUpdateCertificate + , ResolvablePointers (..) + , unsafeBoundedRational + -- ** Supporting modules - module Cardano.Api.Monad.Error, - module Cardano.Api.Pretty - ) where - -import Cardano.Api.Address -import Cardano.Api.Anchor -import Cardano.Api.Block -import Cardano.Api.Certificate -import Cardano.Api.Convenience.Construction -import Cardano.Api.Convenience.Query -import Cardano.Api.DeserialiseAnyOf -import Cardano.Api.DRepMetadata -import Cardano.Api.Eon.AllegraEraOnwards -import Cardano.Api.Eon.AlonzoEraOnwards -import Cardano.Api.Eon.BabbageEraOnwards -import Cardano.Api.Eon.ByronToAlonzoEra -import Cardano.Api.Eon.ConwayEraOnwards -import Cardano.Api.Eon.MaryEraOnwards -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eon.ShelleyEraOnly -import Cardano.Api.Eon.ShelleyToAllegraEra -import Cardano.Api.Eon.ShelleyToAlonzoEra -import Cardano.Api.Eon.ShelleyToBabbageEra -import Cardano.Api.Eon.ShelleyToMaryEra -import Cardano.Api.Eras -import Cardano.Api.Eras.Case -import Cardano.Api.Error -import Cardano.Api.Feature -import Cardano.Api.Fees -import Cardano.Api.Genesis -import Cardano.Api.GenesisParameters -import Cardano.Api.Governance.Actions.ProposalProcedure -import Cardano.Api.Hash -import Cardano.Api.HasTypeProxy -import Cardano.Api.InMode -import Cardano.Api.IO -import Cardano.Api.IPC -import Cardano.Api.IPC.Monad -import Cardano.Api.Keys.Byron -import Cardano.Api.Keys.Class -import Cardano.Api.Keys.Read -import Cardano.Api.Keys.Shelley -import Cardano.Api.LedgerState -import Cardano.Api.Modes -import Cardano.Api.Monad.Error -import Cardano.Api.NetworkId -import Cardano.Api.OperationalCertificate -import Cardano.Api.Orphans () -import Cardano.Api.Pretty -import Cardano.Api.Protocol -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query hiding (LedgerState (..)) -import Cardano.Api.Query.Expr -import Cardano.Api.Rewards -import Cardano.Api.Script -import Cardano.Api.ScriptData -import Cardano.Api.SerialiseBech32 -import Cardano.Api.SerialiseCBOR -import Cardano.Api.SerialiseJSON -import Cardano.Api.SerialiseLedgerCddl -import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Api.StakePoolMetadata -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.TxMetadata -import Cardano.Api.Utils -import Cardano.Api.Value -import Cardano.Api.ValueParser + , module Cardano.Api.Monad.Error + , module Cardano.Api.Pretty + ) +where + +import Cardano.Api.Address +import Cardano.Api.Anchor +import Cardano.Api.Block +import Cardano.Api.Certificate +import Cardano.Api.Convenience.Construction +import Cardano.Api.Convenience.Query +import Cardano.Api.DRepMetadata +import Cardano.Api.DeserialiseAnyOf +import Cardano.Api.Eon.AllegraEraOnwards +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ByronToAlonzoEra +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.MaryEraOnwards +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyEraOnly +import Cardano.Api.Eon.ShelleyToAllegraEra +import Cardano.Api.Eon.ShelleyToAlonzoEra +import Cardano.Api.Eon.ShelleyToBabbageEra +import Cardano.Api.Eon.ShelleyToMaryEra +import Cardano.Api.Eras +import Cardano.Api.Eras.Case +import Cardano.Api.Error +import Cardano.Api.Feature +import Cardano.Api.Fees +import Cardano.Api.Genesis +import Cardano.Api.GenesisParameters +import Cardano.Api.Governance.Actions.ProposalProcedure +import Cardano.Api.HasTypeProxy +import Cardano.Api.Hash +import Cardano.Api.IO +import Cardano.Api.IPC +import Cardano.Api.IPC.Monad +import Cardano.Api.InMode +import Cardano.Api.Keys.Byron +import Cardano.Api.Keys.Class +import Cardano.Api.Keys.Read +import Cardano.Api.Keys.Shelley +import Cardano.Api.LedgerState +import Cardano.Api.Modes +import Cardano.Api.Monad.Error +import Cardano.Api.NetworkId +import Cardano.Api.OperationalCertificate +import Cardano.Api.Orphans () +import Cardano.Api.Pretty +import Cardano.Api.Protocol +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query hiding (LedgerState (..)) +import Cardano.Api.Query.Expr +import Cardano.Api.Rewards +import Cardano.Api.Script +import Cardano.Api.ScriptData +import Cardano.Api.SerialiseBech32 +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseJSON +import Cardano.Api.SerialiseLedgerCddl +import Cardano.Api.SerialiseRaw +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.SerialiseUsing +import Cardano.Api.StakePoolMetadata +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.TxMetadata +import Cardano.Api.Utils +import Cardano.Api.Value +import Cardano.Api.ValueParser diff --git a/cardano-api/src/Cardano/Api/Byron.hs b/cardano-api/src/Cardano/Api/Byron.hs index 8754c310f5..620dc5a583 100644 --- a/cardano-api/src/Cardano/Api/Byron.hs +++ b/cardano-api/src/Cardano/Api/Byron.hs @@ -1,99 +1,101 @@ -- | This module provides a library interface that is intended to be -- the complete API for Byron covering everything, including exposing -- constructors for the lower level types. --- - module Cardano.Api.Byron - ( module Cardano.Api, - AsType(..), + ( module Cardano.Api + , AsType (..) -- * Cryptographic key interface -- $keys - VerificationKey(..), - SigningKey(..), - SomeByronSigningKey(..), + , VerificationKey (..) + , SigningKey (..) + , SomeByronSigningKey (..) -- * Hashes - Hash(..), + , Hash (..) -- * Payment addresses + -- | Constructing and inspecting Byron payment addresses - Address(ByronAddress), - NetworkId(Mainnet, Testnet), + , Address (ByronAddress) + , NetworkId (Mainnet, Testnet) -- * Building transactions + -- | Constructing and inspecting transactions - TxId(TxId), - TxIn(TxIn), - TxOut(TxOut), - TxIx(TxIx), + , TxId (TxId) + , TxIn (TxIn) + , TxOut (TxOut) + , TxIx (TxIx) -- * Signing transactions + -- | Creating transaction witnesses one by one, or all in one go. - ATxAux(..), + , ATxAux (..) -- ** Incremental signing and separate witnesses - KeyWitness (ByronKeyWitness), - WitnessNetworkIdOrByronAddress - ( WitnessNetworkId - , WitnessByronAddress - ), + , KeyWitness (ByronKeyWitness) + , WitnessNetworkIdOrByronAddress + ( WitnessNetworkId + , WitnessByronAddress + ) -- * Errors - Error(..), - FileError(..), + , Error (..) + , FileError (..) -- ** Low level protocol interaction with a Cardano node - LocalNodeConnectInfo(LocalNodeConnectInfo), - LocalNodeClientProtocols(LocalNodeClientProtocols), + , LocalNodeConnectInfo (LocalNodeConnectInfo) + , LocalNodeClientProtocols (LocalNodeClientProtocols) -- *** Chain sync protocol - ChainSyncClient(..), + , ChainSyncClient (..) -- *** Local tx submission - LocalTxSubmissionClient(LocalTxSubmissionClient), + , LocalTxSubmissionClient (LocalTxSubmissionClient) -- *** Local state query - LocalStateQueryClient(..), + , LocalStateQueryClient (..) -- * Address - NetworkMagic(..), + , NetworkMagic (..) -- * Update Proposal - ByronUpdateProposal(..), - ByronProtocolParametersUpdate (..), - makeByronUpdateProposal, - toByronLedgerUpdateProposal, - makeProtocolParametersUpdate, + , ByronUpdateProposal (..) + , ByronProtocolParametersUpdate (..) + , makeByronUpdateProposal + , toByronLedgerUpdateProposal + , makeProtocolParametersUpdate -- * Vote - ByronVote(..), - makeByronVote, - toByronLedgertoByronVote, + , ByronVote (..) + , makeByronVote + , toByronLedgertoByronVote -- ** Conversions - fromByronTxIn, - toByronLovelace, - toByronNetworkMagic, - toByronProtocolMagicId, - toByronRequiresNetworkMagic, + , fromByronTxIn + , toByronLovelace + , toByronNetworkMagic + , toByronProtocolMagicId + , toByronRequiresNetworkMagic -- * Hardcoded configuration parameters - applicationName, - applicationVersion, - softwareVersion, + , applicationName + , applicationVersion + , softwareVersion -- * Serialization - serializeByronTx, - writeByronTxFileTextEnvelopeCddl, - ) where - -import Cardano.Api -import Cardano.Api.Address -import Cardano.Api.Keys.Byron -import Cardano.Api.NetworkId -import Cardano.Api.SerialiseLedgerCddl -import Cardano.Api.SpecialByron -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.Value + , serializeByronTx + , writeByronTxFileTextEnvelopeCddl + ) +where + +import Cardano.Api +import Cardano.Api.Address +import Cardano.Api.Keys.Byron +import Cardano.Api.NetworkId +import Cardano.Api.SerialiseLedgerCddl +import Cardano.Api.SpecialByron +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.Value diff --git a/cardano-api/src/Cardano/Api/ChainSync/Client.hs b/cardano-api/src/Cardano/Api/ChainSync/Client.hs index 0f821f6656..a24da8a7f5 100644 --- a/cardano-api/src/Cardano/Api/ChainSync/Client.hs +++ b/cardano-api/src/Cardano/Api/ChainSync/Client.hs @@ -1,17 +1,18 @@ +module Cardano.Api.ChainSync.Client + ( -- * Protocol type for the client -module Cardano.Api.ChainSync.Client ( - -- * Protocol type for the client - -- | The protocol states from the point of view of the client. - ChainSyncClient(..) - , ClientStIdle(..) - , ClientStNext(..) - , ClientStIntersect(..) + -- | The protocol states from the point of view of the client. + ChainSyncClient (..) + , ClientStIdle (..) + , ClientStNext (..) + , ClientStIntersect (..) - -- * Null chain sync client - , chainSyncClientNull + -- * Null chain sync client + , chainSyncClientNull - -- * Utilities - , mapChainSyncClient - ) where + -- * Utilities + , mapChainSyncClient + ) +where -import Ouroboros.Network.Protocol.ChainSync.Client +import Ouroboros.Network.Protocol.ChainSync.Client diff --git a/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs b/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs index f5dcc3f762..d9a3da779d 100644 --- a/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs +++ b/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs @@ -1,35 +1,36 @@ +module Cardano.Api.ChainSync.ClientPipelined + ( -- * Pipelined protocol type for the client -module Cardano.Api.ChainSync.ClientPipelined ( - -- * Pipelined protocol type for the client - -- | The protocol states from the point of view of the client. - ChainSyncClientPipelined (..) - , ClientPipelinedStIdle (..) - , ClientStNext (..) - , ClientPipelinedStIntersect (..) - , ChainSyncInstruction (..) + -- | The protocol states from the point of view of the client. + ChainSyncClientPipelined (..) + , ClientPipelinedStIdle (..) + , ClientStNext (..) + , ClientPipelinedStIntersect (..) + , ChainSyncInstruction (..) - -- * Implementation Helpers - -- | It's generally idiomatic to use these functions to implement your - -- pipelined client. It aids in deciding when to make pipelined requests - -- vs process received responses. - , PipelineDecision(..) - , MkPipelineDecision(..) - , runPipelineDecision - , constantPipelineDecision - , pipelineDecisionMax - , pipelineDecisionMin - , pipelineDecisionLowHighMark + -- * Implementation Helpers - -- * Type level natural numbers - , N (..) - , Nat (..) - , natToInt + -- | It's generally idiomatic to use these functions to implement your + -- pipelined client. It aids in deciding when to make pipelined requests + -- vs process received responses. + , PipelineDecision (..) + , MkPipelineDecision (..) + , runPipelineDecision + , constantPipelineDecision + , pipelineDecisionMax + , pipelineDecisionMin + , pipelineDecisionLowHighMark - -- * Utilities - , mapChainSyncClientPipelined - ) where + -- * Type level natural numbers + , N (..) + , Nat (..) + , natToInt -import Ouroboros.Network.Protocol.ChainSync.ClientPipelined -import Ouroboros.Network.Protocol.ChainSync.PipelineDecision + -- * Utilities + , mapChainSyncClientPipelined + ) +where -import Network.TypedProtocol.Pipelined (N (..), Nat (..), natToInt) +import Network.TypedProtocol.Pipelined (N (..), Nat (..), natToInt) +import Ouroboros.Network.Protocol.ChainSync.ClientPipelined +import Ouroboros.Network.Protocol.ChainSync.PipelineDecision diff --git a/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs b/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs index 5c09bc8a75..2debb745d1 100644 --- a/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs +++ b/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs @@ -18,106 +18,101 @@ module Cardano.Api.Crypto.Ed25519Bip32 ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Crypto.DSIGN.Class -import Cardano.Crypto.Seed -import Cardano.Crypto.Util (SignableRepresentation (..)) +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import Cardano.Crypto.DSIGN.Class +import Cardano.Crypto.Seed +import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.Wallet as CC - -import Control.DeepSeq (NFData) -import Data.ByteArray as BA (ByteArrayAccess, ScrubbedBytes, convert) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import GHC.Generics (Generic) - +import Control.DeepSeq (NFData) import qualified Crypto.ECC.Edwards25519 as Ed25519 -import Crypto.Error (eitherCryptoError) -import NoThunks.Class (InspectHeap (..), NoThunks) - +import Crypto.Error (eitherCryptoError) +import Data.ByteArray as BA (ByteArrayAccess, ScrubbedBytes, convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import GHC.Generics (Generic) +import NoThunks.Class (InspectHeap (..), NoThunks) data Ed25519Bip32DSIGN instance DSIGNAlgorithm Ed25519Bip32DSIGN where + type SeedSizeDSIGN Ed25519Bip32DSIGN = 32 - type SeedSizeDSIGN Ed25519Bip32DSIGN = 32 + -- \| BIP32-Ed25519 extended verification key size is 64 octets. + type SizeVerKeyDSIGN Ed25519Bip32DSIGN = 64 - -- | BIP32-Ed25519 extended verification key size is 64 octets. - type SizeVerKeyDSIGN Ed25519Bip32DSIGN = 64 + -- \| BIP32-Ed25519 extended signing key size is 96 octets. + type SizeSignKeyDSIGN Ed25519Bip32DSIGN = 96 - -- | BIP32-Ed25519 extended signing key size is 96 octets. - type SizeSignKeyDSIGN Ed25519Bip32DSIGN = 96 + -- \| BIP32-Ed25519 extended signature size is 64 octets. + type SizeSigDSIGN Ed25519Bip32DSIGN = 64 - -- | BIP32-Ed25519 extended signature size is 64 octets. - type SizeSigDSIGN Ed25519Bip32DSIGN = 64 + -- + -- Key and signature types + -- - -- - -- Key and signature types - -- + newtype VerKeyDSIGN Ed25519Bip32DSIGN = VerKeyEd25519Bip32DSIGN CC.XPub + deriving (Show, Eq, Generic) + deriving newtype (NFData) + deriving (NoThunks) via InspectHeap CC.XPub - newtype VerKeyDSIGN Ed25519Bip32DSIGN = VerKeyEd25519Bip32DSIGN CC.XPub - deriving (Show, Eq, Generic) - deriving newtype NFData - deriving NoThunks via InspectHeap CC.XPub + newtype SignKeyDSIGN Ed25519Bip32DSIGN = SignKeyEd25519Bip32DSIGN CC.XPrv + deriving (Generic, ByteArrayAccess) + deriving newtype (NFData) + deriving (NoThunks) via InspectHeap CC.XPrv - newtype SignKeyDSIGN Ed25519Bip32DSIGN = SignKeyEd25519Bip32DSIGN CC.XPrv - deriving (Generic, ByteArrayAccess) - deriving newtype NFData - deriving NoThunks via InspectHeap CC.XPrv + newtype SigDSIGN Ed25519Bip32DSIGN = SigEd25519Bip32DSIGN CC.XSignature + deriving (Show, Eq, Generic, ByteArrayAccess) + deriving (NoThunks) via InspectHeap CC.XSignature - newtype SigDSIGN Ed25519Bip32DSIGN = SigEd25519Bip32DSIGN CC.XSignature - deriving (Show, Eq, Generic, ByteArrayAccess) - deriving NoThunks via InspectHeap CC.XSignature + -- + -- Metadata and basic key operations + -- - -- - -- Metadata and basic key operations - -- + algorithmNameDSIGN _ = "ed25519_bip32" - algorithmNameDSIGN _ = "ed25519_bip32" + deriveVerKeyDSIGN (SignKeyEd25519Bip32DSIGN sk) = + VerKeyEd25519Bip32DSIGN $ CC.toXPub sk - deriveVerKeyDSIGN (SignKeyEd25519Bip32DSIGN sk) = - VerKeyEd25519Bip32DSIGN $ CC.toXPub sk + -- + -- Core algorithm operations + -- - -- - -- Core algorithm operations - -- + type Signable Ed25519Bip32DSIGN = SignableRepresentation - type Signable Ed25519Bip32DSIGN = SignableRepresentation + signDSIGN () a (SignKeyEd25519Bip32DSIGN sk) = + SigEd25519Bip32DSIGN $ + CC.sign (mempty :: ScrubbedBytes) sk (getSignableRepresentation a) - signDSIGN () a (SignKeyEd25519Bip32DSIGN sk) = - SigEd25519Bip32DSIGN $ - CC.sign (mempty :: ScrubbedBytes) sk (getSignableRepresentation a) + verifyDSIGN () (VerKeyEd25519Bip32DSIGN vk) a (SigEd25519Bip32DSIGN sig) = + if CC.verify vk (getSignableRepresentation a) sig + then Right () + else Left "Verification failed" - verifyDSIGN () (VerKeyEd25519Bip32DSIGN vk) a (SigEd25519Bip32DSIGN sig) = - if CC.verify vk (getSignableRepresentation a) sig - then Right () - else Left "Verification failed" + -- + -- Key generation + -- - -- - -- Key generation - -- + genKeyDSIGN seed = + SignKeyEd25519Bip32DSIGN $ + CC.generateNew + (getSeedBytes seed) + (mempty :: ScrubbedBytes) + (mempty :: ScrubbedBytes) - genKeyDSIGN seed = - SignKeyEd25519Bip32DSIGN $ - CC.generateNew - (getSeedBytes seed) - (mempty :: ScrubbedBytes) - (mempty :: ScrubbedBytes) + -- + -- raw serialise/deserialise + -- - -- - -- raw serialise/deserialise - -- - - rawSerialiseVerKeyDSIGN (VerKeyEd25519Bip32DSIGN vk) = CC.unXPub vk - rawSerialiseSignKeyDSIGN (SignKeyEd25519Bip32DSIGN sk) = xPrvToBytes sk - rawSerialiseSigDSIGN = BA.convert - - rawDeserialiseVerKeyDSIGN = - either (const Nothing) (Just . VerKeyEd25519Bip32DSIGN) . CC.xpub - rawDeserialiseSignKeyDSIGN = - fmap SignKeyEd25519Bip32DSIGN . xPrvFromBytes - rawDeserialiseSigDSIGN = - either (const Nothing) (Just . SigEd25519Bip32DSIGN) . CC.xsignature + rawSerialiseVerKeyDSIGN (VerKeyEd25519Bip32DSIGN vk) = CC.unXPub vk + rawSerialiseSignKeyDSIGN (SignKeyEd25519Bip32DSIGN sk) = xPrvToBytes sk + rawSerialiseSigDSIGN = BA.convert + rawDeserialiseVerKeyDSIGN = + either (const Nothing) (Just . VerKeyEd25519Bip32DSIGN) . CC.xpub + rawDeserialiseSignKeyDSIGN = + fmap SignKeyEd25519Bip32DSIGN . xPrvFromBytes + rawDeserialiseSigDSIGN = + either (const Nothing) (Just . SigEd25519Bip32DSIGN) . CC.xsignature instance Show (SignKeyDSIGN Ed25519Bip32DSIGN) where show (SignKeyEd25519Bip32DSIGN sk) = show $ xPrvToBytes sk @@ -143,7 +138,6 @@ instance ToCBOR (SigDSIGN Ed25519Bip32DSIGN) where instance FromCBOR (SigDSIGN Ed25519Bip32DSIGN) where fromCBOR = decodeSigDSIGN - -- | Serialise an 'CC.XPrv' to a 'ByteString' (96 bytes). -- -- In @cardano-crypto@, an 'CC.XPrv' was originally serialised using the @@ -159,15 +153,14 @@ instance FromCBOR (SigDSIGN Ed25519Bip32DSIGN) where -- +---------------------------------+-----------------------+ -- | Extended Private Key (64 bytes) | Chain Code (32 bytes) | -- +---------------------------------+-----------------------+ --- xPrvToBytes :: CC.XPrv -> ByteString xPrvToBytes xPrv = privateKeyBytes <> chainCodeBytes - where - privateKeyBytes :: ByteString - privateKeyBytes = BS.take 64 (CC.unXPrv xPrv) + where + privateKeyBytes :: ByteString + privateKeyBytes = BS.take 64 (CC.unXPrv xPrv) - chainCodeBytes :: ByteString - chainCodeBytes = BS.drop 96 (CC.unXPrv xPrv) + chainCodeBytes :: ByteString + chainCodeBytes = BS.drop 96 (CC.unXPrv xPrv) -- | Deserialise an 'CC.XPrv' from a 'ByteString' (96 bytes). -- @@ -184,19 +177,18 @@ xPrvToBytes xPrv = privateKeyBytes <> chainCodeBytes -- +---------------------------------+-----------------------+ -- | Extended Private Key (64 bytes) | Chain Code (32 bytes) | -- +---------------------------------+-----------------------+ --- xPrvFromBytes :: ByteString -> Maybe CC.XPrv xPrvFromBytes bytes - | BS.length bytes /= 96 = Nothing - | otherwise = do - let (prv, cc) = BS.splitAt 64 bytes - pub <- ed25519ScalarMult (BS.take 32 prv) - eitherToMaybe $ CC.xprv $ prv <> pub <> cc - where - eitherToMaybe :: Either a b -> Maybe b - eitherToMaybe = either (const Nothing) Just - - ed25519ScalarMult :: ByteString -> Maybe ByteString - ed25519ScalarMult bs = do - scalar <- eitherToMaybe . eitherCryptoError $ Ed25519.scalarDecodeLong bs - pure $ Ed25519.pointEncode $ Ed25519.toPoint scalar + | BS.length bytes /= 96 = Nothing + | otherwise = do + let (prv, cc) = BS.splitAt 64 bytes + pub <- ed25519ScalarMult (BS.take 32 prv) + eitherToMaybe $ CC.xprv $ prv <> pub <> cc + where + eitherToMaybe :: Either a b -> Maybe b + eitherToMaybe = either (const Nothing) Just + + ed25519ScalarMult :: ByteString -> Maybe ByteString + ed25519ScalarMult bs = do + scalar <- eitherToMaybe . eitherCryptoError $ Ed25519.scalarDecodeLong bs + pure $ Ed25519.pointEncode $ Ed25519.toPoint scalar diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 1b1cf1db1e..a670fe599e 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -11,6 +11,7 @@ module Cardano.Api.Experimental , VersionToSbe , useEra , protocolVersionToSbe - ) where + ) +where -import Cardano.Api.Protocol.Version +import Cardano.Api.Protocol.Version diff --git a/cardano-api/src/Cardano/Api/Ledger.hs b/cardano-api/src/Cardano/Api/Ledger.hs index 7d8caba1e4..1619105aef 100644 --- a/cardano-api/src/Cardano/Api/Ledger.hs +++ b/cardano-api/src/Cardano/Api/Ledger.hs @@ -1,6 +1,6 @@ module Cardano.Api.Ledger ( module Cardano.Api.ReexposeLedger ) - where +where -import Cardano.Api.ReexposeLedger +import Cardano.Api.ReexposeLedger diff --git a/cardano-api/src/Cardano/Api/Network.hs b/cardano-api/src/Cardano/Api/Network.hs index 45edec13ee..047f7b099f 100644 --- a/cardano-api/src/Cardano/Api/Network.hs +++ b/cardano-api/src/Cardano/Api/Network.hs @@ -1,6 +1,6 @@ module Cardano.Api.Network ( module Cardano.Api.ReexposeNetwork ) - where +where -import Cardano.Api.ReexposeNetwork +import Cardano.Api.ReexposeNetwork diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index db16d817f5..f1f475b79e 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -1,319 +1,316 @@ -- | This module provides a library interface that is intended to be -- the complete API for Shelley covering everything, including -- exposing constructors for the lower level types. --- - module Cardano.Api.Shelley - ( module Cardano.Api, + ( module Cardano.Api -- * Genesis - ShelleyGenesis(..), - shelleyGenesisDefaults, - alonzoGenesisDefaults, - conwayGenesisDefaults, + , ShelleyGenesis (..) + , shelleyGenesisDefaults + , alonzoGenesisDefaults + , conwayGenesisDefaults -- * Cryptographic key interface -- $keys - Key(..), - VerificationKey(..), - SigningKey(..), + , Key (..) + , VerificationKey (..) + , SigningKey (..) -- * Hashes - Hash(..), + , Hash (..) -- * Type Proxies - AsType(..), + , AsType (..) -- * Payment addresses + -- | Constructing and inspecting Shelley payment addresses - Address(ShelleyAddress), - toShelleyAddr, - fromShelleyAddr, - fromShelleyAddrIsSbe, - fromShelleyAddrToAny, - toShelleyStakeCredential, - fromShelleyStakeCredential, - NetworkId(Mainnet, Testnet), + , Address (ShelleyAddress) + , toShelleyAddr + , fromShelleyAddr + , fromShelleyAddrIsSbe + , fromShelleyAddrToAny + , toShelleyStakeCredential + , fromShelleyStakeCredential + , NetworkId (Mainnet, Testnet) -- * Stake addresses - PaymentCredential(..), - StakeAddress(..), - StakeAddressReference(..), - StakeCredential(..), - toShelleyStakeAddr, - fromShelleyStakeAddr, - fromShelleyStakeReference, - fromShelleyPaymentCredential, + , PaymentCredential (..) + , StakeAddress (..) + , StakeAddressReference (..) + , StakeCredential (..) + , toShelleyStakeAddr + , fromShelleyStakeAddr + , fromShelleyStakeReference + , fromShelleyPaymentCredential -- * Building transactions + -- | Constructing and inspecting transactions - TxBody(ShelleyTxBody), - TxId(TxId), - toShelleyTxId, - fromShelleyTxId, - getTxIdShelley, - TxIn(TxIn), - toShelleyTxIn, - fromShelleyTxIn, - TxOut(TxOut), - toShelleyTxOut, - fromShelleyTxOut, - TxIx(TxIx), - toMaryValue, - fromMaryValue, - calcMinimumDeposit, + , TxBody (ShelleyTxBody) + , TxId (TxId) + , toShelleyTxId + , fromShelleyTxId + , getTxIdShelley + , TxIn (TxIn) + , toShelleyTxIn + , fromShelleyTxIn + , TxOut (TxOut) + , toShelleyTxOut + , fromShelleyTxOut + , TxIx (TxIx) + , toMaryValue + , fromMaryValue + , calcMinimumDeposit -- * Arbitrary signing - signArbitraryBytesKes, + , signArbitraryBytesKes -- * Signing transactions + -- | Creating transaction witnesses one by one, or all in one go. - Tx(ShelleyTx), + , Tx (ShelleyTx) -- ** Incremental signing and separate witnesses - KeyWitness - ( ShelleyBootstrapWitness - , ShelleyKeyWitness - ), - ShelleyWitnessSigningKey - ( WitnessPaymentKey - , WitnessPaymentExtendedKey - , WitnessStakeKey - , WitnessStakeExtendedKey - , WitnessStakePoolKey - , WitnessGenesisKey - , WitnessGenesisExtendedKey - , WitnessGenesisDelegateKey - , WitnessGenesisDelegateExtendedKey - ), - ShelleySigningKey(..), - getShelleyKeyWitnessVerificationKey, - getTxBodyAndWitnesses, - makeShelleySignature, - toShelleySigningKey, + , KeyWitness + ( ShelleyBootstrapWitness + , ShelleyKeyWitness + ) + , ShelleyWitnessSigningKey + ( WitnessPaymentKey + , WitnessPaymentExtendedKey + , WitnessStakeKey + , WitnessStakeExtendedKey + , WitnessStakePoolKey + , WitnessGenesisKey + , WitnessGenesisExtendedKey + , WitnessGenesisDelegateKey + , WitnessGenesisDelegateExtendedKey + ) + , ShelleySigningKey (..) + , getShelleyKeyWitnessVerificationKey + , getTxBodyAndWitnesses + , makeShelleySignature + , toShelleySigningKey -- * Blocks - fromConsensusBlock, - toConsensusBlock, - fromConsensusTip, - fromConsensusPointHF, - toConsensusPointHF, + , fromConsensusBlock + , toConsensusBlock + , fromConsensusTip + , fromConsensusPointHF + , toConsensusPointHF -- * Transaction metadata + -- | Embedding additional structured data within transactions. - toShelleyMetadata, - fromShelleyMetadata, - toShelleyMetadatum, - fromShelleyMetadatum, + , toShelleyMetadata + , fromShelleyMetadata + , toShelleyMetadatum + , fromShelleyMetadatum -- * Protocol parameters - LedgerProtocolParameters(..), - EraBasedProtocolParametersUpdate(..), - CommonProtocolParametersUpdate(..), - AlonzoOnwardsPParams(..), - DeprecatedAfterBabbagePParams(..), - DeprecatedAfterMaryPParams(..), - ShelleyToAlonzoPParams(..), - IntroducedInBabbagePParams(..), - IntroducedInConwayPParams(..), - createEraBasedProtocolParamUpdate, - convertToLedgerProtocolParameters, - - ProtocolParameters(..), - checkProtocolParameters, - ProtocolParametersError(..), + , LedgerProtocolParameters (..) + , EraBasedProtocolParametersUpdate (..) + , CommonProtocolParametersUpdate (..) + , AlonzoOnwardsPParams (..) + , DeprecatedAfterBabbagePParams (..) + , DeprecatedAfterMaryPParams (..) + , ShelleyToAlonzoPParams (..) + , IntroducedInBabbagePParams (..) + , IntroducedInConwayPParams (..) + , createEraBasedProtocolParamUpdate + , convertToLedgerProtocolParameters + , ProtocolParameters (..) + , checkProtocolParameters + , ProtocolParametersError (..) -- * Scripts - fromShelleyBasedScript, - toShelleyScript, - toShelleyMultiSig, - fromShelleyMultiSig, - toAllegraTimelock, - fromAllegraTimelock, - toShelleyScriptHash, - fromShelleyScriptHash, - PlutusScript(..), - PlutusScriptOrReferenceInput(..), - SimpleScriptOrReferenceInput(..), - toPlutusData, - fromPlutusData, - toAlonzoData, - fromAlonzoData, - toAlonzoPrices, - fromAlonzoPrices, - toAlonzoExUnits, - fromAlonzoExUnits, - toScriptIndex, - scriptDataFromJsonDetailedSchema, - scriptDataToJsonDetailedSchema, - calculateExecutionUnitsLovelace, + , fromShelleyBasedScript + , toShelleyScript + , toShelleyMultiSig + , fromShelleyMultiSig + , toAllegraTimelock + , fromAllegraTimelock + , toShelleyScriptHash + , fromShelleyScriptHash + , PlutusScript (..) + , PlutusScriptOrReferenceInput (..) + , SimpleScriptOrReferenceInput (..) + , toPlutusData + , fromPlutusData + , toAlonzoData + , fromAlonzoData + , toAlonzoPrices + , fromAlonzoPrices + , toAlonzoExUnits + , fromAlonzoExUnits + , toScriptIndex + , scriptDataFromJsonDetailedSchema + , scriptDataToJsonDetailedSchema + , calculateExecutionUnitsLovelace -- * Reference Scripts - ReferenceScript(..), - refScriptToShelleyScript, + , ReferenceScript (..) + , refScriptToShelleyScript -- * Certificates - Certificate (..), - toShelleyCertificate, - fromShelleyCertificate, - toShelleyPoolParams, + , Certificate (..) + , toShelleyCertificate + , fromShelleyCertificate + , toShelleyPoolParams -- ** Operational certificates - OperationalCertificate(OperationalCertificate), - OperationalCertificateIssueCounter(..), - OperationalCertIssueError(..), + , OperationalCertificate (OperationalCertificate) + , OperationalCertificateIssueCounter (..) + , OperationalCertIssueError (..) -- * Stake Pool - StakePoolMetadata(StakePoolMetadata), - stakePoolName, - stakePoolDescription, - stakePoolTicker, - stakePoolHomepage, - StakePoolMetadataReference(StakePoolMetadataReference), - stakePoolMetadataURL, - stakePoolMetadataHash, - StakePoolParameters(StakePoolParameters), - stakePoolId, - stakePoolVRF, - stakePoolCost, - stakePoolMargin, - stakePoolRewardAccount, - stakePoolPledge, - stakePoolOwners, - stakePoolRelays, - stakePoolMetadata, - StakePoolRelay - ( StakePoolRelayIp - , StakePoolRelayDnsARecord - , StakePoolRelayDnsSrvRecord - ), - EpochNo(..), + , StakePoolMetadata (StakePoolMetadata) + , stakePoolName + , stakePoolDescription + , stakePoolTicker + , stakePoolHomepage + , StakePoolMetadataReference (StakePoolMetadataReference) + , stakePoolMetadataURL + , stakePoolMetadataHash + , StakePoolParameters (StakePoolParameters) + , stakePoolId + , stakePoolVRF + , stakePoolCost + , stakePoolMargin + , stakePoolRewardAccount + , stakePoolPledge + , stakePoolOwners + , stakePoolRelays + , stakePoolMetadata + , StakePoolRelay + ( StakePoolRelayIp + , StakePoolRelayDnsARecord + , StakePoolRelayDnsSrvRecord + ) + , EpochNo (..) -- * Governance Actions - createAnchor, - createPreviousGovernanceActionId, - createGovernanceActionId, + , createAnchor + , createPreviousGovernanceActionId + , createGovernanceActionId -- * DRep - DRepMetadata(DRepMetadata), - DRepMetadataReference(DRepMetadataReference), + , DRepMetadata (DRepMetadata) + , DRepMetadataReference (DRepMetadataReference) -- ** Stake pool operator's keys - StakePoolKey, - PoolId, + , StakePoolKey + , PoolId -- ** KES keys - KesKey, - KESPeriod(..), + , KesKey + , KESPeriod (..) -- ** VRF keys - VrfKey, + , VrfKey -- ** Low level protocol interaction with a Cardano node - LocalNodeConnectInfo(LocalNodeConnectInfo), - LocalNodeClientProtocols(LocalNodeClientProtocols), + , LocalNodeConnectInfo (LocalNodeConnectInfo) + , LocalNodeClientProtocols (LocalNodeClientProtocols) -- ** Shelley based eras - ShelleyLedgerEra, + , ShelleyLedgerEra -- *** Ledger Events - LedgerEvent(..), - AnyProposals(..), - AnyRatificationState(..), - MIRDistributionDetails(..), - PoolReapDetails(..), - toLedgerEvent, + , LedgerEvent (..) + , AnyProposals (..) + , AnyRatificationState (..) + , MIRDistributionDetails (..) + , PoolReapDetails (..) + , toLedgerEvent -- ** Local State Query - DebugLedgerState(..), - decodeDebugLedgerState, - ProtocolState(..), - decodeProtocolState, - SerialisedDebugLedgerState(..), - CurrentEpochState(..), - SerialisedCurrentEpochState(..), - decodeCurrentEpochState, - - PoolState(..), - SerialisedPoolState(..), - decodePoolState, - - PoolDistribution(..), - SerialisedPoolDistribution(..), - decodePoolDistribution, - - StakeSnapshot(..), - SerialisedStakeSnapshots(..), - decodeStakeSnapshot, - - UTxO(..), - AcquiringFailure(..), - SystemStart(..), + , DebugLedgerState (..) + , decodeDebugLedgerState + , ProtocolState (..) + , decodeProtocolState + , SerialisedDebugLedgerState (..) + , CurrentEpochState (..) + , SerialisedCurrentEpochState (..) + , decodeCurrentEpochState + , PoolState (..) + , SerialisedPoolState (..) + , decodePoolState + , PoolDistribution (..) + , SerialisedPoolDistribution (..) + , decodePoolDistribution + , StakeSnapshot (..) + , SerialisedStakeSnapshots (..) + , decodeStakeSnapshot + , UTxO (..) + , AcquiringFailure (..) + , SystemStart (..) -- ** Governance - GovernanceAction(..), - GovernanceActionId(..), - Proposal(..), - VotingProcedure(..), - VotingProcedures(..), - GovernancePoll(..), - GovernancePollAnswer(..), - GovernancePollError(..), - Vote(..), - Voter(..), - createProposalProcedure, - createVotingProcedure, - renderGovernancePollError, - fromProposalProcedure, - hashGovernancePoll, - verifyPollAnswer, + , GovernanceAction (..) + , GovernanceActionId (..) + , Proposal (..) + , VotingProcedure (..) + , VotingProcedures (..) + , GovernancePoll (..) + , GovernancePollAnswer (..) + , GovernancePollError (..) + , Vote (..) + , Voter (..) + , createProposalProcedure + , createVotingProcedure + , renderGovernancePollError + , fromProposalProcedure + , hashGovernancePoll + , verifyPollAnswer -- ** Various calculations - LeadershipError(..), - currentEpochEligibleLeadershipSlots, - nextEpochEligibleLeadershipSlots, + , LeadershipError (..) + , currentEpochEligibleLeadershipSlots + , nextEpochEligibleLeadershipSlots -- ** Conversions - shelleyPayAddrToPlutusPubKHash, - toConsensusGenTx, - fromAlonzoCostModels, - -- TODO: arrange not to export these - toLedgerNonce, - toShelleyNetwork, - fromShelleyPoolParams, - fromLedgerPParamsUpdate, - - emptyVotingProcedures, - mergeVotingProcedures, - singletonVotingProcedures, - VotesMergingConflict(..), - ) where - -import Cardano.Api -import Cardano.Api.Address -import Cardano.Api.Block -import Cardano.Api.Certificate -import Cardano.Api.DRepMetadata -import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Genesis -import Cardano.Api.Governance.Actions.ProposalProcedure -import Cardano.Api.Governance.Actions.VotingProcedure -import Cardano.Api.Governance.Poll -import Cardano.Api.InMode -import Cardano.Api.IPC -import Cardano.Api.Keys.Praos -import Cardano.Api.Keys.Shelley -import Cardano.Api.LedgerEvents.ConvertLedgerEvent -import Cardano.Api.LedgerEvents.LedgerEvent -import Cardano.Api.LedgerState -import Cardano.Api.NetworkId -import Cardano.Api.OperationalCertificate -import Cardano.Api.ProtocolParameters -import Cardano.Api.Query -import Cardano.Api.Script -import Cardano.Api.ScriptData -import Cardano.Api.StakePoolMetadata -import Cardano.Api.Tx.Body -import Cardano.Api.Tx.Sign -import Cardano.Api.TxMetadata -import Cardano.Api.Value + , shelleyPayAddrToPlutusPubKHash + , toConsensusGenTx + , fromAlonzoCostModels + -- TODO: arrange not to export these + , toLedgerNonce + , toShelleyNetwork + , fromShelleyPoolParams + , fromLedgerPParamsUpdate + , emptyVotingProcedures + , mergeVotingProcedures + , singletonVotingProcedures + , VotesMergingConflict (..) + ) +where + +import Cardano.Api +import Cardano.Api.Address +import Cardano.Api.Block +import Cardano.Api.Certificate +import Cardano.Api.DRepMetadata +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Genesis +import Cardano.Api.Governance.Actions.ProposalProcedure +import Cardano.Api.Governance.Actions.VotingProcedure +import Cardano.Api.Governance.Poll +import Cardano.Api.IPC +import Cardano.Api.InMode +import Cardano.Api.Keys.Praos +import Cardano.Api.Keys.Shelley +import Cardano.Api.LedgerEvents.ConvertLedgerEvent +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerState +import Cardano.Api.NetworkId +import Cardano.Api.OperationalCertificate +import Cardano.Api.ProtocolParameters +import Cardano.Api.Query +import Cardano.Api.Script +import Cardano.Api.ScriptData +import Cardano.Api.StakePoolMetadata +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import Cardano.Api.TxMetadata +import Cardano.Api.Value diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Genesis.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Genesis.hs index 358e3322ae..9fdb63e4cb 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Genesis.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Genesis.hs @@ -1,32 +1,38 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} - {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Test.Golden.Cardano.Api.Genesis ( exampleShelleyGenesis - ) where - -import Cardano.Api.Shelley (ShelleyGenesis (..)) + ) +where -import Cardano.Ledger.Address (Addr (..)) -import Cardano.Ledger.BaseTypes (Network (..)) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Core -import Cardano.Ledger.Credential (Credential (..), PaymentCredential, StakeCredential, - StakeReference (..)) -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Keys (GenDelegPair (..), Hash, KeyHash (..), KeyRole (..), - VerKeyVRF) -import Cardano.Ledger.Shelley.Genesis (emptyGenesisStaking) -import Cardano.Slotting.Slot (EpochSize (..)) - -import Data.ListMap (ListMap (ListMap)) +import Cardano.Api.Shelley (ShelleyGenesis (..)) +import Cardano.Ledger.Address (Addr (..)) +import Cardano.Ledger.BaseTypes (Network (..)) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Core +import Cardano.Ledger.Credential + ( Credential (..) + , PaymentCredential + , StakeCredential + , StakeReference (..) + ) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys + ( GenDelegPair (..) + , Hash + , KeyHash (..) + , KeyRole (..) + , VerKeyVRF + ) +import Cardano.Ledger.Shelley.Genesis (emptyGenesisStaking) +import Cardano.Slotting.Slot (EpochSize (..)) +import Data.ListMap (ListMap (ListMap)) import qualified Data.Map.Strict as Map -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Lens.Micro - -import Test.Cardano.Ledger.Shelley.Utils (unsafeBoundRational) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Lens.Micro +import Test.Cardano.Ledger.Shelley.Utils (unsafeBoundRational) exampleShelleyGenesis :: ShelleyGenesis StandardCrypto exampleShelleyGenesis = @@ -42,15 +48,19 @@ exampleShelleyGenesis = , sgSlotLength = 8 , sgUpdateQuorum = 16991 , sgMaxLovelaceSupply = 71 - , sgProtocolParams = emptyPParams - & ppDL .~ unsafeBoundRational 1.9e-2 - & ppMaxBBSizeL .~ 65535 - & ppMaxBHSizeL .~ 65535 - , sgGenDelegs = Map.fromList - [( genesisVerKeyHash - , GenDelegPair delegVerKeyHash delegVrfKeyHash) - ] - , sgInitialFunds = ListMap [(initialFundedAddress,initialFunds)] + , sgProtocolParams = + emptyPParams + & ppDL .~ unsafeBoundRational 1.9e-2 + & ppMaxBBSizeL .~ 65535 + & ppMaxBHSizeL .~ 65535 + , sgGenDelegs = + Map.fromList + [ + ( genesisVerKeyHash + , GenDelegPair delegVerKeyHash delegVrfKeyHash + ) + ] + , sgInitialFunds = ListMap [(initialFundedAddress, initialFunds)] , sgStaking = emptyGenesisStaking } where @@ -64,15 +74,17 @@ exampleShelleyGenesis = delegVrfKeyHash = "231391e7ec1c450a8518134cf6fad1a8e0ed7ffd66d740f8e8271347a6de7bf2" initialFundedAddress :: Addr StandardCrypto initialFundedAddress = Addr Testnet paymentCredential (StakeRefBase stakingCredential) - where - paymentCredential :: PaymentCredential StandardCrypto - paymentCredential = - KeyHashObj $ KeyHash + where + paymentCredential :: PaymentCredential StandardCrypto + paymentCredential = + KeyHashObj $ + KeyHash "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5" - stakingCredential :: StakeCredential StandardCrypto - stakingCredential = - KeyHashObj $ KeyHash + stakingCredential :: StakeCredential StandardCrypto + stakingCredential = + KeyHashObj $ + KeyHash "e37a65ea2f9bcefb645de4312cf13d8ac12ae61cf242a9aa2973c9ee" initialFunds :: Coin diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs index 44863fb2c9..2fef2dae0b 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs @@ -1,14 +1,17 @@ module Test.Golden.Cardano.Api.Ledger ( test_golden_ShelleyGenesis - ) where - -import Test.Cardano.Ledger.Core.Arbitrary () + ) +where import qualified Hedgehog.Extras.Aeson as H -import Test.Golden.Cardano.Api.Genesis (exampleShelleyGenesis) -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Golden.Cardano.Api.Genesis (exampleShelleyGenesis) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) test_golden_ShelleyGenesis :: TestTree -test_golden_ShelleyGenesis = testProperty "golden ShelleyGenesis" $ - H.goldenTestJsonValuePretty exampleShelleyGenesis "test/cardano-api-golden/files/golden/ShelleyGenesis.json" +test_golden_ShelleyGenesis = + testProperty "golden ShelleyGenesis" $ + H.goldenTestJsonValuePretty + exampleShelleyGenesis + "test/cardano-api-golden/files/golden/ShelleyGenesis.json" diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs index d2309136b1..c59f90be89 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs @@ -2,124 +2,145 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} - -- TODO remove me when ProtocolParameters is deleted {-# OPTIONS_GHC -Wno-deprecations #-} module Test.Golden.Cardano.Api.ProtocolParameters ( test_golden_ProtocolParameters , test_golden_ProtocolParameters_to_PParams - ) where - -import Cardano.Api (AnyPlutusScriptVersion (AnyPlutusScriptVersion), CostModel (..), - ExecutionUnits (..), PlutusScriptVersion (..), makePraosNonce) -import Cardano.Api.Ledger (Coin (..), EpochInterval (EpochInterval), StandardCrypto) -import Cardano.Api.ProtocolParameters (ExecutionUnitPrices (..), ProtocolParameters (..)) + ) +where -import Cardano.Ledger.Alonzo (AlonzoEra) -import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (..)) -import Cardano.Ledger.Babbage (BabbageEra) -import Cardano.Ledger.Babbage.PParams (BabbagePParams (..)) -import Cardano.Ledger.Plutus.CostModels (costModelParamsCount) -import Cardano.Ledger.Plutus.Language (Language (..)) -import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..)) - -import Data.Aeson (FromJSON, eitherDecode, encode) -import Data.ByteString.Lazy (ByteString) -import Data.Functor.Identity (Identity) -import Data.Int (Int64) -import Data.Map (Map) +import Cardano.Api + ( AnyPlutusScriptVersion (AnyPlutusScriptVersion) + , CostModel (..) + , ExecutionUnits (..) + , PlutusScriptVersion (..) + , makePraosNonce + ) +import Cardano.Api.Ledger (Coin (..), EpochInterval (EpochInterval), StandardCrypto) +import Cardano.Api.ProtocolParameters (ExecutionUnitPrices (..), ProtocolParameters (..)) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Babbage.PParams (BabbagePParams (..)) +import Cardano.Ledger.Plutus.CostModels (costModelParamsCount) +import Cardano.Ledger.Plutus.Language (Language (..)) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..)) +import Data.Aeson (FromJSON, eitherDecode, encode) +import Data.ByteString.Lazy (ByteString) +import Data.Functor.Identity (Identity) +import Data.Int (Int64) +import Data.Map (Map) import qualified Data.Map as M -import Data.Proxy (Proxy (..)) - -import Hedgehog (Property, property, success) +import Data.Proxy (Proxy (..)) +import Hedgehog (Property, property, success) import qualified Hedgehog.Extras.Aeson as H -import Hedgehog.Internal.Property (failWith) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Hedgehog.Internal.Property (failWith) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) test_golden_ProtocolParameters :: TestTree test_golden_ProtocolParameters = testProperty "golden ProtocolParameters" $ do - H.goldenTestJsonValuePretty legacyCardanoApiProtocolParameters "test/cardano-api-golden/files/golden/LegacyProtocolParameters.json" + H.goldenTestJsonValuePretty + legacyCardanoApiProtocolParameters + "test/cardano-api-golden/files/golden/LegacyProtocolParameters.json" test_golden_ProtocolParameters_to_PParams :: TestTree test_golden_ProtocolParameters_to_PParams = - testGroup "golden ProtocolParameter tests" - [ testProperty "ShelleyPParams" $ - goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (ShelleyPParams Identity (ShelleyEra StandardCrypto))) - , testProperty "AlonzoPParams" $ - goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (AlonzoPParams Identity (AlonzoEra StandardCrypto))) - , testProperty "BabbagePParams" $ - goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (BabbagePParams Identity (BabbageEra StandardCrypto))) - ] + testGroup + "golden ProtocolParameter tests" + [ testProperty "ShelleyPParams" $ + goldenLegacyProtocolParametersToPParams + (Proxy :: Proxy (ShelleyPParams Identity (ShelleyEra StandardCrypto))) + , testProperty "AlonzoPParams" $ + goldenLegacyProtocolParametersToPParams + (Proxy :: Proxy (AlonzoPParams Identity (AlonzoEra StandardCrypto))) + , testProperty "BabbagePParams" $ + goldenLegacyProtocolParametersToPParams + (Proxy :: Proxy (BabbagePParams Identity (BabbageEra StandardCrypto))) + ] -- Test that tries decoding the legacy protocol parameters golden file -- 'legacyCardanoApiProtocolParameters' as the type provided as a 'Proxy'. goldenLegacyProtocolParametersToPParams :: forall pp. FromJSON pp => Proxy pp -> Property goldenLegacyProtocolParametersToPParams proxy = property $ case decodedLegacyCardanoApiProtocolParameters of - Left err -> failWith Nothing - ("goldenLegacyProtocolParametersToPParams could not decode golden file as " - <> show proxy - <> ": " - <> show err) - Right _ -> success - where - bytestringLegacyCardanoApiProtocolParameters :: ByteString - bytestringLegacyCardanoApiProtocolParameters = encode legacyCardanoApiProtocolParameters + Left err -> + failWith + Nothing + ( "goldenLegacyProtocolParametersToPParams could not decode golden file as " + <> show proxy + <> ": " + <> show err + ) + Right _ -> success + where + bytestringLegacyCardanoApiProtocolParameters :: ByteString + bytestringLegacyCardanoApiProtocolParameters = encode legacyCardanoApiProtocolParameters - decodedLegacyCardanoApiProtocolParameters :: Either String pp - decodedLegacyCardanoApiProtocolParameters = eitherDecode bytestringLegacyCardanoApiProtocolParameters + decodedLegacyCardanoApiProtocolParameters :: Either String pp + decodedLegacyCardanoApiProtocolParameters = eitherDecode bytestringLegacyCardanoApiProtocolParameters legacyCardanoApiProtocolParameters :: ProtocolParameters -legacyCardanoApiProtocolParameters = ProtocolParameters { protocolParamUTxOCostPerByte = Just $ Coin 1_000_000 - , protocolParamTxFeePerByte = Coin 2_000_000 - , protocolParamTxFeeFixed = Coin 1_500_000 - , protocolParamTreasuryCut = 0.1 - , protocolParamStakePoolTargetNum = 100 - , protocolParamStakePoolDeposit = Coin 1_000_000_000 - , protocolParamStakeAddressDeposit = Coin 10_000_000 - , protocolParamProtocolVersion = (2, 3) - , protocolParamPrices = Just executionUnitPrices - , protocolParamPoolRetireMaxEpoch = Cardano.Api.Ledger.EpochInterval 4 - , protocolParamPoolPledgeInfluence = 0.54 - , protocolParamMonetaryExpansion = 0.23 - , protocolParamMinUTxOValue = Just $ Coin 3_000_000 - , protocolParamMinPoolCost = Coin 3_500_000 - , protocolParamMaxValueSize = Just 10 - , protocolParamMaxTxSize = 3000 - , protocolParamMaxTxExUnits = Just executionUnits - , protocolParamMaxCollateralInputs = Just 10 - , protocolParamMaxBlockHeaderSize = 1200 - , protocolParamMaxBlockExUnits = Just executionUnits2 - , protocolParamMaxBlockBodySize = 5000 - , protocolParamExtraPraosEntropy = Just $ makePraosNonce "entropyEntropy" - , protocolParamDecentralization = Just 0.52 - , protocolParamCostModels = costModels - , protocolParamCollateralPercent = Just 23 - } - where - executionUnitPrices :: ExecutionUnitPrices - executionUnitPrices = ExecutionUnitPrices { priceExecutionSteps = 0.3 - , priceExecutionMemory = 0.2 - } +legacyCardanoApiProtocolParameters = + ProtocolParameters + { protocolParamUTxOCostPerByte = Just $ Coin 1_000_000 + , protocolParamTxFeePerByte = Coin 2_000_000 + , protocolParamTxFeeFixed = Coin 1_500_000 + , protocolParamTreasuryCut = 0.1 + , protocolParamStakePoolTargetNum = 100 + , protocolParamStakePoolDeposit = Coin 1_000_000_000 + , protocolParamStakeAddressDeposit = Coin 10_000_000 + , protocolParamProtocolVersion = (2, 3) + , protocolParamPrices = Just executionUnitPrices + , protocolParamPoolRetireMaxEpoch = Cardano.Api.Ledger.EpochInterval 4 + , protocolParamPoolPledgeInfluence = 0.54 + , protocolParamMonetaryExpansion = 0.23 + , protocolParamMinUTxOValue = Just $ Coin 3_000_000 + , protocolParamMinPoolCost = Coin 3_500_000 + , protocolParamMaxValueSize = Just 10 + , protocolParamMaxTxSize = 3000 + , protocolParamMaxTxExUnits = Just executionUnits + , protocolParamMaxCollateralInputs = Just 10 + , protocolParamMaxBlockHeaderSize = 1200 + , protocolParamMaxBlockExUnits = Just executionUnits2 + , protocolParamMaxBlockBodySize = 5000 + , protocolParamExtraPraosEntropy = Just $ makePraosNonce "entropyEntropy" + , protocolParamDecentralization = Just 0.52 + , protocolParamCostModels = costModels + , protocolParamCollateralPercent = Just 23 + } + where + executionUnitPrices :: ExecutionUnitPrices + executionUnitPrices = + ExecutionUnitPrices + { priceExecutionSteps = 0.3 + , priceExecutionMemory = 0.2 + } - costModels :: Map AnyPlutusScriptVersion CostModel - costModels = M.fromList [ (AnyPlutusScriptVersion PlutusScriptV3, CostModel [1..numParams PlutusV3]) - , (AnyPlutusScriptVersion PlutusScriptV2, CostModel [1..numParams PlutusV2]) - , (AnyPlutusScriptVersion PlutusScriptV1, CostModel [1..numParams PlutusV1]) - ] + costModels :: Map AnyPlutusScriptVersion CostModel + costModels = + M.fromList + [ (AnyPlutusScriptVersion PlutusScriptV3, CostModel [1 .. numParams PlutusV3]) + , (AnyPlutusScriptVersion PlutusScriptV2, CostModel [1 .. numParams PlutusV2]) + , (AnyPlutusScriptVersion PlutusScriptV1, CostModel [1 .. numParams PlutusV1]) + ] - numParams :: Language -> Int64 - numParams = fromIntegral . costModelParamsCount + numParams :: Language -> Int64 + numParams = fromIntegral . costModelParamsCount - executionUnits :: ExecutionUnits - executionUnits = ExecutionUnits { executionSteps = 4300 - , executionMemory = 2300 - } + executionUnits :: ExecutionUnits + executionUnits = + ExecutionUnits + { executionSteps = 4300 + , executionMemory = 2300 + } - executionUnits2 :: ExecutionUnits - executionUnits2 = ExecutionUnits { executionSteps = 5600 - , executionMemory = 3400 - } + executionUnits2 :: ExecutionUnits + executionUnits2 = + ExecutionUnits + { executionSteps = 5600 + , executionMemory = 3400 + } diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs index 138a48ab79..4889b8dbcd 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs @@ -10,23 +10,20 @@ module Test.Golden.Cardano.Api.Typed.Script , test_roundtrip_SimpleScript_JSON , test_roundtrip_ScriptData , test_roundtrip_HashableScriptData_JSON - ) where - -import Cardano.Api -import Cardano.Api.Shelley + ) +where +import Cardano.Api +import Cardano.Api.Shelley import qualified Cardano.Ledger.Api.Era as L - -import Data.Aeson -import System.FilePath (()) - -import Test.Gen.Cardano.Api.Typed - -import Hedgehog ((===)) +import Data.Aeson +import Hedgehog ((===)) import qualified Hedgehog as H -import Hedgehog.Extras.Aeson -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) +import Hedgehog.Extras.Aeson +import System.FilePath (()) +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -56,14 +53,14 @@ exampleSimpleScriptV1_Any = exampleSimpleScriptV1_MofN :: SimpleScript exampleSimpleScriptV1_MofN = - RequireMOf 2 + RequireMOf + 2 [ RequireSignature "2f3d4cf10d0471a1db9f2d2907de867968c27bca6272f062cd1c2413" , RequireSignature "f856c0c5839bab22673747d53f1ae9eed84afafb085f086e8e988614" , RequireSignature "b275b08c999097247f7c17e77007c7010cd19f20cc086ad99d398538" , RequireSignature "686024aecb5884d73a11b9ae4e63931112ba737e878d74638b78513a" ] - exampleSimpleScriptV2_All :: SimpleScript exampleSimpleScriptV2_All = RequireAllOf @@ -80,7 +77,8 @@ exampleSimpleScriptV2_Any = exampleSimpleScriptV2_MofN :: SimpleScript exampleSimpleScriptV2_MofN = - RequireMOf 1 + RequireMOf + 1 [ RequireSignature "2f3d4cf10d0471a1db9f2d2907de867968c27bca6272f062cd1c2413" , RequireSignature "f856c0c5839bab22673747d53f1ae9eed84afafb085f086e8e988614" , RequireTimeBefore (SlotNo 42) diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs index c32d5ffdbe..643ef9d5f4 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs @@ -1,23 +1,28 @@ module Test.Golden.Cardano.Api.Value where -import Cardano.Api (MaryEraOnwards (..), ShelleyBasedEra (..), ValueNestedBundle (..), - ValueNestedRep (..), fromLedgerValue, parseValue, renderValue, renderValuePretty, - valueFromNestedRep, valueToNestedRep) +import Cardano.Api + ( MaryEraOnwards (..) + , ShelleyBasedEra (..) + , ValueNestedBundle (..) + , ValueNestedRep (..) + , fromLedgerValue + , parseValue + , renderValue + , renderValuePretty + , valueFromNestedRep + , valueToNestedRep + ) import qualified Cardano.Api as Api - -import Prelude - -import Data.Aeson (eitherDecode, encode) -import Data.List (groupBy, sort) +import Data.Aeson (eitherDecode, encode) +import Data.List (groupBy, sort) import qualified Data.Map.Strict as Map import qualified Data.Text as Text -import qualified Text.Parsec as Parsec (parse) - -import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep) - -import Hedgehog (Property, forAll, property, tripping, (===)) +import Hedgehog (Property, forAll, property, tripping, (===)) import qualified Hedgehog.Extras as H import qualified Hedgehog.Extras.Test.Golden as H +import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep) +import qualified Text.Parsec as Parsec (parse) +import Prelude {- HLINT ignore "Use let" -} @@ -43,24 +48,25 @@ hprop_roundtrip_Value_parse_renderPretty = renderValuePretty (Parsec.parse parseValue "" . Text.unpack) - hprop_goldenValue_1_lovelace :: Property hprop_goldenValue_1_lovelace = H.propertyOnce $ do valueList <- pure [(Api.AdaAssetId, 1)] - value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList + value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList H.diffVsGoldenFile value "test/cardano-api-golden/files/golden/Cardano/Api/Value/value-ada-1.json" hprop_goldenValue1 :: Property hprop_goldenValue1 = H.propertyOnce $ do - policyId <- pure $ Api.PolicyId "a0000000000000000000000000000000000000000000000000000000" + policyId <- pure $ Api.PolicyId "a0000000000000000000000000000000000000000000000000000000" assetName <- pure $ Api.AssetName "asset1" valueList <- pure [(Api.AssetId policyId assetName, 1)] - value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList + value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList - H.diffVsGoldenFile value "test/cardano-api-golden/files/golden/Cardano/Api/Value/value-asset1-1.json" + H.diffVsGoldenFile + value + "test/cardano-api-golden/files/golden/Cardano/Api/Value/value-asset1-1.json" hprop_roundtrip_Value_JSON :: Property hprop_roundtrip_Value_JSON = @@ -76,43 +82,45 @@ hprop_roundtrip_Value_flatten_unflatten = hprop_roundtrip_Value_unflatten_flatten :: Property hprop_roundtrip_Value_unflatten_flatten = - property $ do - v <- forAll genValueNestedRep - canonicalise v === valueToNestedRep (valueFromNestedRep v) + property $ do + v <- forAll genValueNestedRep + canonicalise v === valueToNestedRep (valueFromNestedRep v) canonicalise :: ValueNestedRep -> ValueNestedRep canonicalise = - ValueNestedRep - . filter (not . isZeroOrEmpty) - . map (filterZeros . foldl1 mergeBundle) - . groupBy samePolicyId - . sort - . (\(ValueNestedRep bundles) -> bundles) - where - samePolicyId ValueNestedBundleAda{} - ValueNestedBundleAda{} = True - samePolicyId (ValueNestedBundle pid _) - (ValueNestedBundle pid' _) = pid == pid' - samePolicyId _ _ = False - - -- Merge together bundles that have already been grouped by same PolicyId: - mergeBundle (ValueNestedBundleAda q) - (ValueNestedBundleAda q') = + ValueNestedRep + . filter (not . isZeroOrEmpty) + . map (filterZeros . foldl1 mergeBundle) + . groupBy samePolicyId + . sort + . (\(ValueNestedRep bundles) -> bundles) + where + samePolicyId + ValueNestedBundleAda {} + ValueNestedBundleAda {} = True + samePolicyId + (ValueNestedBundle pid _) + (ValueNestedBundle pid' _) = pid == pid' + samePolicyId _ _ = False + + -- Merge together bundles that have already been grouped by same PolicyId: + mergeBundle + (ValueNestedBundleAda q) + (ValueNestedBundleAda q') = ValueNestedBundleAda (q <> q') - - mergeBundle (ValueNestedBundle pid as) - (ValueNestedBundle pid' as') | pid == pid' = - ValueNestedBundle pid (Map.unionWith (<>) as as') - - mergeBundle _ _ = error "canonicalise.mergeBundle: impossible" - - filterZeros b@ValueNestedBundleAda{} = b - filterZeros (ValueNestedBundle pid as) = - ValueNestedBundle pid (Map.filter (/=0) as) - - isZeroOrEmpty (ValueNestedBundleAda q) = q == 0 - isZeroOrEmpty (ValueNestedBundle _ as) = Map.null as - + mergeBundle + (ValueNestedBundle pid as) + (ValueNestedBundle pid' as') + | pid == pid' = + ValueNestedBundle pid (Map.unionWith (<>) as as') + mergeBundle _ _ = error "canonicalise.mergeBundle: impossible" + + filterZeros b@ValueNestedBundleAda {} = b + filterZeros (ValueNestedBundle pid as) = + ValueNestedBundle pid (Map.filter (/= 0) as) + + isZeroOrEmpty (ValueNestedBundleAda q) = q == 0 + isZeroOrEmpty (ValueNestedBundle _ as) = Map.null as hprop_roundtrip_AssetName_JSON :: Property hprop_roundtrip_AssetName_JSON = diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index 3379fcb6e7..90ead48a3d 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -1,9 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - {- HLINT ignore "Redundant do" -} - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Test.Golden.ErrorsSpec @@ -28,41 +26,41 @@ module Test.Golden.ErrorsSpec , test_TxBodyErrorAutoBalance , test_TxMetadataJsonError , test_TxMetadataRangeError - ) where - -import Cardano.Api -import Cardano.Api.Shelley + ) +where -import Cardano.Binary as CBOR +import Cardano.Api +import Cardano.Api.Shelley +import Cardano.Binary as CBOR import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Ledger import qualified Cardano.Ledger.Api.Era as Ledger import qualified Cardano.Ledger.Coin as L -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Plutus.Language as Plutus -import qualified PlutusCore.Evaluation.Machine.CostModelInterface as Plutus -import qualified PlutusLedgerApi.Common as Plutus hiding (PlutusV2) - import qualified Codec.Binary.Bech32 as Bech32 -import Control.Error.Util (hush) +import Control.Error.Util (hush) import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS -import Data.Data +import Data.Data import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust) import qualified Data.Set as Set -import Data.Text (Text) -import GHC.Stack (HasCallStack) - +import Data.Text (Text) +import GHC.Stack (HasCallStack) +import qualified PlutusCore.Evaluation.Machine.CostModelInterface as Plutus +import qualified PlutusLedgerApi.Common as Plutus hiding (PlutusV2) import qualified Test.Hedgehog.Golden.ErrorMessage as ErrorMessage -import Test.Tasty +import Test.Tasty seed1 :: ByteString -seed1 = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" +seed1 = + "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" seed2 :: ByteString -seed2 = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001" +seed2 = + "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001" json :: Aeson.Value json = Aeson.String "" @@ -89,7 +87,10 @@ paymentVerKey1 :: VerificationKey PaymentKey paymentVerKey1 = getVerificationKey $ deterministicSigningKey AsPaymentKey (Crypto.mkSeedFromBytes seed1) txid1 :: TxId -txid1 = fromJust $ hush $ deserialiseFromRawBytesHex AsTxId "210c0a4bb6391baf606843e67863d1474cc462374ab12c42d55f78a0b55b56e0" +txid1 = + fromJust $ + hush $ + deserialiseFromRawBytesHex AsTxId "210c0a4bb6391baf606843e67863d1474cc462374ab12c42d55f78a0b55b56e0" txin1 :: TxIn txin1 = TxIn txid1 (TxIx 1) @@ -113,8 +114,11 @@ changeaddr1 :: AddressInEra AllegraEra changeaddr1 = AddressInEra (ShelleyAddressInEra ShelleyBasedEraAllegra) - (makeShelleyAddress Mainnet - (PaymentCredentialByKey (verificationKeyHash paymentVerKey1)) NoStakeAddress) + ( makeShelleyAddress + Mainnet + (PaymentCredentialByKey (verificationKeyHash paymentVerKey1)) + NoStakeAddress + ) txOutValue1 :: TxOutValue AllegraEra txOutValue1 = TxOutValueShelleyBased ShelleyBasedEraAllegra (L.Coin 1) @@ -126,8 +130,12 @@ txOutInAnyEra1 :: TxOutInAnyEra txOutInAnyEra1 = txOutInAnyEra AllegraEra txout1 poolId :: Hash StakePoolKey -poolId = fromJust $ hush $ deserialiseFromRawBytesHex (AsHash AsStakePoolKey) - "9e734b6c2263c0917bfc550e9c949f41afa3fe000377243bd29df399" +poolId = + fromJust $ + hush $ + deserialiseFromRawBytesHex + (AsHash AsStakePoolKey) + "9e734b6c2263c0917bfc550e9c949f41afa3fe000377243bd29df399" test_Bech32DecodeError :: TestTree test_Bech32DecodeError = @@ -164,13 +172,21 @@ test_JsonDecodeError = test_LeadershipError :: TestTree test_LeadershipError = - testAllErrorMessages_ "Cardano.Api.LedgerState" "LeadershipError" + testAllErrorMessages_ + "Cardano.Api.LedgerState" + "LeadershipError" [ ("LeaderErrDecodeLedgerStateFailure", LeaderErrDecodeLedgerStateFailure) - , ("LeaderErrDecodeProtocolStateFailure", LeaderErrDecodeProtocolStateFailure + , + ( "LeaderErrDecodeProtocolStateFailure" + , LeaderErrDecodeProtocolStateFailure ( lazyBytestring , CBOR.DecoderErrorVoid - )) - , ("LeaderErrDecodeProtocolEpochStateFailure", LeaderErrDecodeProtocolEpochStateFailure CBOR.DecoderErrorVoid) + ) + ) + , + ( "LeaderErrDecodeProtocolEpochStateFailure" + , LeaderErrDecodeProtocolEpochStateFailure CBOR.DecoderErrorVoid + ) , ("LeaderErrGenesisSlot", LeaderErrGenesisSlot) , ("LeaderErrStakePoolHasNoStake", LeaderErrStakePoolHasNoStake poolId) , ("LeaderErrStakeDistribUnstable", LeaderErrStakeDistribUnstable 1 2 3 4) @@ -180,26 +196,35 @@ test_LeadershipError = test_OperationalCertIssueError :: TestTree test_OperationalCertIssueError = - testAllErrorMessages_ "Cardano.Api.OperationalCertificate" "OperationalCertIssueError" - [ ("OperationalCertKeyMismatch", OperationalCertKeyMismatch stakePoolVerKey1 stakePoolVerKey2) - ] + testAllErrorMessages_ + "Cardano.Api.OperationalCertificate" + "OperationalCertIssueError" + [ ("OperationalCertKeyMismatch", OperationalCertKeyMismatch stakePoolVerKey1 stakePoolVerKey2) + ] test_ProtocolParametersError :: TestTree test_ProtocolParametersError = - testAllErrorMessages_ "Cardano.Api.ProtocolParameters" "ProtocolParametersError" - [ ("PParamsErrorMissingMinUTxoValue", PParamsErrorMissingMinUTxoValue (AnyCardanoEra ConwayEra)) - , ("PParamsErrorMissingAlonzoProtocolParameter", PParamsErrorMissingAlonzoProtocolParameter) - ] + testAllErrorMessages_ + "Cardano.Api.ProtocolParameters" + "ProtocolParametersError" + [ ("PParamsErrorMissingMinUTxoValue", PParamsErrorMissingMinUTxoValue (AnyCardanoEra ConwayEra)) + , ("PParamsErrorMissingAlonzoProtocolParameter", PParamsErrorMissingAlonzoProtocolParameter) + ] test_RawBytesHexError :: TestTree test_RawBytesHexError = - testAllErrorMessages_ "Cardano.Api.SerialiseRaw" "RawBytesHexError" - [ ("RawBytesHexErrorBase16DecodeFail", RawBytesHexErrorBase16DecodeFail bytestring string) - , ("RawBytesHexErrorRawBytesDecodeFail", RawBytesHexErrorRawBytesDecodeFail + testAllErrorMessages_ + "Cardano.Api.SerialiseRaw" + "RawBytesHexError" + [ ("RawBytesHexErrorBase16DecodeFail", RawBytesHexErrorBase16DecodeFail bytestring string) + , + ( "RawBytesHexErrorRawBytesDecodeFail" + , RawBytesHexErrorRawBytesDecodeFail bytestring (typeRep (AsVerificationKey AsGenesisKey)) - (SerialiseAsRawBytesError string)) - ] + (SerialiseAsRawBytesError string) + ) + ] test_ScriptDataJsonBytesError :: TestTree test_ScriptDataJsonBytesError = @@ -235,15 +260,31 @@ test_ScriptDataRangeError = test_ScriptExecutionError :: TestTree test_ScriptExecutionError = - testAllErrorMessages_ "Cardano.Api.Fees" "ScriptExecutionError" + testAllErrorMessages_ + "Cardano.Api.Fees" + "ScriptExecutionError" [ ("ScriptErrorMissingTxIn", ScriptErrorMissingTxIn txin1) , ("ScriptErrorTxInWithoutDatum", ScriptErrorTxInWithoutDatum txin1) , ("ScriptErrorWrongDatum", ScriptErrorWrongDatum hashScriptData1) - , ("ScriptErrorEvaluationFailed", ScriptErrorEvaluationFailed Plutus.CostModelParameterMismatch (replicate 5 text)) + , + ( "ScriptErrorEvaluationFailed" + , ScriptErrorEvaluationFailed Plutus.CostModelParameterMismatch (replicate 5 text) + ) , ("ScriptErrorExecutionUnitsOverflow", ScriptErrorExecutionUnitsOverflow) - , ("ScriptErrorNotPlutusWitnessedTxIn", ScriptErrorNotPlutusWitnessedTxIn (ScriptWitnessIndexTxIn 0) scriptHash) - , ("ScriptErrorRedeemerPointsToUnknownScriptHash", ScriptErrorRedeemerPointsToUnknownScriptHash (ScriptWitnessIndexTxIn 0)) - , ("ScriptErrorMissingScript", ScriptErrorMissingScript (ScriptWitnessIndexMint 0) (ResolvablePointers ShelleyBasedEraBabbage Map.empty)) -- TODO CIP-1694 make work in all eras + , + ( "ScriptErrorNotPlutusWitnessedTxIn" + , ScriptErrorNotPlutusWitnessedTxIn (ScriptWitnessIndexTxIn 0) scriptHash + ) + , + ( "ScriptErrorRedeemerPointsToUnknownScriptHash" + , ScriptErrorRedeemerPointsToUnknownScriptHash (ScriptWitnessIndexTxIn 0) + ) + , + ( "ScriptErrorMissingScript" + , ScriptErrorMissingScript + (ScriptWitnessIndexMint 0) + (ResolvablePointers ShelleyBasedEraBabbage Map.empty) -- TODO CIP-1694 make work in all eras + ) , ("ScriptErrorMissingCostModel", ScriptErrorMissingCostModel Plutus.PlutusV2) , ("ScriptErrorTranslationError", ScriptErrorTranslationError testPastHorizonValue) ] @@ -279,24 +320,31 @@ testPastHorizonValue = Ledger.TimeTranslationPastHorizon text test_TransactionValidityError :: TestTree test_TransactionValidityError = - testAllErrorMessages_ "Cardano.Api.Fees" "TransactionValidityError" - [ ("TransactionValidityCostModelError", TransactionValidityCostModelError - (Map.fromList [(AnyPlutusScriptVersion PlutusScriptV2, costModel)]) - string) - -- TODO Implement this when we get access to data constructors of PastHorizon or its fields' types' constructors - -- or we get a dummy value for such purposes. - -- - -- , ("TransactionValidityIntervalError", TransactionValidityIntervalError $ - -- Qry.PastHorizon - -- { Qry.pastHorizonCallStack = GHC.callStack - -- , Qry.pastHorizonExpression = error "" -- Some $ Qry.ClosedExpr $ Qry.ELit 0 - -- , Qry.pastHorizonSummary = [] - -- }) + testAllErrorMessages_ + "Cardano.Api.Fees" + "TransactionValidityError" + [ + ( "TransactionValidityCostModelError" + , TransactionValidityCostModelError + (Map.fromList [(AnyPlutusScriptVersion PlutusScriptV2, costModel)]) + string + ) + -- TODO Implement this when we get access to data constructors of PastHorizon or its fields' types' constructors + -- or we get a dummy value for such purposes. + -- + -- , ("TransactionValidityIntervalError", TransactionValidityIntervalError $ + -- Qry.PastHorizon + -- { Qry.pastHorizonCallStack = GHC.callStack + -- , Qry.pastHorizonExpression = error "" -- Some $ Qry.ClosedExpr $ Qry.ELit 0 + -- , Qry.pastHorizonSummary = [] + -- }) ] test_TxBodyError :: TestTree test_TxBodyError = - testAllErrorMessages_ "Cardano.Api.Tx.Body" "TxBodyError" + testAllErrorMessages_ + "Cardano.Api.Tx.Body" + "TxBodyError" [ ("TxBodyEmptyTxIns", TxBodyEmptyTxIns) , ("TxBodyEmptyTxInsCollateral", TxBodyEmptyTxInsCollateral) , ("TxBodyEmptyTxOuts", TxBodyEmptyTxOuts) @@ -310,20 +358,34 @@ test_TxBodyError = test_TxBodyErrorAutoBalance :: TestTree test_TxBodyErrorAutoBalance = - testAllErrorMessages_ "Cardano.Api.Fees" "TxBodyErrorAutoBalance" + testAllErrorMessages_ + "Cardano.Api.Fees" + "TxBodyErrorAutoBalance" [ ("TxBodyError", TxBodyError TxBodyEmptyTxIns) - , ("TxBodyScriptExecutionError", TxBodyScriptExecutionError [(ScriptWitnessIndexTxIn 1, ScriptErrorExecutionUnitsOverflow)]) + , + ( "TxBodyScriptExecutionError" + , TxBodyScriptExecutionError [(ScriptWitnessIndexTxIn 1, ScriptErrorExecutionUnitsOverflow)] + ) , ("TxBodyScriptBadScriptValidity", TxBodyScriptBadScriptValidity) , ("TxBodyErrorAdaBalanceNegative", TxBodyErrorAdaBalanceNegative 1) , ("TxBodyErrorAdaBalanceTooSmall", TxBodyErrorAdaBalanceTooSmall txOutInAnyEra1 0 1) , ("TxBodyErrorByronEraNotSupported", TxBodyErrorByronEraNotSupported) , ("TxBodyErrorMissingParamMinUTxO", TxBodyErrorMissingParamMinUTxO) - , ("TxBodyErrorValidityInterval", TxBodyErrorValidityInterval $ TransactionValidityCostModelError Map.empty string) + , + ( "TxBodyErrorValidityInterval" + , TxBodyErrorValidityInterval $ TransactionValidityCostModelError Map.empty string + ) , ("TxBodyErrorMinUTxONotMet", TxBodyErrorMinUTxONotMet txOutInAnyEra1 1) - , ("TxBodyErrorNonAdaAssetsUnbalanced", TxBodyErrorNonAdaAssetsUnbalanced (valueFromList [(AdaAssetId, Quantity 1)])) - , ("TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap", TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap - (ScriptWitnessIndexTxIn 1) - (Map.fromList [(ScriptWitnessIndexTxIn 2, ExecutionUnits 1 1)])) + , + ( "TxBodyErrorNonAdaAssetsUnbalanced" + , TxBodyErrorNonAdaAssetsUnbalanced (valueFromList [(AdaAssetId, Quantity 1)]) + ) + , + ( "TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap" + , TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap + (ScriptWitnessIndexTxIn 1) + (Map.fromList [(ScriptWitnessIndexTxIn 2, ExecutionUnits 1 1)]) + ) ] test_TxMetadataJsonError :: TestTree @@ -349,9 +411,14 @@ goldenFilesPath = "test/cardano-api-golden/files/golden/errors" testAllErrorMessages :: forall a. (HasCallStack, Data a, Error a) => [a] -> TestTree testAllErrorMessages = ErrorMessage.testAllErrorMessages goldenFilesPath -testAllErrorMessages_ :: forall a. (HasCallStack, Error a) - => String -- ^ module name - -> String -- ^ type name - -> [(String, a)] -- ^ list of constructor names and values - -> TestTree +testAllErrorMessages_ + :: forall a + . (HasCallStack, Error a) + => String + -- ^ module name + -> String + -- ^ type name + -> [(String, a)] + -- ^ list of constructor names and values + -> TestTree testAllErrorMessages_ = ErrorMessage.testAllErrorMessages_ goldenFilesPath diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Crypto.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Crypto.hs index c1a9f1238a..80a886d743 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Crypto.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Crypto.hs @@ -5,7 +5,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Api.Crypto @@ -13,142 +12,158 @@ module Test.Cardano.Api.Crypto ) where -import Cardano.Api.Crypto.Ed25519Bip32 (Ed25519Bip32DSIGN, SignKeyDSIGN (..)) - -import Cardano.Crypto.DSIGN -import Cardano.Crypto.Util (SignableRepresentation (..)) +import Cardano.Api.Crypto.Ed25519Bip32 (Ed25519Bip32DSIGN, SignKeyDSIGN (..)) +import Cardano.Crypto.DSIGN +import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.Wallet as CC - -import Data.Proxy (Proxy (..)) - -import Test.Crypto.Util -import Test.QuickCheck (Arbitrary (..), Gen, Property, (=/=), (===), (==>)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) +import Data.Proxy (Proxy (..)) +import Test.Crypto.Util +import Test.QuickCheck (Arbitrary (..), Gen, Property, (=/=), (===), (==>)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) -- -- The list of all tests -- tests :: TestTree tests = - testGroup "Cardano.Api.Crypto" + testGroup + "Cardano.Api.Crypto" [ testDSIGNAlgorithm (Proxy :: Proxy Ed25519Bip32DSIGN) "Ed25519Bip32DSIGN" ] testDSIGNAlgorithm - :: forall proxy v. ( DSIGNAlgorithm v - , ToCBOR (VerKeyDSIGN v) - , FromCBOR (VerKeyDSIGN v) - , ToCBOR (SignKeyDSIGN v) - , FromCBOR (SignKeyDSIGN v) - , Eq (SignKeyDSIGN v) -- no Eq for signing keys normally - , ToCBOR (SigDSIGN v) - , FromCBOR (SigDSIGN v) - , Signable v ~ SignableRepresentation - , ContextDSIGN v ~ () - ) + :: forall proxy v + . ( DSIGNAlgorithm v + , ToCBOR (VerKeyDSIGN v) + , FromCBOR (VerKeyDSIGN v) + , ToCBOR (SignKeyDSIGN v) + , FromCBOR (SignKeyDSIGN v) + , Eq (SignKeyDSIGN v) -- no Eq for signing keys normally + , ToCBOR (SigDSIGN v) + , FromCBOR (SigDSIGN v) + , Signable v ~ SignableRepresentation + , ContextDSIGN v ~ () + ) => proxy v -> String -> TestTree testDSIGNAlgorithm _ n = - testGroup n - [ testGroup "serialisation" - [ testGroup "raw" - [ testProperty "VerKey" $ prop_raw_serialise @(VerKeyDSIGN v) - rawSerialiseVerKeyDSIGN - rawDeserialiseVerKeyDSIGN - , testProperty "SignKey" $ prop_raw_serialise @(SignKeyDSIGN v) - rawSerialiseSignKeyDSIGN - rawDeserialiseSignKeyDSIGN - , testProperty "Sig" $ prop_raw_serialise @(SigDSIGN v) - rawSerialiseSigDSIGN - rawDeserialiseSigDSIGN - ] - - , testGroup "size" - [ testProperty "VerKey" $ prop_size_serialise @(VerKeyDSIGN v) - rawSerialiseVerKeyDSIGN - (sizeVerKeyDSIGN (Proxy @v)) - , testProperty "SignKey" $ prop_size_serialise @(SignKeyDSIGN v) - rawSerialiseSignKeyDSIGN - (sizeSignKeyDSIGN (Proxy @v)) - , testProperty "Sig" $ prop_size_serialise @(SigDSIGN v) - rawSerialiseSigDSIGN - (sizeSigDSIGN (Proxy @v)) - ] - - , testGroup "direct CBOR" - [ testProperty "VerKey" $ prop_cbor_with @(VerKeyDSIGN v) - encodeVerKeyDSIGN - decodeVerKeyDSIGN - , testProperty "SignKey" $ prop_cbor_with @(SignKeyDSIGN v) - encodeSignKeyDSIGN - decodeSignKeyDSIGN - , testProperty "Sig" $ prop_cbor_with @(SigDSIGN v) - encodeSigDSIGN - decodeSigDSIGN - ] - - , testGroup "To/FromCBOR class" - [ testProperty "VerKey" $ prop_cbor @(VerKeyDSIGN v) - , testProperty "SignKey" $ prop_cbor @(SignKeyDSIGN v) - , testProperty "Sig" $ prop_cbor @(SigDSIGN v) + testGroup + n + [ testGroup + "serialisation" + [ testGroup + "raw" + [ testProperty "VerKey" $ + prop_raw_serialise @(VerKeyDSIGN v) + rawSerialiseVerKeyDSIGN + rawDeserialiseVerKeyDSIGN + , testProperty "SignKey" $ + prop_raw_serialise @(SignKeyDSIGN v) + rawSerialiseSignKeyDSIGN + rawDeserialiseSignKeyDSIGN + , testProperty "Sig" $ + prop_raw_serialise @(SigDSIGN v) + rawSerialiseSigDSIGN + rawDeserialiseSigDSIGN + ] + , testGroup + "size" + [ testProperty "VerKey" $ + prop_size_serialise @(VerKeyDSIGN v) + rawSerialiseVerKeyDSIGN + (sizeVerKeyDSIGN (Proxy @v)) + , testProperty "SignKey" $ + prop_size_serialise @(SignKeyDSIGN v) + rawSerialiseSignKeyDSIGN + (sizeSignKeyDSIGN (Proxy @v)) + , testProperty "Sig" $ + prop_size_serialise @(SigDSIGN v) + rawSerialiseSigDSIGN + (sizeSigDSIGN (Proxy @v)) + ] + , testGroup + "direct CBOR" + [ testProperty "VerKey" $ + prop_cbor_with @(VerKeyDSIGN v) + encodeVerKeyDSIGN + decodeVerKeyDSIGN + , testProperty "SignKey" $ + prop_cbor_with @(SignKeyDSIGN v) + encodeSignKeyDSIGN + decodeSignKeyDSIGN + , testProperty "Sig" $ + prop_cbor_with @(SigDSIGN v) + encodeSigDSIGN + decodeSigDSIGN + ] + , testGroup + "To/FromCBOR class" + [ testProperty "VerKey" $ prop_cbor @(VerKeyDSIGN v) + , testProperty "SignKey" $ prop_cbor @(SignKeyDSIGN v) + , testProperty "Sig" $ prop_cbor @(SigDSIGN v) + ] + , testGroup + "ToCBOR size" + [ testProperty "VerKey" $ prop_cbor_size @(VerKeyDSIGN v) + , testProperty "SignKey" $ prop_cbor_size @(SignKeyDSIGN v) + , testProperty "Sig" $ prop_cbor_size @(SigDSIGN v) + ] + , testGroup + "direct matches class" + [ testProperty "VerKey" $ + prop_cbor_direct_vs_class @(VerKeyDSIGN v) + encodeVerKeyDSIGN + , testProperty "SignKey" $ + prop_cbor_direct_vs_class @(SignKeyDSIGN v) + encodeSignKeyDSIGN + , testProperty "Sig" $ + prop_cbor_direct_vs_class @(SigDSIGN v) + encodeSigDSIGN + ] ] - - , testGroup "ToCBOR size" - [ testProperty "VerKey" $ prop_cbor_size @(VerKeyDSIGN v) - , testProperty "SignKey" $ prop_cbor_size @(SignKeyDSIGN v) - , testProperty "Sig" $ prop_cbor_size @(SigDSIGN v) + , testGroup + "verify" + [ testProperty "verify positive" $ prop_dsign_verify_pos @v + , testProperty "verify negative (wrong key)" $ prop_dsign_verify_neg_key @v + , testProperty "verify negative (wrong message)" $ prop_dsign_verify_neg_msg @v ] - - , testGroup "direct matches class" - [ testProperty "VerKey" $ prop_cbor_direct_vs_class @(VerKeyDSIGN v) - encodeVerKeyDSIGN - , testProperty "SignKey" $ prop_cbor_direct_vs_class @(SignKeyDSIGN v) - encodeSignKeyDSIGN - , testProperty "Sig" $ prop_cbor_direct_vs_class @(SigDSIGN v) - encodeSigDSIGN + , testGroup + "NoUnexpectedThunks" + [ testProperty "VerKey" $ prop_no_thunks @(VerKeyDSIGN v) + , testProperty "SignKey" $ prop_no_thunks @(SignKeyDSIGN v) + , testProperty "Sig" $ prop_no_thunks @(SigDSIGN v) ] - ] - - , testGroup "verify" - [ testProperty "verify positive" $ prop_dsign_verify_pos @v - , testProperty "verify negative (wrong key)" $ prop_dsign_verify_neg_key @v - , testProperty "verify negative (wrong message)" $ prop_dsign_verify_neg_msg @v - ] - - , testGroup "NoUnexpectedThunks" - [ testProperty "VerKey" $ prop_no_thunks @(VerKeyDSIGN v) - , testProperty "SignKey" $ prop_no_thunks @(SignKeyDSIGN v) - , testProperty "Sig" $ prop_no_thunks @(SigDSIGN v) - ] ] - -- | If we sign a message @a@ with the signing key, then we can verify the -- signature using the corresponding verification key. -- -- TODO: Export this from @Test.Crypto.Util@. --- prop_dsign_verify_pos - :: forall v. (DSIGNAlgorithm v, ContextDSIGN v ~ (), Signable v ~ SignableRepresentation) + :: forall v + . (DSIGNAlgorithm v, ContextDSIGN v ~ (), Signable v ~ SignableRepresentation) => Message -> SignKeyDSIGN v -> Property prop_dsign_verify_pos a sk = let sig = signDSIGN () a sk vk = deriveVerKeyDSIGN sk - in verifyDSIGN () vk a sig === Right () + in verifyDSIGN () vk a sig === Right () -- | If we sign a message @a@ with one signing key, if we try to verify the -- signature (and message @a@) using a verification key corresponding to a -- different signing key, then the verification fails. -- -- TODO: Export this from @Test.Crypto.Util@. --- prop_dsign_verify_neg_key - :: forall v. (DSIGNAlgorithm v, Eq (SignKeyDSIGN v), - ContextDSIGN v ~ (), Signable v ~ SignableRepresentation) + :: forall v + . ( DSIGNAlgorithm v + , Eq (SignKeyDSIGN v) + , ContextDSIGN v ~ () + , Signable v ~ SignableRepresentation + ) => Message -> SignKeyDSIGN v -> SignKeyDSIGN v @@ -157,17 +172,18 @@ prop_dsign_verify_neg_key a sk sk' = sk /= sk' ==> let sig = signDSIGN () a sk vk' = deriveVerKeyDSIGN sk' - in verifyDSIGN () vk' a sig =/= Right () - + in verifyDSIGN () vk' a sig =/= Right () -- | If we sign a message @a@ with one signing key, if we try to verify the -- signature with a message other than @a@, then the verification fails. -- -- TODO: Export this from @Test.Crypto.Util@. --- prop_dsign_verify_neg_msg - :: forall v. (DSIGNAlgorithm v, - ContextDSIGN v ~ (), Signable v ~ SignableRepresentation) + :: forall v + . ( DSIGNAlgorithm v + , ContextDSIGN v ~ () + , Signable v ~ SignableRepresentation + ) => Message -> Message -> SignKeyDSIGN v @@ -176,7 +192,7 @@ prop_dsign_verify_neg_msg a a' sk = a /= a' ==> let sig = signDSIGN () a sk vk = deriveVerKeyDSIGN sk - in verifyDSIGN () vk a' sig =/= Right () + in verifyDSIGN () vk a' sig =/= Right () -- -- Arbitrary instances @@ -188,13 +204,17 @@ instance DSIGNAlgorithm v => Arbitrary (VerKeyDSIGN v) where instance DSIGNAlgorithm v => Arbitrary (SignKeyDSIGN v) where arbitrary = genKeyDSIGN <$> arbitrarySeedOfSize seedSize - where - seedSize = seedSizeDSIGN (Proxy :: Proxy v) + where + seedSize = seedSizeDSIGN (Proxy :: Proxy v) shrink = const [] -instance (DSIGNAlgorithm v, - ContextDSIGN v ~ (), Signable v ~ SignableRepresentation) - => Arbitrary (SigDSIGN v) where +instance + ( DSIGNAlgorithm v + , ContextDSIGN v ~ () + , Signable v ~ SignableRepresentation + ) + => Arbitrary (SigDSIGN v) + where arbitrary = signDSIGN () <$> (arbitrary :: Gen Message) <*> arbitrary shrink = const [] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/EpochLeadership.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/EpochLeadership.hs index 4e73d29214..ba01346cbb 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/EpochLeadership.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/EpochLeadership.hs @@ -5,104 +5,143 @@ module Test.Cardano.Api.EpochLeadership ( tests - ) where + ) +where -import Cardano.Api (Key (verificationKeyHash), deterministicSigningKey, - getVerificationKey) -import Cardano.Api.Block (EpochNo (..), Hash (StakePoolKeyHash), SlotNo (..)) -import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) -import Cardano.Api.Genesis (shelleyGenesisDefaults) -import Cardano.Api.GenesisParameters (EpochSize (..)) -import Cardano.Api.Ledger (KeyHash (..), StandardCrypto, toCBOR) -import Cardano.Api.LedgerState (currentEpochEligibleLeadershipSlots) -import Cardano.Api.Modes (ConsensusProtocol) -import Cardano.Api.Query (ProtocolState (..), - SerialisedPoolDistribution (SerialisedPoolDistribution)) -import Cardano.Api.Shelley (Hash (VrfKeyHash), VrfKey, proxyToAsType, unStakePoolKeyHash) - -import Cardano.Binary (ToCBOR, serialize) -import Cardano.Crypto.Seed (mkSeedFromBytes) -import Cardano.Ledger.Api.PParams (emptyPParams) -import Cardano.Ledger.BaseTypes (Nonce (..), WithOrigin (..)) -import Cardano.Ledger.Binary.Encoding (toByronCBOR) +import Cardano.Api + ( Key (verificationKeyHash) + , deterministicSigningKey + , getVerificationKey + ) +import Cardano.Api.Block (EpochNo (..), Hash (StakePoolKeyHash), SlotNo (..)) +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..)) +import Cardano.Api.Genesis (shelleyGenesisDefaults) +import Cardano.Api.GenesisParameters (EpochSize (..)) +import Cardano.Api.Ledger (KeyHash (..), StandardCrypto, toCBOR) +import Cardano.Api.LedgerState (currentEpochEligibleLeadershipSlots) +import Cardano.Api.Modes (ConsensusProtocol) +import Cardano.Api.Query + ( ProtocolState (..) + , SerialisedPoolDistribution (SerialisedPoolDistribution) + ) +import Cardano.Api.Shelley (Hash (VrfKeyHash), VrfKey, proxyToAsType, unStakePoolKeyHash) +import Cardano.Binary (ToCBOR, serialize) +import Cardano.Crypto.Seed (mkSeedFromBytes) +import Cardano.Ledger.Api.PParams (emptyPParams) +import Cardano.Ledger.BaseTypes (Nonce (..), WithOrigin (..)) +import Cardano.Ledger.Binary.Encoding (toByronCBOR) import qualified Cardano.Protocol.TPraos.API as API -import Cardano.Slotting.EpochInfo (EpochInfo (..)) -import Cardano.Slotting.Time (RelativeTime (..), mkSlotLength) -import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus -import Ouroboros.Consensus.Protocol.TPraos (TPraosState (..)) -import Ouroboros.Consensus.Shelley.Ledger.Query.Types (IndividualPoolStake (..), - PoolDistr (..)) -import Ouroboros.Network.Block (Serialised (..)) - +import Cardano.Slotting.EpochInfo (EpochInfo (..)) +import Cardano.Slotting.Time (RelativeTime (..), mkSlotLength) import qualified Data.Map as Map -import Data.Proxy (Proxy (..)) -import Data.Ratio ((%)) +import Data.Proxy (Proxy (..)) +import Data.Ratio ((%)) import qualified Data.Set as Set -import Data.Time.Clock (secondsToNominalDiffTime) - +import Data.Time.Clock (secondsToNominalDiffTime) import qualified Hedgehog as H import qualified Hedgehog.Extras as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus +import Ouroboros.Consensus.Protocol.TPraos (TPraosState (..)) +import Ouroboros.Consensus.Shelley.Ledger.Query.Types + ( IndividualPoolStake (..) + , PoolDistr (..) + ) +import Ouroboros.Network.Block (Serialised (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) -- -- The list of all tests -- tests :: TestTree tests = - testGroup "Epoch Leadership" + testGroup + "Epoch Leadership" [ test_currentEpochEligibleLeadershipSlots ] test_currentEpochEligibleLeadershipSlots :: TestTree test_currentEpochEligibleLeadershipSlots = testProperty "currentEpochEligibleLeadershipSlots happy path" $ - H.propertyOnce $ do - let sbe = ShelleyBasedEraShelley - sGen = shelleyGenesisDefaults - eInfo = EpochInfo { epochInfoSize_ = const (Right (EpochSize 100)) - , epochInfoFirst_ = \(EpochNo x) -> pure $ SlotNo (x * 100) - , epochInfoEpoch_ = \(SlotNo x) -> pure $ EpochNo (x `div` 100) - , epochInfoSlotToRelativeTime_ = \(SlotNo x) -> pure $ RelativeTime (secondsToNominalDiffTime (fromIntegral x * 60)) - , epochInfoSlotLength_ = const (pure $ mkSlotLength 100) - } - pp = emptyPParams - chainDepState = TPraosState Origin (API.initialChainDepState NeutralNonce Map.empty) - ptclState = encodeProtocolState chainDepState - poolid = StakePoolKeyHash { unStakePoolKeyHash = KeyHash "83c5da842d7437e411d3c4db8aaa7a7d2c1642aee932108c9857282d" } - vrskey1 = deterministicSigningKey (proxyToAsType (Proxy :: Proxy VrfKey)) (mkSeedFromBytes "V5UlALekTHL9bIbe3Yb0Kk4T49gn9smf") - VrfKeyHash hash1 = verificationKeyHash $ getVerificationKey vrskey1 - vrskey2 = deterministicSigningKey (proxyToAsType (Proxy :: Proxy VrfKey)) (mkSeedFromBytes "OLjPbWC6JCjSwO4lqUms0EgkinoLoIhz") - VrfKeyHash hash2 = verificationKeyHash $ getVerificationKey vrskey2 - vrskey3 = deterministicSigningKey (proxyToAsType (Proxy :: Proxy VrfKey)) (mkSeedFromBytes "eF0R2dENRrHM8iyb9q7puTw4y2l8e2z4") - VrfKeyHash hash3 = verificationKeyHash $ getVerificationKey vrskey3 - poolDistr :: PoolDistr StandardCrypto = PoolDistr $ - Map.fromList [ ( KeyHash "a2927c1e43974b036d8e6838d410279266946e8a094895cfc748c91d" - , IndividualPoolStake { individualPoolStake = 1 % 3 - , individualPoolStakeVrf = hash1 - } - ) - , ( KeyHash "83c5da842d7437e411d3c4db8aaa7a7d2c1642aee932108c9857282d" - , IndividualPoolStake { individualPoolStake = 1 % 3 - , individualPoolStakeVrf = hash2 - } - ) - , ( KeyHash "362c2c2128ee75ca39690c27b42e809301231098003443669e2b03f3" - , IndividualPoolStake { individualPoolStake = 1 % 3 - , individualPoolStakeVrf = hash3 - } - ) - ] - serPoolDistr = SerialisedPoolDistribution (Serialised (serialize (toByronCBOR poolDistr))) - currentEpoch = EpochNo 4 - eEligibleSlots = currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid vrskey1 serPoolDistr currentEpoch - expectedEligibleSlots = [ SlotNo 406, SlotNo 432, SlotNo 437, SlotNo 443, SlotNo 484 ] - eligibleSlots <- H.evalEither eEligibleSlots - eligibleSlots H.=== Set.fromList expectedEligibleSlots - where + H.propertyOnce $ do + let sbe = ShelleyBasedEraShelley + sGen = shelleyGenesisDefaults + eInfo = + EpochInfo + { epochInfoSize_ = const (Right (EpochSize 100)) + , epochInfoFirst_ = \(EpochNo x) -> pure $ SlotNo (x * 100) + , epochInfoEpoch_ = \(SlotNo x) -> pure $ EpochNo (x `div` 100) + , epochInfoSlotToRelativeTime_ = \(SlotNo x) -> pure $ RelativeTime (secondsToNominalDiffTime (fromIntegral x * 60)) + , epochInfoSlotLength_ = const (pure $ mkSlotLength 100) + } + pp = emptyPParams + chainDepState = TPraosState Origin (API.initialChainDepState NeutralNonce Map.empty) + ptclState = encodeProtocolState chainDepState + poolid = + StakePoolKeyHash + { unStakePoolKeyHash = KeyHash "83c5da842d7437e411d3c4db8aaa7a7d2c1642aee932108c9857282d" + } + vrskey1 = + deterministicSigningKey + (proxyToAsType (Proxy :: Proxy VrfKey)) + (mkSeedFromBytes "V5UlALekTHL9bIbe3Yb0Kk4T49gn9smf") + VrfKeyHash hash1 = verificationKeyHash $ getVerificationKey vrskey1 + vrskey2 = + deterministicSigningKey + (proxyToAsType (Proxy :: Proxy VrfKey)) + (mkSeedFromBytes "OLjPbWC6JCjSwO4lqUms0EgkinoLoIhz") + VrfKeyHash hash2 = verificationKeyHash $ getVerificationKey vrskey2 + vrskey3 = + deterministicSigningKey + (proxyToAsType (Proxy :: Proxy VrfKey)) + (mkSeedFromBytes "eF0R2dENRrHM8iyb9q7puTw4y2l8e2z4") + VrfKeyHash hash3 = verificationKeyHash $ getVerificationKey vrskey3 + poolDistr :: PoolDistr StandardCrypto = + PoolDistr $ + Map.fromList + [ + ( KeyHash "a2927c1e43974b036d8e6838d410279266946e8a094895cfc748c91d" + , IndividualPoolStake + { individualPoolStake = 1 % 3 + , individualPoolStakeVrf = hash1 + } + ) + , + ( KeyHash "83c5da842d7437e411d3c4db8aaa7a7d2c1642aee932108c9857282d" + , IndividualPoolStake + { individualPoolStake = 1 % 3 + , individualPoolStakeVrf = hash2 + } + ) + , + ( KeyHash "362c2c2128ee75ca39690c27b42e809301231098003443669e2b03f3" + , IndividualPoolStake + { individualPoolStake = 1 % 3 + , individualPoolStakeVrf = hash3 + } + ) + ] + serPoolDistr = SerialisedPoolDistribution (Serialised (serialize (toByronCBOR poolDistr))) + currentEpoch = EpochNo 4 + eEligibleSlots = + currentEpochEligibleLeadershipSlots + sbe + sGen + eInfo + pp + ptclState + poolid + vrskey1 + serPoolDistr + currentEpoch + expectedEligibleSlots = [SlotNo 406, SlotNo 432, SlotNo 437, SlotNo 443, SlotNo 484] + eligibleSlots <- H.evalEither eEligibleSlots + eligibleSlots H.=== Set.fromList expectedEligibleSlots + where encodeProtocolState :: ToCBOR (Consensus.ChainDepState (ConsensusProtocol era)) => Consensus.ChainDepState (ConsensusProtocol era) -> ProtocolState era encodeProtocolState cds = ProtocolState (Serialised pbs) - where pbs = serialize (toCBOR cds) + where + pbs = serialize (toCBOR cds) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs index f12610a875..ecd05f9bd6 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs @@ -2,18 +2,17 @@ module Test.Cardano.Api.Eras ( tests - ) where + ) +where -import Cardano.Api -import Cardano.Api.Orphans () - -import Data.Aeson (ToJSON (..), decode, encode) - -import Hedgehog (Property, forAll, property, (===)) +import Cardano.Api +import Cardano.Api.Orphans () +import Data.Aeson (ToJSON (..), decode, encode) +import Hedgehog (Property, forAll, property, (===)) import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) -------------------------------------------------------------------------------- -- Bounded instances @@ -30,26 +29,28 @@ prop_maxBound_CardanoMatchesShelley = property $ do prop_roundtrip_JSON_Shelley :: Property prop_roundtrip_JSON_Shelley = property $ do - anySbe <- forAll $ Gen.element $ id @[AnyShelleyBasedEra] [minBound..maxBound] + anySbe <- forAll $ Gen.element $ id @[AnyShelleyBasedEra] [minBound .. maxBound] H.tripping anySbe encode decode prop_roundtrip_JSON_Cardano :: Property prop_roundtrip_JSON_Cardano = property $ do - anyEra <- forAll $ Gen.element $ id @[AnyCardanoEra] [minBound..maxBound] + anyEra <- forAll $ Gen.element $ id @[AnyCardanoEra] [minBound .. maxBound] H.tripping anyEra encode decode prop_toJSON_CardanoMatchesShelley :: Property prop_toJSON_CardanoMatchesShelley = property $ do - AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound .. maxBound] toJSON (AnyShelleyBasedEra sbe) === toJSON (anyCardanoEra (toCardanoEra sbe)) tests :: TestTree -tests = testGroup "Test.Cardano.Api.Json" - [ testProperty "maxBound cardano matches shelley" prop_maxBound_CardanoMatchesShelley - , testProperty "roundtrip JSON shelley" prop_roundtrip_JSON_Shelley - , testProperty "roundtrip JSON cardano" prop_roundtrip_JSON_Cardano - , testProperty "toJSON cardano matches shelley" prop_toJSON_CardanoMatchesShelley - ] +tests = + testGroup + "Test.Cardano.Api.Json" + [ testProperty "maxBound cardano matches shelley" prop_maxBound_CardanoMatchesShelley + , testProperty "roundtrip JSON shelley" prop_roundtrip_JSON_Shelley + , testProperty "roundtrip JSON cardano" prop_roundtrip_JSON_Cardano + , testProperty "toJSON cardano matches shelley" prop_toJSON_CardanoMatchesShelley + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/IO.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/IO.hs index 3b67dcb02f..dd49814c4e 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/IO.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/IO.hs @@ -2,18 +2,17 @@ module Test.Cardano.Api.IO ( tests - ) where + ) +where -import Cardano.Api -import Cardano.Api.IO - -import System.Directory (removeFile) - -import Hedgehog +import Cardano.Api +import Cardano.Api.IO +import Hedgehog import qualified Hedgehog.Extras as H -import Hedgehog.Internal.Property -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog +import Hedgehog.Internal.Property +import System.Directory (removeFile) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog prop_createVrfFileWithOwnerPermissions :: Property prop_createVrfFileWithOwnerPermissions = @@ -33,6 +32,8 @@ prop_createVrfFileWithOwnerPermissions = Right () -> liftIO (removeFile file) >> success tests :: TestTree -tests = testGroup "Test.Cardano.Api.IO" - [ testProperty "Create VRF File with Owner Permissions" prop_createVrfFileWithOwnerPermissions - ] +tests = + testGroup + "Test.Cardano.Api.IO" + [ testProperty "Create VRF File with Owner Permissions" prop_createVrfFileWithOwnerPermissions + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index 740a5f19cc..11a7408f9e 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -3,20 +3,18 @@ module Test.Cardano.Api.Json ( tests - ) where + ) +where -import Cardano.Api.Orphans () -import Cardano.Api.Shelley - -import Data.Aeson (eitherDecode, encode) - -import Test.Gen.Cardano.Api (genAlonzoGenesis) -import Test.Gen.Cardano.Api.Typed - -import Hedgehog (Property, forAll, tripping) +import Cardano.Api.Orphans () +import Cardano.Api.Shelley +import Data.Aeson (eitherDecode, encode) +import Hedgehog (Property, forAll, tripping) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Gen.Cardano.Api (genAlonzoGenesis) +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -56,12 +54,14 @@ prop_json_roundtrip_scriptdata_detailed_json = H.property $ do tripping sData scriptDataToJsonDetailedSchema scriptDataFromJsonDetailedSchema tests :: TestTree -tests = testGroup "Test.Cardano.Api.Json" - [ testProperty "json roundtrip alonzo genesis" prop_json_roundtrip_alonzo_genesis - , testProperty "json roundtrip utxo" prop_json_roundtrip_utxo - , testProperty "json roundtrip reference scripts" prop_json_roundtrip_reference_scripts - , testProperty "json roundtrip txoutvalue" prop_json_roundtrip_txoutvalue - , testProperty "json roundtrip txout tx context" prop_json_roundtrip_txout_tx_context - , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context - , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json - ] +tests = + testGroup + "Test.Cardano.Api.Json" + [ testProperty "json roundtrip alonzo genesis" prop_json_roundtrip_alonzo_genesis + , testProperty "json roundtrip utxo" prop_json_roundtrip_utxo + , testProperty "json roundtrip reference scripts" prop_json_roundtrip_reference_scripts + , testProperty "json roundtrip txoutvalue" prop_json_roundtrip_txoutvalue + , testProperty "json roundtrip txout tx context" prop_json_roundtrip_txout_tx_context + , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context + , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs index b62323fa56..50f93526ea 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs @@ -2,18 +2,17 @@ module Test.Cardano.Api.KeysByron ( tests - ) where + ) +where -import Cardano.Api (AsType (AsByronKey, AsSigningKey), Key (deterministicSigningKey)) - -import Test.Cardano.Api.Typed.Orphans () -import qualified Test.Gen.Cardano.Crypto.Seed as Gen - -import Hedgehog (Property) +import Cardano.Api (AsType (AsByronKey, AsSigningKey), Key (deterministicSigningKey)) +import Hedgehog (Property) import qualified Hedgehog as H -import Test.Hedgehog.Roundtrip.CBOR (trippingCbor) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import qualified Test.Gen.Cardano.Crypto.Seed as Gen +import Test.Hedgehog.Roundtrip.CBOR (trippingCbor) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -23,6 +22,8 @@ prop_roundtrip_byron_key_CBOR = H.property $ do trippingCbor (AsSigningKey AsByronKey) seed tests :: TestTree -tests = testGroup "Test.Cardano.Api.KeysByron" - [ testProperty "roundtrip byron key CBOR" prop_roundtrip_byron_key_CBOR - ] +tests = + testGroup + "Test.Cardano.Api.KeysByron" + [ testProperty "roundtrip byron key CBOR" prop_roundtrip_byron_key_CBOR + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs index 7024d035f4..b2ceb9ce49 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs @@ -3,27 +3,23 @@ module Test.Cardano.Api.Ledger ( tests - ) where - -import Cardano.Api -import Cardano.Api.Shelley + ) +where +import Cardano.Api +import Cardano.Api.Shelley import qualified Cardano.Ledger.Api as L -import Cardano.Ledger.Api.Tx.Address -import Cardano.Ledger.Crypto -import Cardano.Ledger.SafeHash - -import Control.Monad.Identity - -import Test.Gen.Cardano.Api.Typed - -import Test.Cardano.Ledger.Core.Arbitrary () - +import Cardano.Ledger.Api.Tx.Address +import Cardano.Ledger.Crypto +import Cardano.Ledger.SafeHash +import Control.Monad.Identity import qualified Hedgehog as H -import Hedgehog.Gen.QuickCheck (arbitrary) -import Hedgehog.Internal.Property -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Hedgehog.Gen.QuickCheck (arbitrary) +import Hedgehog.Internal.Property +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) -- Keep this here to make sure serialiseAddr/deserialiseAddr are working. -- They are defined in the Shelley executable spec and have been wrong at @@ -65,8 +61,10 @@ prop_roundtrip_scriptdata_plutusdata = H.property $ do -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Ledger" - [ testProperty "roundtrip Address CBOR" prop_roundtrip_Address_CBOR - , testProperty "roundtrip ScriptData" prop_roundtrip_scriptdata_plutusdata - , testProperty "script data bytes preserved" prop_original_scriptdata_bytes_preserved - ] +tests = + testGroup + "Test.Cardano.Api.Ledger" + [ testProperty "roundtrip Address CBOR" prop_roundtrip_Address_CBOR + , testProperty "roundtrip ScriptData" prop_roundtrip_scriptdata_plutusdata + , testProperty "script data bytes preserved" prop_original_scriptdata_bytes_preserved + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Metadata.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Metadata.hs index 4e64212ee5..6c695fc794 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Metadata.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Metadata.hs @@ -6,74 +6,92 @@ module Test.Cardano.Api.Metadata ( tests , genTxMetadata , genTxMetadataValue - ) where - -import Cardano.Api + ) +where +import Cardano.Api import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import Data.Word (Word64) -import GHC.Stack -import Text.InterpolatedString.Perl6 - -import Test.Gen.Cardano.Api.Metadata - -import Hedgehog (Gen, Property, (===)) +import Data.Maybe (mapMaybe) +import Data.Word (Word64) +import GHC.Stack +import Hedgehog (Gen, Property, (===)) import qualified Hedgehog as H import qualified Hedgehog.Extras as H import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Gen.Cardano.Api.Metadata +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) +import Text.InterpolatedString.Perl6 -- ---------------------------------------------------------------------------- -- Golden / unit tests -- prop_golden_1 :: Property -prop_golden_1 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": 1}|] - (TxMetadata (Map.fromList [(0, TxMetaNumber 1)])) +prop_golden_1 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": 1}|] + (TxMetadata (Map.fromList [(0, TxMetaNumber 1)])) prop_golden_2 :: Property -prop_golden_2 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": "deadbeef"}|] - (txMetadataSingleton 0 (TxMetaText "deadbeef")) +prop_golden_2 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": "deadbeef"}|] + (txMetadataSingleton 0 (TxMetaText "deadbeef")) prop_golden_3 :: Property -prop_golden_3 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": "0xDEADBEEF"}|] - (txMetadataSingleton 0 (TxMetaText "0xDEADBEEF")) +prop_golden_3 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": "0xDEADBEEF"}|] + (txMetadataSingleton 0 (TxMetaText "0xDEADBEEF")) prop_golden_4 :: Property -prop_golden_4 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": "0xdeadbeef"}|] - (txMetadataSingleton 0 (TxMetaBytes "\xde\xad\xbe\xef")) +prop_golden_4 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": "0xdeadbeef"}|] + (txMetadataSingleton 0 (TxMetaBytes "\xde\xad\xbe\xef")) prop_golden_5 :: Property -prop_golden_5 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": [] }|] - (txMetadataSingleton 0 (TxMetaList [])) +prop_golden_5 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": [] }|] + (txMetadataSingleton 0 (TxMetaList [])) prop_golden_6 :: Property -prop_golden_6 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": [1, "a", "0x42"] }|] - (txMetadataSingleton 0 - (TxMetaList [TxMetaNumber 1 - ,TxMetaText "a" - ,TxMetaBytes "\x42"])) +prop_golden_6 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": [1, "a", "0x42"] }|] + ( txMetadataSingleton + 0 + ( TxMetaList + [ TxMetaNumber 1 + , TxMetaText "a" + , TxMetaBytes "\x42" + ] + ) + ) prop_golden_7 :: Property -prop_golden_7 = matchMetadata TxMetadataJsonNoSchema - [q|{"0": {} }|] - (txMetadataSingleton 0 (TxMetaMap [])) +prop_golden_7 = + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": {} }|] + (txMetadataSingleton 0 (TxMetaMap [])) prop_golden_8 :: Property prop_golden_8 = - matchMetadata TxMetadataJsonNoSchema - [q|{"0": { + matchMetadata + TxMetadataJsonNoSchema + [q|{"0": { "0x41": "0x42", "0x154041": "0x44", "0x104041": "0x43", @@ -99,41 +117,45 @@ prop_golden_8 = "ab": "ba" } }}|] - ( txMetadataSingleton 0 - ( TxMetaMap - [ ( TxMetaNumber 1 , TxMetaNumber 2 ) - , ( TxMetaNumber 11 , TxMetaNumber 3 ) - , ( TxMetaBytes "A" , TxMetaBytes "B" ) - , ( TxMetaText "a" , TxMetaText "b" ) - , ( TxMetaBytes "0A" , TxMetaBytes "E" ) - , ( TxMetaText "aa" , TxMetaText "bb" ) - , ( TxMetaText "ab" , TxMetaText "ba" ) - , ( TxMetaBytes "\DLE@A" , TxMetaBytes "C" ) - , ( TxMetaBytes "\NAK@A" , TxMetaBytes "D" ) - , ( TxMetaText "aab" , TxMetaText "ba" ) - , ( TxMetaText "aba" - , TxMetaMap - [ ( TxMetaNumber 1 , TxMetaNumber 2 ) - , ( TxMetaNumber 11 , TxMetaNumber 3 ) - , ( TxMetaBytes "A" , TxMetaBytes "B" ) - , ( TxMetaText "a" , TxMetaText "b" ) - , ( TxMetaBytes "0A" , TxMetaBytes "E" ) - , ( TxMetaText "aa" , TxMetaText "bb" ) - , ( TxMetaText "ab" , TxMetaText "ba" ) - , ( TxMetaBytes "\DLE@A" , TxMetaBytes "C" ) - , ( TxMetaBytes "\NAK@A" , TxMetaBytes "D" ) - , ( TxMetaText "aab" , TxMetaText "ba" ) - , ( TxMetaText "abb" , TxMetaText "ba" ) - ] + ( txMetadataSingleton + 0 + ( TxMetaMap + [ (TxMetaNumber 1, TxMetaNumber 2) + , (TxMetaNumber 11, TxMetaNumber 3) + , (TxMetaBytes "A", TxMetaBytes "B") + , (TxMetaText "a", TxMetaText "b") + , (TxMetaBytes "0A", TxMetaBytes "E") + , (TxMetaText "aa", TxMetaText "bb") + , (TxMetaText "ab", TxMetaText "ba") + , (TxMetaBytes "\DLE@A", TxMetaBytes "C") + , (TxMetaBytes "\NAK@A", TxMetaBytes "D") + , (TxMetaText "aab", TxMetaText "ba") + , + ( TxMetaText "aba" + , TxMetaMap + [ (TxMetaNumber 1, TxMetaNumber 2) + , (TxMetaNumber 11, TxMetaNumber 3) + , (TxMetaBytes "A", TxMetaBytes "B") + , (TxMetaText "a", TxMetaText "b") + , (TxMetaBytes "0A", TxMetaBytes "E") + , (TxMetaText "aa", TxMetaText "bb") + , (TxMetaText "ab", TxMetaText "ba") + , (TxMetaBytes "\DLE@A", TxMetaBytes "C") + , (TxMetaBytes "\NAK@A", TxMetaBytes "D") + , (TxMetaText "aab", TxMetaText "ba") + , (TxMetaText "abb", TxMetaText "ba") + ] + ) + , (TxMetaText "abb", TxMetaText "ba") + ] ) - , ( TxMetaText "abb" , TxMetaText "ba" ) - ] - )) + ) prop_golden_9 :: Property prop_golden_9 = - matchMetadata TxMetadataJsonDetailedSchema - [q|{"0": + matchMetadata + TxMetadataJsonDetailedSchema + [q|{"0": {"map": [ { "k": {"string": "aaa"} , "v": {"string": "b4"} @@ -155,25 +177,30 @@ prop_golden_9 = } ] }}|] - ( txMetadataSingleton 0 - ( TxMetaMap - [ ( TxMetaText "aaa" , TxMetaText "b4" ) - , ( TxMetaNumber 1 , TxMetaText "b6" ) - , ( TxMetaText "aa" , TxMetaText "b2" ) - , ( TxMetaText "ab" , TxMetaText "b3" ) - , ( TxMetaText "b" , TxMetaText "b5" ) - , ( TxMetaText "a" , TxMetaText "b1" ) - ] - )) + ( txMetadataSingleton + 0 + ( TxMetaMap + [ (TxMetaText "aaa", TxMetaText "b4") + , (TxMetaNumber 1, TxMetaText "b6") + , (TxMetaText "aa", TxMetaText "b2") + , (TxMetaText "ab", TxMetaText "b3") + , (TxMetaText "b", TxMetaText "b5") + , (TxMetaText "a", TxMetaText "b1") + ] + ) + ) txMetadataSingleton :: Word64 -> TxMetadataValue -> TxMetadata txMetadataSingleton n v = TxMetadata (Map.fromList [(n, v)]) -matchMetadata :: HasCallStack - => TxMetadataJsonSchema - -> ByteString -- ^ json string to test - -> TxMetadata -- ^ expected metadata - -> Property +matchMetadata + :: HasCallStack + => TxMetadataJsonSchema + -> ByteString + -- ^ json string to test + -> TxMetadata + -- ^ expected metadata + -> Property matchMetadata hasSchema jsonStr expectedMetadata = withFrozenCallStack $ H.propertyOnce $ do json <- H.noteShowM . H.nothingFail $ Aeson.decodeStrict' jsonStr metadata <- H.noteShowM . H.leftFail $ metadataFromJson hasSchema json @@ -189,31 +216,36 @@ matchMetadata hasSchema jsonStr expectedMetadata = withFrozenCallStack $ H.prope -- This uses the \"no schema\" mapping. Note that with this mapping it is /not/ -- the case that any tx metadata can be converted to JSON and back to give the -- original value. --- prop_noschema_json_roundtrip_via_metadata :: Property prop_noschema_json_roundtrip_via_metadata = H.property $ do - json <- H.forAll (genJsonForTxMetadata TxMetadataJsonNoSchema) - Right json === (fmap (metadataToJson TxMetadataJsonNoSchema) - . metadataFromJson TxMetadataJsonNoSchema) json + json <- H.forAll (genJsonForTxMetadata TxMetadataJsonNoSchema) + Right json + === ( fmap (metadataToJson TxMetadataJsonNoSchema) + . metadataFromJson TxMetadataJsonNoSchema + ) + json -- | Any JSON (fitting the detailed schema) can be converted to tx metadata and -- back, to give the same original JSON. --- prop_schema_json_roundtrip_via_metadata :: Property prop_schema_json_roundtrip_via_metadata = H.property $ do - json <- H.forAll (genJsonForTxMetadata TxMetadataJsonDetailedSchema) - Right json === (fmap (metadataToJson TxMetadataJsonDetailedSchema) - . metadataFromJson TxMetadataJsonDetailedSchema) json - + json <- H.forAll (genJsonForTxMetadata TxMetadataJsonDetailedSchema) + Right json + === ( fmap (metadataToJson TxMetadataJsonDetailedSchema) + . metadataFromJson TxMetadataJsonDetailedSchema + ) + json -- | Any tx metadata can be converted to JSON (using the detailed schema) and -- back, to give the same original tx metadata. --- prop_metadata_roundtrip_via_schema_json :: Property prop_metadata_roundtrip_via_schema_json = H.property $ do - md <- H.forAll genTxMetadata - Right md === (metadataFromJson TxMetadataJsonDetailedSchema - . metadataToJson TxMetadataJsonDetailedSchema) md + md <- H.forAll genTxMetadata + Right md + === ( metadataFromJson TxMetadataJsonDetailedSchema + . metadataToJson TxMetadataJsonDetailedSchema + ) + md prop_metadata_chunks :: (Show str, Eq str, Monoid str) @@ -225,9 +257,9 @@ prop_metadata_chunks genStr toMetadataValue extractChunk = H.property $ do str <- H.forAll genStr case toMetadataValue str of metadataValue@(TxMetaList chunks) -> do - H.cover 1 "Empty chunks" (null chunks) - H.cover 5 "Single chunks" (length chunks == 1) - H.cover 25 "Many chunks" (length chunks > 1) + H.cover 1 "Empty chunks" (null chunks) + H.cover 5 "Single chunks" (length chunks == 1) + H.cover 25 "Many chunks" (length chunks > 1) str === mconcat (mapMaybe extractChunk chunks) Right () === validateTxMetadata metadata where @@ -240,9 +272,9 @@ prop_metadata_text_chunks = prop_metadata_chunks (Gen.text (Range.linear 0 255) Gen.unicodeAll) metaTextChunks - (\case - TxMetaText chunk -> Just chunk - _ -> Nothing + ( \case + TxMetaText chunk -> Just chunk + _ -> Nothing ) prop_metadata_bytes_chunks :: Property @@ -250,9 +282,9 @@ prop_metadata_bytes_chunks = prop_metadata_chunks (Gen.bytes (Range.linear 0 255)) metaBytesChunks - (\case - TxMetaBytes chunk -> Just chunk - _ -> Nothing + ( \case + TxMetaBytes chunk -> Just chunk + _ -> Nothing ) -- ---------------------------------------------------------------------------- @@ -260,19 +292,21 @@ prop_metadata_bytes_chunks = -- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Metadata" - [ testProperty "golden 1" prop_golden_1 - , testProperty "golden 2" prop_golden_2 - , testProperty "golden 3" prop_golden_3 - , testProperty "golden 4" prop_golden_4 - , testProperty "golden 5" prop_golden_5 - , testProperty "golden 6" prop_golden_6 - , testProperty "golden 7" prop_golden_7 - , testProperty "golden 8" prop_golden_8 - , testProperty "golden 9" prop_golden_9 - , testProperty "noschema json roundtrip via metadata" prop_noschema_json_roundtrip_via_metadata - , testProperty "schema json roundtrip via metadata" prop_schema_json_roundtrip_via_metadata - , testProperty "metadata roundtrip via schema json" prop_metadata_roundtrip_via_schema_json - , testProperty "valid & rountrip text chunks" prop_metadata_text_chunks - , testProperty "valid & rountrip bytes chunks" prop_metadata_bytes_chunks - ] +tests = + testGroup + "Test.Cardano.Api.Metadata" + [ testProperty "golden 1" prop_golden_1 + , testProperty "golden 2" prop_golden_2 + , testProperty "golden 3" prop_golden_3 + , testProperty "golden 4" prop_golden_4 + , testProperty "golden 5" prop_golden_5 + , testProperty "golden 6" prop_golden_6 + , testProperty "golden 7" prop_golden_7 + , testProperty "golden 8" prop_golden_8 + , testProperty "golden 9" prop_golden_9 + , testProperty "noschema json roundtrip via metadata" prop_noschema_json_roundtrip_via_metadata + , testProperty "schema json roundtrip via metadata" prop_schema_json_roundtrip_via_metadata + , testProperty "metadata roundtrip via schema json" prop_metadata_roundtrip_via_schema_json + , testProperty "valid & rountrip text chunks" prop_metadata_text_chunks + , testProperty "valid & rountrip bytes chunks" prop_metadata_bytes_chunks + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs index f93a1ec447..d459464f65 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs @@ -2,34 +2,38 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - -- TODO remove me when ProtocolParameters is deleted {-# OPTIONS_GHC -Wno-deprecations #-} module Test.Cardano.Api.ProtocolParameters ( tests - ) where - -import Cardano.Api (CardanoEra (..), ProtocolParametersConversionError, inEonForEra, - prettyPrintJSON) -import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) -import Cardano.Api.Ledger (PParams (..)) -import Cardano.Api.ProtocolParameters (LedgerProtocolParameters (..), - convertToLedgerProtocolParameters, fromLedgerPParams) - -import Control.Monad (void) -import Data.Aeson (FromJSON, Object, ToJSON, eitherDecode) + ) +where + +import Cardano.Api + ( CardanoEra (..) + , ProtocolParametersConversionError + , inEonForEra + , prettyPrintJSON + ) +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) +import Cardano.Api.Ledger (PParams (..)) +import Cardano.Api.ProtocolParameters + ( LedgerProtocolParameters (..) + , convertToLedgerProtocolParameters + , fromLedgerPParams + ) +import Control.Monad (void) +import Data.Aeson (FromJSON, Object, ToJSON, eitherDecode) import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as Aeson import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (foldl') - -import Test.Gen.Cardano.Api.Typed (genProtocolParameters) - -import Hedgehog (Gen, MonadTest, Property, forAll, property, success, (===)) -import Hedgehog.Extras (leftFail) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Data.Foldable (foldl') +import Hedgehog (Gen, MonadTest, Property, forAll, property, success, (===)) +import Hedgehog.Extras (leftFail) +import Test.Gen.Cardano.Api.Typed (genProtocolParameters) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) -- Originally, cardano-api used a different type than cardano-ledger to represent -- protocol parameters. From conway on, we aim to unify those types and use PParams. @@ -38,60 +42,85 @@ import Test.Tasty.Hedgehog (testProperty) -- provide any tests for it. tests :: TestTree tests = - testGroup "ProtocolParameter tests" - [ testGroup "ToJSON instances produce the same" - [ testProperty "ShelleyEra" $ protocolParametersSerializeTheSame ShelleyEra - , testProperty "AlonzoEra" $ protocolParametersSerializeTheSame AlonzoEra - , testProperty "BabbageEra" $ protocolParametersSerializeTheSame BabbageEra - ] - , testGroup "ProtocolParameters ToJSON can be read by PParams FromJSON" - [ testProperty "ShelleyEra" $ protocolParametersAreCompatible ShelleyEra - , testProperty "AlonzoEra" $ protocolParametersAreCompatible AlonzoEra - , testProperty "BabbageEra" $ protocolParametersAreCompatible BabbageEra - ] - , testGroup "PParams roundtrip" - [ testProperty "ShelleyEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters ShelleyEra - , testProperty "AlonzoEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters AlonzoEra - , testProperty "BabbageEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters BabbageEra - ] - ] + testGroup + "ProtocolParameter tests" + [ testGroup + "ToJSON instances produce the same" + [ testProperty "ShelleyEra" $ protocolParametersSerializeTheSame ShelleyEra + , testProperty "AlonzoEra" $ protocolParametersSerializeTheSame AlonzoEra + , testProperty "BabbageEra" $ protocolParametersSerializeTheSame BabbageEra + ] + , testGroup + "ProtocolParameters ToJSON can be read by PParams FromJSON" + [ testProperty "ShelleyEra" $ protocolParametersAreCompatible ShelleyEra + , testProperty "AlonzoEra" $ protocolParametersAreCompatible AlonzoEra + , testProperty "BabbageEra" $ protocolParametersAreCompatible BabbageEra + ] + , testGroup + "PParams roundtrip" + [ testProperty "ShelleyEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters ShelleyEra + , testProperty "AlonzoEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters AlonzoEra + , testProperty "BabbageEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters BabbageEra + ] + ] -- | Compares the JSON serialization of cardano-ledger's PParams and cardano-api's ProtocolParameters and -- | ensures that they are the same (except for the agreed changes specified in `patchProtocolParamsJSONOrFail`) -protocolParametersSerializeTheSame :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Property +protocolParametersSerializeTheSame + :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Property protocolParametersSerializeTheSame era = - property $ do ValidatedSerializedPair { serializedProtocolParameters - , serializedPParams - } <- forAll $ genValidSerializedPair era - patchedserializedProtocolParameters <- patchProtocolParamsJSONOrFail era serializedProtocolParameters - serializedPParams === patchedserializedProtocolParameters + property $ do + ValidatedSerializedPair + { serializedProtocolParameters + , serializedPParams + } <- + forAll $ genValidSerializedPair era + patchedserializedProtocolParameters <- + patchProtocolParamsJSONOrFail era serializedProtocolParameters + serializedPParams === patchedserializedProtocolParameters -- | Ensure that cardano-api's legacy ProtocolParameter serialization can be deserialized by cardano-ledger's PParams FromJSON instance -protocolParametersAreCompatible :: forall era. ( ToJSON (PParams (ShelleyLedgerEra era)) - , FromJSON (PParams (ShelleyLedgerEra era)) - ) => CardanoEra era -> Property +protocolParametersAreCompatible + :: forall era + . ( ToJSON (PParams (ShelleyLedgerEra era)) + , FromJSON (PParams (ShelleyLedgerEra era)) + ) + => CardanoEra era -> Property protocolParametersAreCompatible era = - property $ do ValidatedSerializedPair { serializedProtocolParameters - , serializedPParams = _ - } <- forAll $ genValidSerializedPair era - void (leftFail (eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)))) - success + property $ do + ValidatedSerializedPair + { serializedProtocolParameters + , serializedPParams = _ + } <- + forAll $ genValidSerializedPair era + void + ( leftFail + (eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era))) + ) + success -- | This tests that, for protocol parameter sets that can roundtrip between PParams and ProtocolParameters -- (i.e. sets of parameters that are valid/work according to the constraints in both PParams and ProtocolParameters -- and their conversion functions), deserializing them using PParams FromJSON instance and then serializing -- again using PParams ToJSON instance results in the same thing. -roundtripBetweenPParamsAndLegacyProtocolParameters :: forall era. ( FromJSON (PParams (ShelleyLedgerEra era)) - , ToJSON (PParams (ShelleyLedgerEra era)) - ) => CardanoEra era -> Property +roundtripBetweenPParamsAndLegacyProtocolParameters + :: forall era + . ( FromJSON (PParams (ShelleyLedgerEra era)) + , ToJSON (PParams (ShelleyLedgerEra era)) + ) + => CardanoEra era -> Property roundtripBetweenPParamsAndLegacyProtocolParameters era = - property $ do ValidatedSerializedPair { serializedProtocolParameters - , serializedPParams = _ - } <- forAll $ genValidSerializedPair era - patchedserializedProtocolParameters <- patchProtocolParamsJSONOrFail era serializedProtocolParameters - case eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)) of - Left err -> fail err - Right pParams -> prettyPrintJSON pParams === LBS.toStrict patchedserializedProtocolParameters + property $ do + ValidatedSerializedPair + { serializedProtocolParameters + , serializedPParams = _ + } <- + forAll $ genValidSerializedPair era + patchedserializedProtocolParameters <- + patchProtocolParamsJSONOrFail era serializedProtocolParameters + case eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)) of + Left err -> fail err + Right pParams -> prettyPrintJSON pParams === LBS.toStrict patchedserializedProtocolParameters ------------------------- -- Auxiliary generator -- @@ -99,77 +128,97 @@ roundtripBetweenPParamsAndLegacyProtocolParameters era = -- | Represents a corresponding pair of serialized protocol parameters in two formats data ValidatedSerializedPair era = ValidatedSerializedPair - { -- | Serialized cardano-api's legacy `ProtocolParameters` as a ByteString. - serializedProtocolParameters :: LBS.ByteString - , -- | Serialized cardano-ledger's `PParams` as a ByteString. - serializedPParams :: LBS.ByteString - } deriving Show - + { serializedProtocolParameters :: LBS.ByteString + -- ^ Serialized cardano-api's legacy `ProtocolParameters` as a ByteString. + , serializedPParams :: LBS.ByteString + -- ^ Serialized cardano-ledger's `PParams` as a ByteString. + } + deriving (Show) -- | Produces a pair of a valid cardano-api's legacy ProtocolParameters and corresponding cardano-ledger's PParams by doing a round trip -genValidSerializedPair :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Gen (ValidatedSerializedPair era) +genValidSerializedPair + :: forall era + . ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Gen (ValidatedSerializedPair era) genValidSerializedPair era = do unrefinedProtocolParameters <- genProtocolParameters era let mValidatedSerializedPair = - do unrefinedPParams <- convertToLedgerProtocolParameters sbe unrefinedProtocolParameters :: (Either ProtocolParametersConversionError (LedgerProtocolParameters era)) - let refinedProtocolParams = fromLedgerPParams sbe $ unLedgerProtocolParameters unrefinedPParams - refinedPParams <- convertToLedgerProtocolParameters sbe refinedProtocolParams - return $ ValidatedSerializedPair { serializedProtocolParameters = LBS.fromStrict $ prettyPrintJSON refinedProtocolParams - , serializedPParams = LBS.fromStrict $ prettyPrintJSON . unLedgerProtocolParameters $ refinedPParams - } + do + unrefinedPParams <- + convertToLedgerProtocolParameters sbe unrefinedProtocolParameters + :: (Either ProtocolParametersConversionError (LedgerProtocolParameters era)) + let refinedProtocolParams = fromLedgerPParams sbe $ unLedgerProtocolParameters unrefinedPParams + refinedPParams <- convertToLedgerProtocolParameters sbe refinedProtocolParams + return $ + ValidatedSerializedPair + { serializedProtocolParameters = LBS.fromStrict $ prettyPrintJSON refinedProtocolParams + , serializedPParams = LBS.fromStrict $ prettyPrintJSON . unLedgerProtocolParameters $ refinedPParams + } case mValidatedSerializedPair of - Right result -> return result - Left _ -> genValidSerializedPair era - where - sbe :: ShelleyBasedEra era - sbe = toShelleyBased era + Right result -> return result + Left _ -> genValidSerializedPair era + where + sbe :: ShelleyBasedEra era + sbe = toShelleyBased era - toShelleyBased :: CardanoEra era -> ShelleyBasedEra era - toShelleyBased = inEonForEra (error "Not a Shelley-based era") id + toShelleyBased :: CardanoEra era -> ShelleyBasedEra era + toShelleyBased = inEonForEra (error "Not a Shelley-based era") id -- Legacy representation of 'ProtocolParameters' in cardano-api is not 100% compatible with -- the 'PParams' representation in cardano-ledger. This functions modifies the JSON object -- produced by the serialization of 'ProtocolParameters' type to match 'PParams' serialization -- format. -patchProtocolParamsJSONOrFail :: (MonadTest m, MonadFail m) => CardanoEra era -> LBS.ByteString -> m LBS.ByteString -patchProtocolParamsJSONOrFail era s = LBS.fromStrict . prettyPrintJSON - <$> (patchProtocolParamRepresentation - =<< leftFail (eitherDecode s)) - where - -- We are renaming two of the fields to match the spec. Based on discussion here: - -- https://github.com/IntersectMBO/cardano-ledger/pull/4129#discussion_r1507373498 - patchProtocolParamRepresentation :: MonadFail m => Object -> m Object - patchProtocolParamRepresentation o = do filters <- filtersForEra era - renameKey "committeeTermLength" "committeeMaxTermLength" - =<< renameKey "minCommitteeSize" "committeeMinSize" - (applyFilters filters o) - - -- Legacy ProtocolParams ToJSON renders all fields from all eras in all eras, - -- because it is the same data type for every era. But this is not backwards compatible - -- because it means that new eras can modify the fields in old eras. For this reason, when - -- comparing to PParams we use this function to filter fields that don't belong to - -- particular era we are testing. - filtersForEra :: MonadFail m => CardanoEra era -> m [String] - filtersForEra ShelleyEra = return [ "collateralPercentage", "costModels", "executionUnitPrices" - , "maxBlockExecutionUnits", "maxCollateralInputs", "maxTxExecutionUnits" - , "maxValueSize", "utxoCostPerByte" ] - filtersForEra AlonzoEra = return [ "minUTxOValue" ] - filtersForEra BabbageEra = return [ "decentralization", "extraPraosEntropy", "minUTxOValue" ] - filtersForEra era' = fail $ "filtersForEra is not defined for: " <> show era' - - applyFilters :: [String] -> Object -> Object - applyFilters filters o = foldl' (flip Aeson.delete) o (map Aeson.fromString filters) - - -- Renames the key of an entry in a JSON object. - -- If there already is a key with the new name in the object the function fails. - renameKey :: MonadFail m => String -> String -> Object -> m Object - renameKey src dest o = - let srcKey = Aeson.fromString src - destKey = Aeson.fromString dest in - case Aeson.lookup srcKey o of - Nothing -> return o - Just v -> if Aeson.member destKey o - then fail $ "renameKey failed because there is already an entry with the new name: " <> dest - else return $ Aeson.insert destKey v $ Aeson.delete srcKey o - - +patchProtocolParamsJSONOrFail + :: (MonadTest m, MonadFail m) => CardanoEra era -> LBS.ByteString -> m LBS.ByteString +patchProtocolParamsJSONOrFail era s = + LBS.fromStrict . prettyPrintJSON + <$> ( patchProtocolParamRepresentation + =<< leftFail (eitherDecode s) + ) + where + -- We are renaming two of the fields to match the spec. Based on discussion here: + -- https://github.com/IntersectMBO/cardano-ledger/pull/4129#discussion_r1507373498 + patchProtocolParamRepresentation :: MonadFail m => Object -> m Object + patchProtocolParamRepresentation o = do + filters <- filtersForEra era + renameKey "committeeTermLength" "committeeMaxTermLength" + =<< renameKey + "minCommitteeSize" + "committeeMinSize" + (applyFilters filters o) + + -- Legacy ProtocolParams ToJSON renders all fields from all eras in all eras, + -- because it is the same data type for every era. But this is not backwards compatible + -- because it means that new eras can modify the fields in old eras. For this reason, when + -- comparing to PParams we use this function to filter fields that don't belong to + -- particular era we are testing. + filtersForEra :: MonadFail m => CardanoEra era -> m [String] + filtersForEra ShelleyEra = + return + [ "collateralPercentage" + , "costModels" + , "executionUnitPrices" + , "maxBlockExecutionUnits" + , "maxCollateralInputs" + , "maxTxExecutionUnits" + , "maxValueSize" + , "utxoCostPerByte" + ] + filtersForEra AlonzoEra = return ["minUTxOValue"] + filtersForEra BabbageEra = return ["decentralization", "extraPraosEntropy", "minUTxOValue"] + filtersForEra era' = fail $ "filtersForEra is not defined for: " <> show era' + + applyFilters :: [String] -> Object -> Object + applyFilters filters o = foldl' (flip Aeson.delete) o (map Aeson.fromString filters) + + -- Renames the key of an entry in a JSON object. + -- If there already is a key with the new name in the object the function fails. + renameKey :: MonadFail m => String -> String -> Object -> m Object + renameKey src dest o = + let srcKey = Aeson.fromString src + destKey = Aeson.fromString dest + in case Aeson.lookup srcKey o of + Nothing -> return o + Just v -> + if Aeson.member destKey o + then fail $ "renameKey failed because there is already an entry with the new name: " <> dest + else return $ Aeson.insert destKey v $ Aeson.delete srcKey o diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Address.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Address.hs index ed4f261d57..3aeed8b2d9 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Address.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Address.hs @@ -2,20 +2,17 @@ module Test.Cardano.Api.Typed.Address ( tests - ) where - -import Cardano.Api + ) +where +import Cardano.Api import qualified Data.Aeson as Aeson - -import Test.Gen.Cardano.Api.Typed (genAddressByron, genAddressShelley) - -import Test.Cardano.Api.Typed.Orphans () - -import Hedgehog (Property) +import Hedgehog (Property) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed (genAddressByron, genAddressShelley) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -25,18 +22,18 @@ prop_roundtrip_shelley_address :: Property prop_roundtrip_shelley_address = roundtrip_serialise_address AsShelleyAddress genAddressShelley - prop_roundtrip_byron_address :: Property prop_roundtrip_byron_address = roundtrip_serialise_address AsByronAddress genAddressByron - -- ----------------------------------------------------------------------------- roundtrip_serialise_address :: ( SerialiseAddress a , Eq a - , Show a) => AsType a -> H.Gen a -> Property + , Show a + ) + => AsType a -> H.Gen a -> Property roundtrip_serialise_address asType g = H.property $ do v <- H.forAll g @@ -57,9 +54,11 @@ prop_roundtrip_shelley_address_JSON = -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.Address" - [ testProperty "roundtrip shelley address" prop_roundtrip_shelley_address - , testProperty "roundtrip byron address" prop_roundtrip_byron_address - , testProperty "roundtrip byron address JSON" prop_roundtrip_byron_address_JSON - , testProperty "roundtrip shelley address JSON" prop_roundtrip_shelley_address_JSON - ] +tests = + testGroup + "Test.Cardano.Api.Typed.Address" + [ testProperty "roundtrip shelley address" prop_roundtrip_shelley_address + , testProperty "roundtrip byron address" prop_roundtrip_byron_address + , testProperty "roundtrip byron address JSON" prop_roundtrip_byron_address_JSON + , testProperty "roundtrip shelley address JSON" prop_roundtrip_shelley_address_JSON + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Bech32.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Bech32.hs index 9aac90b106..67c52739bb 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Bech32.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Bech32.hs @@ -1,15 +1,14 @@ module Test.Cardano.Api.Typed.Bech32 ( tests - ) where + ) +where -import Cardano.Api (AsType (AsShelleyAddress, AsStakeAddress)) - -import Test.Gen.Cardano.Api.Typed (genAddressShelley, genStakeAddress) - -import Hedgehog (Property) -import Test.Hedgehog.Roundtrip.Bech32 (roundtrip_Bech32) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Cardano.Api (AsType (AsShelleyAddress, AsStakeAddress)) +import Hedgehog (Property) +import Test.Gen.Cardano.Api.Typed (genAddressShelley, genStakeAddress) +import Test.Hedgehog.Roundtrip.Bech32 (roundtrip_Bech32) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_Address_Shelley :: Property prop_roundtrip_Address_Shelley = roundtrip_Bech32 AsShelleyAddress genAddressShelley @@ -18,7 +17,9 @@ prop_roundtrip_StakeAddress :: Property prop_roundtrip_StakeAddress = roundtrip_Bech32 AsStakeAddress genStakeAddress tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.Bech32" - [ testProperty "roundtrip Address Shelley" prop_roundtrip_Address_Shelley - , testProperty "roundtrip StakeAddress" prop_roundtrip_StakeAddress - ] +tests = + testGroup + "Test.Cardano.Api.Typed.Bech32" + [ testProperty "roundtrip Address Shelley" prop_roundtrip_Address_Shelley + , testProperty "roundtrip StakeAddress" prop_roundtrip_StakeAddress + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index efe1d080b0..8f22768565 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -1,28 +1,26 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- TODO remove when serialiseTxLedgerCddl is removed {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +-- TODO remove when serialiseTxLedgerCddl is removed +{-# OPTIONS_GHC -Wno-deprecations #-} module Test.Cardano.Api.Typed.CBOR ( tests - ) where + ) +where -import Cardano.Api -import Cardano.Api.Shelley (AsType (..)) - -import Data.Proxy (Proxy (..)) - -import Test.Gen.Cardano.Api.Typed - -import Test.Cardano.Api.Typed.Orphans () - -import Hedgehog (Property, forAll, property, tripping) +import Cardano.Api +import Cardano.Api.Shelley (AsType (..)) +import Data.Proxy (Proxy (..)) +import Hedgehog (Property, forAll, property, tripping) import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed +import Test.Hedgehog.Roundtrip.CBOR import qualified Test.Hedgehog.Roundtrip.CBOR as H -import Test.Hedgehog.Roundtrip.CBOR -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -31,19 +29,19 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ genTx era shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ genCardanoKeyWitness era shelleyBasedEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x @@ -170,13 +168,13 @@ prop_roundtrip_UpdateProposal_CBOR = H.property $ do prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] x <- forAll $ genTx era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do - AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound .. maxBound] x <- forAll $ genShelleyKeyWitness sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe) @@ -191,36 +189,88 @@ prop_roundtrip_GovernancePollAnswer_CBOR = property $ do -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.CBOR" - [ testProperty "roundtrip witness CBOR" prop_roundtrip_witness_CBOR - , testProperty "roundtrip operational certificate CBOR" prop_roundtrip_operational_certificate_CBOR - , testProperty "roundtrip operational certificate issue counter CBOR" prop_roundtrip_operational_certificate_issue_counter_CBOR - , testProperty "roundtrip verification key byron CBOR" prop_roundtrip_verification_key_byron_CBOR - , testProperty "roundtrip signing key byron CBOR" prop_roundtrip_signing_key_byron_CBOR - , testProperty "roundtrip verification key payment CBOR" prop_roundtrip_verification_key_payment_CBOR - , testProperty "roundtrip signing key payment CBOR" prop_roundtrip_signing_key_payment_CBOR - , testProperty "roundtrip verification key stake CBOR" prop_roundtrip_verification_key_stake_CBOR - , testProperty "roundtrip signing key stake CBOR" prop_roundtrip_signing_key_stake_CBOR - , testProperty "roundtrip verification key genesis CBOR" prop_roundtrip_verification_key_genesis_CBOR - , testProperty "roundtrip signing key genesis CBOR" prop_roundtrip_signing_key_genesis_CBOR - , testProperty "roundtrip verification key genesis delegate CBOR" prop_roundtrip_verification_key_genesis_delegate_CBOR - , testProperty "roundtrip signing key genesis delegate CBOR" prop_roundtrip_signing_key_genesis_delegate_CBOR - , testProperty "roundtrip verification key stake pool CBOR" prop_roundtrip_verification_key_stake_pool_CBOR - , testProperty "roundtrip signing key stake pool CBOR" prop_roundtrip_signing_key_stake_pool_CBOR - , testProperty "roundtrip verification key vrf CBOR" prop_roundtrip_verification_key_vrf_CBOR - , testProperty "roundtrip signing key vrf CBOR" prop_roundtrip_signing_key_vrf_CBOR - , testProperty "roundtrip verification key kes CBOR" prop_roundtrip_verification_key_kes_CBOR - , testProperty "roundtrip signing key kes CBOR" prop_roundtrip_signing_key_kes_CBOR - , testProperty "roundtrip script SimpleScriptV1 CBOR" prop_roundtrip_script_SimpleScriptV1_CBOR - , testProperty "roundtrip script SimpleScriptV2 CBOR" prop_roundtrip_script_SimpleScriptV2_CBOR - , testProperty "roundtrip script PlutusScriptV1 CBOR" prop_roundtrip_script_PlutusScriptV1_CBOR - , testProperty "roundtrip script PlutusScriptV2 CBOR" prop_roundtrip_script_PlutusScriptV2_CBOR - , testProperty "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR - , testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR - , testProperty "roundtrip txbody CBOR" prop_roundtrip_txbody_CBOR - , testProperty "roundtrip Tx Cddl" prop_roundtrip_Tx_Cddl - , testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl - , testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR - , testProperty "roundtrip GovernancePoll CBOR" prop_roundtrip_GovernancePoll_CBOR - , testProperty "roundtrip GovernancePollAnswer CBOR" prop_roundtrip_GovernancePollAnswer_CBOR - ] +tests = + testGroup + "Test.Cardano.Api.Typed.CBOR" + [ testProperty "roundtrip witness CBOR" prop_roundtrip_witness_CBOR + , testProperty + "roundtrip operational certificate CBOR" + prop_roundtrip_operational_certificate_CBOR + , testProperty + "roundtrip operational certificate issue counter CBOR" + prop_roundtrip_operational_certificate_issue_counter_CBOR + , testProperty + "roundtrip verification key byron CBOR" + prop_roundtrip_verification_key_byron_CBOR + , testProperty + "roundtrip signing key byron CBOR" + prop_roundtrip_signing_key_byron_CBOR + , testProperty + "roundtrip verification key payment CBOR" + prop_roundtrip_verification_key_payment_CBOR + , testProperty + "roundtrip signing key payment CBOR" + prop_roundtrip_signing_key_payment_CBOR + , testProperty + "roundtrip verification key stake CBOR" + prop_roundtrip_verification_key_stake_CBOR + , testProperty + "roundtrip signing key stake CBOR" + prop_roundtrip_signing_key_stake_CBOR + , testProperty + "roundtrip verification key genesis CBOR" + prop_roundtrip_verification_key_genesis_CBOR + , testProperty + "roundtrip signing key genesis CBOR" + prop_roundtrip_signing_key_genesis_CBOR + , testProperty + "roundtrip verification key genesis delegate CBOR" + prop_roundtrip_verification_key_genesis_delegate_CBOR + , testProperty + "roundtrip signing key genesis delegate CBOR" + prop_roundtrip_signing_key_genesis_delegate_CBOR + , testProperty + "roundtrip verification key stake pool CBOR" + prop_roundtrip_verification_key_stake_pool_CBOR + , testProperty + "roundtrip signing key stake pool CBOR" + prop_roundtrip_signing_key_stake_pool_CBOR + , testProperty + "roundtrip verification key vrf CBOR" + prop_roundtrip_verification_key_vrf_CBOR + , testProperty + "roundtrip signing key vrf CBOR" + prop_roundtrip_signing_key_vrf_CBOR + , testProperty + "roundtrip verification key kes CBOR" + prop_roundtrip_verification_key_kes_CBOR + , testProperty + "roundtrip signing key kes CBOR" + prop_roundtrip_signing_key_kes_CBOR + , testProperty + "roundtrip script SimpleScriptV1 CBOR" + prop_roundtrip_script_SimpleScriptV1_CBOR + , testProperty + "roundtrip script SimpleScriptV2 CBOR" + prop_roundtrip_script_SimpleScriptV2_CBOR + , testProperty + "roundtrip script PlutusScriptV1 CBOR" + prop_roundtrip_script_PlutusScriptV1_CBOR + , testProperty + "roundtrip script PlutusScriptV2 CBOR" + prop_roundtrip_script_PlutusScriptV2_CBOR + , testProperty + "roundtrip UpdateProposal CBOR" + prop_roundtrip_UpdateProposal_CBOR + , testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR + , testProperty "roundtrip txbody CBOR" prop_roundtrip_txbody_CBOR + , testProperty "roundtrip Tx Cddl" prop_roundtrip_Tx_Cddl + , testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl + , testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR + , testProperty + "roundtrip GovernancePoll CBOR" + prop_roundtrip_GovernancePoll_CBOR + , testProperty + "roundtrip GovernancePollAnswer CBOR" + prop_roundtrip_GovernancePollAnswer_CBOR + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Envelope.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Envelope.hs index 3c977b5c26..127244d8df 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Envelope.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Envelope.hs @@ -3,18 +3,16 @@ module Test.Cardano.Api.Typed.Envelope ( tests - ) where + ) +where -import Cardano.Api - -import Test.Gen.Cardano.Api.Typed - -import Test.Cardano.Api.Typed.Orphans () - -import Hedgehog (Property) +import Cardano.Api +import Hedgehog (Property) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -34,7 +32,6 @@ prop_roundtrip_PaymentSigningKey_envelope :: Property prop_roundtrip_PaymentSigningKey_envelope = roundtrip_SigningKey_envelope AsPaymentKey - prop_roundtrip_StakeVerificationKey_envelope :: Property prop_roundtrip_StakeVerificationKey_envelope = roundtrip_VerificationKey_envelope AsStakeKey @@ -43,7 +40,6 @@ prop_roundtrip_StakeSigningKey_envelope :: Property prop_roundtrip_StakeSigningKey_envelope = roundtrip_SigningKey_envelope AsStakeKey - prop_roundtrip_StakePoolVerificationKey_envelope :: Property prop_roundtrip_StakePoolVerificationKey_envelope = roundtrip_VerificationKey_envelope AsStakePoolKey @@ -52,7 +48,6 @@ prop_roundtrip_StakePoolSigningKey_envelope :: Property prop_roundtrip_StakePoolSigningKey_envelope = roundtrip_SigningKey_envelope AsStakePoolKey - prop_roundtrip_GenesisVerificationKey_envelope :: Property prop_roundtrip_GenesisVerificationKey_envelope = roundtrip_VerificationKey_envelope AsGenesisKey @@ -61,7 +56,6 @@ prop_roundtrip_GenesisSigningKey_envelope :: Property prop_roundtrip_GenesisSigningKey_envelope = roundtrip_SigningKey_envelope AsGenesisKey - prop_roundtrip_GenesisDelegateVerificationKey_envelope :: Property prop_roundtrip_GenesisDelegateVerificationKey_envelope = roundtrip_VerificationKey_envelope AsGenesisDelegateKey @@ -70,7 +64,6 @@ prop_roundtrip_GenesisDelegateSigningKey_envelope :: Property prop_roundtrip_GenesisDelegateSigningKey_envelope = roundtrip_SigningKey_envelope AsGenesisDelegateKey - prop_roundtrip_KesVerificationKey_envelope :: Property prop_roundtrip_KesVerificationKey_envelope = roundtrip_VerificationKey_envelope AsKesKey @@ -79,7 +72,6 @@ prop_roundtrip_KesSigningKey_envelope :: Property prop_roundtrip_KesSigningKey_envelope = roundtrip_SigningKey_envelope AsKesKey - prop_roundtrip_VrfVerificationKey_envelope :: Property prop_roundtrip_VrfVerificationKey_envelope = roundtrip_VerificationKey_envelope AsVrfKey @@ -90,49 +82,90 @@ prop_roundtrip_VrfSigningKey_envelope = -- ----------------------------------------------------------------------------- -roundtrip_VerificationKey_envelope :: () +roundtrip_VerificationKey_envelope + :: () #if MIN_VERSION_base(4,17,0) - -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.2 and above complains if its - -- not present. - => HasTypeProxy keyrole + -- GHC 8.10 considers the HasTypeProxy constraint redundant but ghc-9.2 and above complains if its + -- not present. + => HasTypeProxy keyrole #endif - => Key keyrole - => AsType keyrole - -> Property + => Key keyrole + => AsType keyrole + -> Property roundtrip_VerificationKey_envelope roletoken = H.property $ do vkey <- H.forAll (genVerificationKey roletoken) - H.tripping vkey (serialiseToTextEnvelope Nothing) - (deserialiseFromTextEnvelope (AsVerificationKey roletoken)) - -roundtrip_SigningKey_envelope :: (Key keyrole, - Eq (SigningKey keyrole), - Show (SigningKey keyrole)) - => AsType keyrole -> Property + H.tripping + vkey + (serialiseToTextEnvelope Nothing) + (deserialiseFromTextEnvelope (AsVerificationKey roletoken)) + +roundtrip_SigningKey_envelope + :: ( Key keyrole + , Eq (SigningKey keyrole) + , Show (SigningKey keyrole) + ) + => AsType keyrole -> Property roundtrip_SigningKey_envelope roletoken = H.property $ do vkey <- H.forAll (genSigningKey roletoken) - H.tripping vkey (serialiseToTextEnvelope Nothing) - (deserialiseFromTextEnvelope (AsSigningKey roletoken)) + H.tripping + vkey + (serialiseToTextEnvelope Nothing) + (deserialiseFromTextEnvelope (AsSigningKey roletoken)) -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.Envelope" - [ testProperty "roundtrip ByronVerificationKey envelope" prop_roundtrip_ByronVerificationKey_envelope - , testProperty "roundtrip ByronSigningKey envelope" prop_roundtrip_ByronSigningKey_envelope - , testProperty "roundtrip PaymentVerificationKey envelope" prop_roundtrip_PaymentVerificationKey_envelope - , testProperty "roundtrip PaymentSigningKey envelope" prop_roundtrip_PaymentSigningKey_envelope - , testProperty "roundtrip StakeVerificationKey envelope" prop_roundtrip_StakeVerificationKey_envelope - , testProperty "roundtrip StakeSigningKey envelope" prop_roundtrip_StakeSigningKey_envelope - , testProperty "roundtrip StakePoolVerificationKey envelope" prop_roundtrip_StakePoolVerificationKey_envelope - , testProperty "roundtrip StakePoolSigningKey envelope" prop_roundtrip_StakePoolSigningKey_envelope - , testProperty "roundtrip GenesisVerificationKey envelope" prop_roundtrip_GenesisVerificationKey_envelope - , testProperty "roundtrip GenesisSigningKey envelope" prop_roundtrip_GenesisSigningKey_envelope - , testProperty "roundtrip GenesisDelegateVerificationKey envelope" prop_roundtrip_GenesisDelegateVerificationKey_envelope - , testProperty "roundtrip GenesisDelegateSigningKey envelope" prop_roundtrip_GenesisDelegateSigningKey_envelope - , testProperty "roundtrip KesVerificationKey envelope" prop_roundtrip_KesVerificationKey_envelope - , testProperty "roundtrip KesSigningKey envelope" prop_roundtrip_KesSigningKey_envelope - , testProperty "roundtrip VrfVerificationKey envelope" prop_roundtrip_VrfVerificationKey_envelope - , testProperty "roundtrip VrfSigningKey envelope" prop_roundtrip_VrfSigningKey_envelope - ] +tests = + testGroup + "Test.Cardano.Api.Typed.Envelope" + [ testProperty + "roundtrip ByronVerificationKey envelope" + prop_roundtrip_ByronVerificationKey_envelope + , testProperty + "roundtrip ByronSigningKey envelope" + prop_roundtrip_ByronSigningKey_envelope + , testProperty + "roundtrip PaymentVerificationKey envelope" + prop_roundtrip_PaymentVerificationKey_envelope + , testProperty + "roundtrip PaymentSigningKey envelope" + prop_roundtrip_PaymentSigningKey_envelope + , testProperty + "roundtrip StakeVerificationKey envelope" + prop_roundtrip_StakeVerificationKey_envelope + , testProperty + "roundtrip StakeSigningKey envelope" + prop_roundtrip_StakeSigningKey_envelope + , testProperty + "roundtrip StakePoolVerificationKey envelope" + prop_roundtrip_StakePoolVerificationKey_envelope + , testProperty + "roundtrip StakePoolSigningKey envelope" + prop_roundtrip_StakePoolSigningKey_envelope + , testProperty + "roundtrip GenesisVerificationKey envelope" + prop_roundtrip_GenesisVerificationKey_envelope + , testProperty + "roundtrip GenesisSigningKey envelope" + prop_roundtrip_GenesisSigningKey_envelope + , testProperty + "roundtrip GenesisDelegateVerificationKey envelope" + prop_roundtrip_GenesisDelegateVerificationKey_envelope + , testProperty + "roundtrip GenesisDelegateSigningKey envelope" + prop_roundtrip_GenesisDelegateSigningKey_envelope + , testProperty + "roundtrip KesVerificationKey envelope" + prop_roundtrip_KesVerificationKey_envelope + , testProperty + "roundtrip KesSigningKey envelope" + prop_roundtrip_KesSigningKey_envelope + , testProperty + "roundtrip VrfVerificationKey envelope" + prop_roundtrip_VrfVerificationKey_envelope + , testProperty + "roundtrip VrfSigningKey envelope" + prop_roundtrip_VrfSigningKey_envelope + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs index b38635257e..548c9b9462 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/JSON.hs @@ -1,26 +1,22 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Api.Typed.JSON ( tests - ) where - -import Cardano.Api - -import Data.Aeson (eitherDecode, encode) - -import Test.Gen.Cardano.Api.Typed (genMaybePraosNonce, genProtocolParameters) - -import Test.Cardano.Api.Typed.Orphans () + ) +where -import Hedgehog (Property, forAll, tripping) +import Cardano.Api +import Data.Aeson (eitherDecode, encode) +import Hedgehog (Property, forAll, tripping) import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed (genMaybePraosNonce, genProtocolParameters) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -38,7 +34,9 @@ prop_roundtrip_protocol_parameters_JSON = H.property $ do -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.JSON" - [ testProperty "roundtrip praos nonce JSON" prop_roundtrip_praos_nonce_JSON - , testProperty "roundtrip protocol parameters JSON" prop_roundtrip_protocol_parameters_JSON - ] +tests = + testGroup + "Test.Cardano.Api.Typed.JSON" + [ testProperty "roundtrip praos nonce JSON" prop_roundtrip_praos_nonce_JSON + , testProperty "roundtrip protocol parameters JSON" prop_roundtrip_protocol_parameters_JSON + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs index 5a5bb95d8a..43f6dc0332 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs @@ -1,65 +1,65 @@ module Test.Cardano.Api.Typed.Ord ( tests - ) where + ) +where -import Cardano.Api -import Cardano.Api.Shelley - -import Test.Gen.Cardano.Api.Typed - -import Test.Cardano.Api.Metadata (genTxMetadataValue) - -import Hedgehog (Property, (===)) +import Cardano.Api +import Cardano.Api.Shelley +import Hedgehog (Property, (===)) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Metadata (genTxMetadataValue) +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} -ord_distributive :: (Show a, Ord a, Ord b) - => H.Gen a -> (a -> b) -> Property +ord_distributive + :: (Show a, Ord a, Ord b) + => H.Gen a -> (a -> b) -> Property ord_distributive gen to = - H.property $ do - x <- H.forAll gen - y <- H.forAll gen - compare x y === compare (to x) (to y) - + H.property $ do + x <- H.forAll gen + y <- H.forAll gen + compare x y === compare (to x) (to y) prop_ord_distributive_TxId :: Property prop_ord_distributive_TxId = - ord_distributive genTxId toShelleyTxId + ord_distributive genTxId toShelleyTxId prop_ord_distributive_TxIn :: Property prop_ord_distributive_TxIn = - ord_distributive genTxIn toShelleyTxIn + ord_distributive genTxIn toShelleyTxIn prop_ord_distributive_Address :: Property prop_ord_distributive_Address = - ord_distributive genAddressShelley (toShelleyAddr . toAddressInAnyEra) - where - toAddressInAnyEra :: Address ShelleyAddr -> AddressInEra ShelleyEra - toAddressInAnyEra = anyAddressInShelleyBasedEra ShelleyBasedEraShelley . toAddressAny + ord_distributive genAddressShelley (toShelleyAddr . toAddressInAnyEra) + where + toAddressInAnyEra :: Address ShelleyAddr -> AddressInEra ShelleyEra + toAddressInAnyEra = anyAddressInShelleyBasedEra ShelleyBasedEraShelley . toAddressAny prop_ord_distributive_StakeAddress :: Property prop_ord_distributive_StakeAddress = - ord_distributive genStakeAddress toShelleyStakeAddr + ord_distributive genStakeAddress toShelleyStakeAddr prop_ord_distributive_TxMetadata :: Property prop_ord_distributive_TxMetadata = - ord_distributive genTxMetadataValue toShelleyMetadatum + ord_distributive genTxMetadataValue toShelleyMetadatum prop_ord_distributive_ScriptData :: Property prop_ord_distributive_ScriptData = - ord_distributive (getScriptData <$> genHashableScriptData) toPlutusData + ord_distributive (getScriptData <$> genHashableScriptData) toPlutusData -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.Ord" - [ testProperty "ord distributive TxId" prop_ord_distributive_TxId - , testProperty "ord distributive TxIn" prop_ord_distributive_TxIn - , testProperty "ord distributive Address" prop_ord_distributive_Address - , testProperty "ord distributive StakeAddress" prop_ord_distributive_StakeAddress - , testProperty "ord distributive TxMetadata" prop_ord_distributive_TxMetadata - , testProperty "ord distributive ScriptData" prop_ord_distributive_ScriptData - ] +tests = + testGroup + "Test.Cardano.Api.Typed.Ord" + [ testProperty "ord distributive TxId" prop_ord_distributive_TxId + , testProperty "ord distributive TxIn" prop_ord_distributive_TxIn + , testProperty "ord distributive Address" prop_ord_distributive_Address + , testProperty "ord distributive StakeAddress" prop_ord_distributive_StakeAddress + , testProperty "ord distributive TxMetadata" prop_ord_distributive_TxMetadata + , testProperty "ord distributive ScriptData" prop_ord_distributive_ScriptData + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Orphans.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Orphans.hs index 6d0e22ce90..3761894a19 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Orphans.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Orphans.hs @@ -3,34 +3,41 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Api.Typed.Orphans () where -import Cardano.Api.Shelley - -import Cardano.Crypto.Hash hiding (Hash) -import Cardano.Crypto.KES -import Cardano.Crypto.Libsodium (SodiumHashAlgorithm) - -import Test.Cardano.Crypto.Orphans () +import Cardano.Api.Shelley +import Cardano.Crypto.Hash hiding (Hash) +import Cardano.Crypto.KES +import Cardano.Crypto.Libsodium (SodiumHashAlgorithm) +import Test.Cardano.Crypto.Orphans () -- Signing Key instances deriving instance Eq (SigningKey ByronKey) + deriving instance Eq (SigningKey PaymentKey) + deriving instance Eq (SigningKey StakeKey) + deriving instance Eq (SigningKey StakePoolKey) + deriving instance Eq (SigningKey GenesisKey) + deriving instance Eq (SigningKey GenesisDelegateKey) + deriving instance Eq (SigningKey GenesisUTxOKey) + deriving instance Eq (SigningKey KesKey) -deriving instance Eq (SigningKey VrfKey) +deriving instance Eq (SigningKey VrfKey) -instance ( KESAlgorithm d - , SodiumHashAlgorithm h - , SizeHash h ~ SeedSizeKES d - ) => Eq (SignKeyKES (SumKES h d)) where +instance + ( KESAlgorithm d + , SodiumHashAlgorithm h + , SizeHash h ~ SeedSizeKES d + ) + => Eq (SignKeyKES (SumKES h d)) + where k1 == k2 = rawSerialiseSignKeyKES k1 == rawSerialiseSignKeyKES k2 diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/RawBytes.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/RawBytes.hs index de1776b412..3d472869b1 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/RawBytes.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/RawBytes.hs @@ -3,18 +3,16 @@ module Test.Cardano.Api.Typed.RawBytes ( tests - ) where + ) +where -import Cardano.Api - -import Test.Gen.Cardano.Api.Typed - -import Test.Cardano.Api.Typed.Orphans () - -import Hedgehog (Property) +import Cardano.Api +import Hedgehog (Property) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} @@ -24,7 +22,6 @@ prop_roundtrip_shelley_address_raw :: Property prop_roundtrip_shelley_address_raw = roundtrip_raw_bytes AsShelleyAddress genAddressShelley - prop_roundtrip_byron_address_raw :: Property prop_roundtrip_byron_address_raw = roundtrip_raw_bytes AsByronAddress genAddressByron @@ -78,13 +75,16 @@ prop_roundtrip_verification_GenesisUTxOKey_hash_raw = roundtrip_raw_bytes :: ( SerialiseAsRawBytes a , Eq a - , Show a) => AsType a -> H.Gen a -> Property + , Show a + ) + => AsType a -> H.Gen a -> Property roundtrip_raw_bytes asType g = H.property $ do v <- H.forAll g H.tripping v serialiseToRawBytes (deserialiseFromRawBytes asType) -roundtrip_verification_key_hash_raw :: () +roundtrip_verification_key_hash_raw + :: () #if MIN_VERSION_base(4,17,0) -- GHC 9.2 and above needs an extra constraint. => HasTypeProxy keyrole @@ -103,18 +103,38 @@ roundtrip_verification_key_hash_raw roletoken = -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.RawBytes" - [ testProperty "roundtrip shelley address raw" prop_roundtrip_shelley_address_raw - , testProperty "roundtrip byron address raw" prop_roundtrip_byron_address_raw - , testProperty "roundtrip stake address raw" prop_roundtrip_stake_address_raw - , testProperty "roundtrip script hash raw" prop_roundtrip_script_hash_raw - , testProperty "roundtrip verification ByronKey hash raw" prop_roundtrip_verification_ByronKey_hash_raw - , testProperty "roundtrip verification PaymentKey hash raw" prop_roundtrip_verification_PaymentKey_hash_raw - , testProperty "roundtrip verification StakeKey hash raw" prop_roundtrip_verification_StakeKey_hash_raw - , testProperty "roundtrip verification StakePoolKey hash raw" prop_roundtrip_verification_StakePoolKey_hash_raw - , testProperty "roundtrip verification GenesisKey hash raw" prop_roundtrip_verification_GenesisKey_hash_raw - , testProperty "roundtrip verification GenesisDelegateKey hash raw" prop_roundtrip_verification_GenesisDelegateKey_hash_raw - , testProperty "roundtrip verification KesKey hash raw" prop_roundtrip_verification_KesKey_hash_raw - , testProperty "roundtrip verification VrfKey hash raw" prop_roundtrip_verification_VrfKey_hash_raw - , testProperty "roundtrip verification GenesisUTxOKey hash raw" prop_roundtrip_verification_GenesisUTxOKey_hash_raw - ] +tests = + testGroup + "Test.Cardano.Api.Typed.RawBytes" + [ testProperty "roundtrip shelley address raw" prop_roundtrip_shelley_address_raw + , testProperty "roundtrip byron address raw" prop_roundtrip_byron_address_raw + , testProperty "roundtrip stake address raw" prop_roundtrip_stake_address_raw + , testProperty "roundtrip script hash raw" prop_roundtrip_script_hash_raw + , testProperty + "roundtrip verification ByronKey hash raw" + prop_roundtrip_verification_ByronKey_hash_raw + , testProperty + "roundtrip verification PaymentKey hash raw" + prop_roundtrip_verification_PaymentKey_hash_raw + , testProperty + "roundtrip verification StakeKey hash raw" + prop_roundtrip_verification_StakeKey_hash_raw + , testProperty + "roundtrip verification StakePoolKey hash raw" + prop_roundtrip_verification_StakePoolKey_hash_raw + , testProperty + "roundtrip verification GenesisKey hash raw" + prop_roundtrip_verification_GenesisKey_hash_raw + , testProperty + "roundtrip verification GenesisDelegateKey hash raw" + prop_roundtrip_verification_GenesisDelegateKey_hash_raw + , testProperty + "roundtrip verification KesKey hash raw" + prop_roundtrip_verification_KesKey_hash_raw + , testProperty + "roundtrip verification VrfKey hash raw" + prop_roundtrip_verification_VrfKey_hash_raw + , testProperty + "roundtrip verification GenesisUTxOKey hash raw" + prop_roundtrip_verification_GenesisUTxOKey_hash_raw + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index d0a0baee64..734cb73d53 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -2,27 +2,24 @@ module Test.Cardano.Api.Typed.TxBody ( tests - ) where + ) +where -import Cardano.Api -import Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleyScript) - -import Data.Maybe (isJust) -import Data.Type.Equality (TestEquality (testEquality)) - -import Test.Gen.Cardano.Api.Typed (genTxBodyContent) - -import Test.Cardano.Api.Typed.Orphans () - -import Hedgehog (MonadTest, Property, annotateShow, failure, (===)) +import Cardano.Api +import Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleyScript) +import Data.Maybe (isJust) +import Data.Type.Equality (TestEquality (testEquality)) +import Hedgehog (MonadTest, Property, annotateShow, failure, (===)) import qualified Hedgehog as H -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Test.Cardano.Api.Typed.Orphans () +import Test.Gen.Cardano.Api.Typed (genTxBodyContent) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} -- | Check the txOuts in a TxBodyContent after a ledger roundtrip. -prop_roundtrip_txbodycontent_txouts:: Property +prop_roundtrip_txbodycontent_txouts :: Property prop_roundtrip_txbodycontent_txouts = H.property $ do let era = ShelleyBasedEraBabbage @@ -63,9 +60,10 @@ prop_roundtrip_txbodycontent_txouts = matchRefScript :: MonadTest m => (ReferenceScript BabbageEra, ReferenceScript BabbageEra) -> m () matchRefScript (a, b) | isSimpleScriptV2 a && isSimpleScriptV2 b = - refScriptToShelleyScript ShelleyBasedEraBabbage a === refScriptToShelleyScript ShelleyBasedEraBabbage b + refScriptToShelleyScript ShelleyBasedEraBabbage a + === refScriptToShelleyScript ShelleyBasedEraBabbage b | otherwise = - a === b + a === b isSimpleScriptV2 :: ReferenceScript era -> Bool isSimpleScriptV2 = isLang SimpleScriptLanguage @@ -76,6 +74,8 @@ prop_roundtrip_txbodycontent_txouts = _ -> False tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.TxBody" - [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts - ] +tests = + testGroup + "Test.Cardano.Api.Typed.TxBody" + [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs index 262c791f92..2b51d8968e 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Value.hs @@ -1,21 +1,25 @@ module Test.Cardano.Api.Typed.Value ( tests - ) where - -import Cardano.Api (MaryEraOnwards (..), ShelleyBasedEra (..), ValueNestedBundle (..), - ValueNestedRep (..), fromLedgerValue, valueFromNestedRep, valueToNestedRep) - -import Prelude - -import Data.Aeson (eitherDecode, encode) -import Data.List (groupBy, sort) + ) +where + +import Cardano.Api + ( MaryEraOnwards (..) + , ShelleyBasedEra (..) + , ValueNestedBundle (..) + , ValueNestedRep (..) + , fromLedgerValue + , valueFromNestedRep + , valueToNestedRep + ) +import Data.Aeson (eitherDecode, encode) +import Data.List (groupBy, sort) import qualified Data.Map.Strict as Map - -import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep) - -import Hedgehog (Property, forAll, property, tripping, (===)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) +import Hedgehog (Property, forAll, property, tripping, (===)) +import Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) +import Prelude prop_roundtrip_Value_JSON :: Property prop_roundtrip_Value_JSON = @@ -23,7 +27,6 @@ prop_roundtrip_Value_JSON = v <- forAll $ fromLedgerValue ShelleyBasedEraConway <$> genValueDefault MaryEraOnwardsConway tripping v encode eitherDecode - prop_roundtrip_Value_flatten_unflatten :: Property prop_roundtrip_Value_flatten_unflatten = property $ do @@ -32,43 +35,45 @@ prop_roundtrip_Value_flatten_unflatten = prop_roundtrip_Value_unflatten_flatten :: Property prop_roundtrip_Value_unflatten_flatten = - property $ do - v <- forAll genValueNestedRep - canonicalise v === valueToNestedRep (valueFromNestedRep v) + property $ do + v <- forAll genValueNestedRep + canonicalise v === valueToNestedRep (valueFromNestedRep v) canonicalise :: ValueNestedRep -> ValueNestedRep canonicalise = - ValueNestedRep - . filter (not . isZeroOrEmpty) - . map (filterZeros . foldl1 mergeBundle) - . groupBy samePolicyId - . sort - . (\(ValueNestedRep bundles) -> bundles) - where - samePolicyId ValueNestedBundleAda{} - ValueNestedBundleAda{} = True - samePolicyId (ValueNestedBundle pid _) - (ValueNestedBundle pid' _) = pid == pid' - samePolicyId _ _ = False - - -- Merge together bundles that have already been grouped by same PolicyId: - mergeBundle (ValueNestedBundleAda q) - (ValueNestedBundleAda q') = + ValueNestedRep + . filter (not . isZeroOrEmpty) + . map (filterZeros . foldl1 mergeBundle) + . groupBy samePolicyId + . sort + . (\(ValueNestedRep bundles) -> bundles) + where + samePolicyId + ValueNestedBundleAda {} + ValueNestedBundleAda {} = True + samePolicyId + (ValueNestedBundle pid _) + (ValueNestedBundle pid' _) = pid == pid' + samePolicyId _ _ = False + + -- Merge together bundles that have already been grouped by same PolicyId: + mergeBundle + (ValueNestedBundleAda q) + (ValueNestedBundleAda q') = ValueNestedBundleAda (q <> q') + mergeBundle + (ValueNestedBundle pid as) + (ValueNestedBundle pid' as') + | pid == pid' = + ValueNestedBundle pid (Map.unionWith (<>) as as') + mergeBundle _ _ = error "canonicalise.mergeBundle: impossible" - mergeBundle (ValueNestedBundle pid as) - (ValueNestedBundle pid' as') | pid == pid' = - ValueNestedBundle pid (Map.unionWith (<>) as as') - - mergeBundle _ _ = error "canonicalise.mergeBundle: impossible" - - filterZeros b@ValueNestedBundleAda{} = b - filterZeros (ValueNestedBundle pid as) = - ValueNestedBundle pid (Map.filter (/=0) as) - - isZeroOrEmpty (ValueNestedBundleAda q) = q == 0 - isZeroOrEmpty (ValueNestedBundle _ as) = Map.null as + filterZeros b@ValueNestedBundleAda {} = b + filterZeros (ValueNestedBundle pid as) = + ValueNestedBundle pid (Map.filter (/= 0) as) + isZeroOrEmpty (ValueNestedBundleAda q) = q == 0 + isZeroOrEmpty (ValueNestedBundle _ as) = Map.null as prop_roundtrip_AssetName_JSON :: Property prop_roundtrip_AssetName_JSON = @@ -82,14 +87,15 @@ prop_roundtrip_AssetName_JSONKey = v <- forAll genAssetName tripping (Map.singleton v ()) encode eitherDecode - -- ----------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Test.Cardano.Api.Typed.Value" - [ testProperty "roundtrip Value JSON" prop_roundtrip_Value_JSON - , testProperty "roundtrip Value flatten unflatten" prop_roundtrip_Value_flatten_unflatten - , testProperty "roundtrip Value unflatten flatten" prop_roundtrip_Value_unflatten_flatten - , testProperty "roundtrip AssetName JSON" prop_roundtrip_AssetName_JSON - , testProperty "roundtrip AssetName JSONKey" prop_roundtrip_AssetName_JSONKey - ] +tests = + testGroup + "Test.Cardano.Api.Typed.Value" + [ testProperty "roundtrip Value JSON" prop_roundtrip_Value_JSON + , testProperty "roundtrip Value flatten unflatten" prop_roundtrip_Value_flatten_unflatten + , testProperty "roundtrip Value unflatten flatten" prop_roundtrip_Value_unflatten_flatten + , testProperty "roundtrip AssetName JSON" prop_roundtrip_AssetName_JSON + , testProperty "roundtrip AssetName JSONKey" prop_roundtrip_AssetName_JSONKey + ] diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index 9b8918d350..40511e5448 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -1,11 +1,7 @@ module Main where -import Cardano.Crypto.Libsodium (sodiumInit) - -import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) - -import qualified Test.Gen.Cardano.Api.Byron - +import Cardano.Crypto.Libsodium (sodiumInit) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import qualified Test.Cardano.Api.Crypto import qualified Test.Cardano.Api.EpochLeadership import qualified Test.Cardano.Api.Eras @@ -24,8 +20,8 @@ import qualified Test.Cardano.Api.Typed.Ord import qualified Test.Cardano.Api.Typed.RawBytes import qualified Test.Cardano.Api.Typed.TxBody import qualified Test.Cardano.Api.Typed.Value - -import Test.Tasty (TestTree, defaultMain, testGroup) +import qualified Test.Gen.Cardano.Api.Byron +import Test.Tasty (TestTree, defaultMain, testGroup) main :: IO () main = do @@ -37,7 +33,8 @@ main = do tests :: TestTree tests = - testGroup "Cardano.Api" + testGroup + "Cardano.Api" [ Test.Gen.Cardano.Api.Byron.tests , Test.Cardano.Api.Crypto.tests , Test.Cardano.Api.EpochLeadership.tests diff --git a/flake.nix b/flake.nix index fd48618510..4cdf94d48b 100644 --- a/flake.nix +++ b/flake.nix @@ -109,10 +109,11 @@ } // lib.optionalAttrs (config.compiler-nix-name == defaultCompiler) { # tools that work or should be used only with default compiler + cabal-gild = "1.3.1.2"; + fourmolu = "0.16.2.0"; haskell-language-server.src = nixpkgs.haskell-nix.sources."hls-2.6"; hlint = "3.6.1"; stylish-haskell = "0.14.5.0"; - cabal-gild = "1.3.1.2"; }; # and from nixpkgs or other inputs shell.nativeBuildInputs = with nixpkgs; [gh jq yq-go actionlint shellcheck cabal-head]; diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000000..7362755bc9 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,17 @@ +indentation: 2 +column-limit: 100 +function-arrows: leading +comma-style: leading +import-export-style: leading +indent-wheres: true +record-brace-space: true +newlines-between-decls: 1 +haddock-style: single-line +haddock-style-module: +let-style: auto +indent-wheres: false +in-style: right-align +unicode: never +respectful: false +fixities: [] +single-constraint-parens: never diff --git a/scripts/githooks/haskell-style-lint b/scripts/githooks/haskell-style-lint index 87c34818b6..95aabcb7f0 100755 --- a/scripts/githooks/haskell-style-lint +++ b/scripts/githooks/haskell-style-lint @@ -1,5 +1,5 @@ #!/usr/bin/env bash -# This script validates the staged changes in Haskell files using stylish-haskell and hlint, and +# This script validates the staged changes in Haskell files using fourmolu and hlint, and # in cabal files using cabal-gild. It returns non-zero code when there are linting # or style issues. # @@ -14,7 +14,7 @@ for x in $(git diff --staged --name-only --diff-filter=ACM "*.hs" | tr '\n' ' ') if grep -qE '^#' "$x"; then echo "$x contains CPP. Skipping." else - stylish-haskell -i "$x" + fourmolu -q -i "$x" fi hlint "$x" || hlint_rc="1" done