From d8c7ea2c3c5813589d5494a282ca5afccab928a7 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 15 Jul 2020 13:14:18 +1000 Subject: [PATCH] =?UTF-8?q?wip=20Cardano.Api=20=E2=86=92=20Cardano.Api.Typ?= =?UTF-8?q?ed=20and=20HardForkBlock=20support?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/core/src/Cardano/Wallet/Network.hs | 7 +- .../src/Cardano/Wallet/Primitive/Slotting.hs | 19 +- lib/shelley/cardano-wallet-shelley.cabal | 3 + .../src/Cardano/Wallet/Byron/Compatibility.hs | 480 ++++++++++++++++++ .../Cardano/Wallet/Shelley/Compatibility.hs | 311 +++++++----- .../src/Cardano/Wallet/Shelley/Network.hs | 211 ++++---- .../src/Cardano/Wallet/Shelley/Pools.hs | 22 +- .../src/Cardano/Wallet/Shelley/Transaction.hs | 74 +-- 8 files changed, 858 insertions(+), 269 deletions(-) create mode 100644 lib/shelley/src/Cardano/Wallet/Byron/Compatibility.hs diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 55f05606471..0c4c3837cb6 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -137,8 +137,9 @@ data NetworkLayer m target block = NetworkLayer :: SealedTx -> ExceptT ErrPostTx m () -- ^ Broadcast a transaction to the chain producer - , stakeDistribution - :: GetStakeDistribution target m + -- adding block causes issues in Functor instance + -- , stakeDistribution + -- :: GetStakeDistribution target block m , getAccountBalance :: ChimericAccount @@ -237,7 +238,7 @@ defaultRetryPolicy = Queries -------------------------------------------------------------------------------} -type family GetStakeDistribution target (m :: * -> *) :: * +type family GetStakeDistribution target block (m :: * -> *) :: * {------------------------------------------------------------------------------- Chain Sync diff --git a/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs b/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs index 56e2f42e6a9..67afdd9f247 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs @@ -64,8 +64,6 @@ import GHC.Generics ( Generic ) import Numeric.Natural ( Natural ) -import Ouroboros.Consensus.HardFork.History.EraParams - ( EraParams (..), noLowerBoundSafeZone ) import Ouroboros.Consensus.HardFork.History.Qry ( Qry, runQuery, slotToEpoch ) import Ouroboros.Consensus.HardFork.History.Summary @@ -89,25 +87,16 @@ epochOf slot = do -- TODO: The type should be changed to @Interpreter@ when we bump -- ouroboros-consensus. singleEraInterpreter :: GenesisParameters -> Summary '[x] -singleEraInterpreter gp = neverForksSummary $ - EraParams - { eraEpochSize = - Cardano.EpochSize +singleEraInterpreter gp = neverForksSummary sz len + where + sz = Cardano.EpochSize . fromIntegral . unEpochLength $ gp ^. #getEpochLength - - , eraSlotLength = - Cardano.mkSlotLength + len = Cardano.mkSlotLength . unSlotLength $ gp ^. #getSlotLength - , eraSafeZone = - noLowerBoundSafeZone (k * 2) - } - where - k = fromIntegral $ getQuantity $ getEpochStability gp - -- ----------------------------------------------------------------------------- -- Legacy functions -- These only work for a single era. We need to stop using them diff --git a/lib/shelley/cardano-wallet-shelley.cabal b/lib/shelley/cardano-wallet-shelley.cabal index ac9b0b8c693..02217855e2c 100644 --- a/lib/shelley/cardano-wallet-shelley.cabal +++ b/lib/shelley/cardano-wallet-shelley.cabal @@ -65,6 +65,8 @@ library , network-mux , optparse-applicative , ouroboros-consensus + , ouroboros-consensus-byron + , ouroboros-consensus-cardano , ouroboros-consensus-shelley , ouroboros-network , ouroboros-network-framework @@ -85,6 +87,7 @@ library hs-source-dirs: src exposed-modules: + Cardano.Wallet.Byron.Compatibility Cardano.Wallet.Shelley Cardano.Wallet.Shelley.Api.Server Cardano.Wallet.Shelley.Compatibility diff --git a/lib/shelley/src/Cardano/Wallet/Byron/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Byron/Compatibility.hs new file mode 100644 index 00000000000..364c6007207 --- /dev/null +++ b/lib/shelley/src/Cardano/Wallet/Byron/Compatibility.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- Orphan instances for {Encode,Decode}Address until we get rid of the +-- Jörmungandr dual support. +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright: © 2020 IOHK +-- License: Apache-2.0 +-- +-- Conversion functions and static chain settings for Byron. + +module Cardano.Wallet.Byron.Compatibility + ( Byron + , ByronBlock + , NodeVersionData + + -- * Chain Parameters + , mainnetVersionData + , testnetVersionData + + , mainnetNetworkParameters + + -- * Genesis + , emptyGenesis + , genesisTip + + -- * Conversions + , toByronHash + , toGenTx + , toPoint + , toSlotInEpoch + + , fromBlockNo + , fromByronBlock + , fromByronHash + , fromChainHash + , fromGenesisData + , byronCodecConfig + , fromNetworkMagic + , fromProtocolMagicId + , fromSlotNo + , fromTip + , fromTxAux + , fromTxIn + , fromTxOut + + , protocolParametersFromUpdateState + ) where + +import Prelude + +import Cardano.Binary + ( fromCBOR, serialize' ) +import Cardano.Chain.Block + ( ABlockOrBoundary (..), blockTxPayload ) +import Cardano.Chain.Common + ( BlockCount (..) + , Lovelace + , TxFeePolicy (..) + , TxSizeLinear (..) + , unsafeGetLovelace + ) +import Cardano.Chain.Genesis + ( GenesisData (..), GenesisHash (..), GenesisNonAvvmBalances (..) ) +import Cardano.Chain.MempoolPayload + ( AMempoolPayload (..) ) +import Cardano.Chain.Slotting + ( EpochSlots (..) ) +import Cardano.Chain.Update + ( ProtocolParameters (..) ) +import Cardano.Chain.UTxO + ( Tx (..), TxAux, TxIn (..), TxOut (..), annotateTxAux, taTx, unTxPayload ) +import Cardano.Crypto + ( serializeCborHash ) +import Cardano.Crypto.ProtocolMagic + ( ProtocolMagicId, unProtocolMagicId ) +import Cardano.Wallet.Primitive.Slotting + ( flatSlot, fromFlatSlot ) +import Cardano.Wallet.Unsafe + ( unsafeDeserialiseCbor, unsafeFromHex ) +import Data.Coerce + ( coerce ) +import Data.Quantity + ( Quantity (..) ) +import Data.Text + ( Text ) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime ) +import Data.Word + ( Word16, Word32 ) +import GHC.Stack + ( HasCallStack ) +import Numeric.Natural + ( Natural ) +import Ouroboros.Consensus.Block.Abstract + ( getHeader, headerPrevHash ) +import Ouroboros.Consensus.Byron.Ledger + ( ByronBlock (..), ByronHash (..), GenTx, fromMempoolPayload ) +import Ouroboros.Consensus.Byron.Ledger.Config + ( CodecConfig (..) ) +import Ouroboros.Consensus.Config.SecurityParam + ( SecurityParam (..) ) +import Ouroboros.Network.Block + ( BlockNo (..) + , ChainHash + , Point (..) + , SlotNo (..) + , Tip (..) + , blockHash + , blockNo + , blockSlot + , genesisPoint + , getLegacyTipBlockNo + , getTipPoint + , legacyTip + ) +import Ouroboros.Network.CodecCBORTerm + ( CodecCBORTerm ) +import Ouroboros.Network.Magic + ( NetworkMagic (..) ) +import Ouroboros.Network.NodeToClient + ( NodeToClientVersionData (..), nodeToClientCodecCBORTerm ) +import Ouroboros.Network.Point + ( WithOrigin (..) ) + +import qualified Cardano.Chain.Update as Update +import qualified Cardano.Chain.Update.Validation.Interface as Update +import qualified Cardano.Crypto.Hashing as CC +import qualified Cardano.Wallet.Primitive.Types as W +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Ouroboros.Network.Block as O +import qualified Ouroboros.Network.Point as Point + +data Byron + +type NodeVersionData = + (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) + +-------------------------------------------------------------------------------- +-- +-- Chain Parameters + + +mainnetNetworkParameters :: W.NetworkParameters +mainnetNetworkParameters = W.NetworkParameters + { genesisParameters = W.GenesisParameters + { getGenesisBlockHash = W.Hash $ unsafeFromHex + "5f20df933584822601f9e3f8c024eb5eb252fe8cefb24d1317dc3d432e940ebb" + , getGenesisBlockDate = + W.StartTime $ posixSecondsToUTCTime 1506203091 + , getSlotLength = + W.SlotLength 20 + , getEpochLength = + W.EpochLength 21600 + , getEpochStability = + Quantity 2160 + , getActiveSlotCoefficient = + W.ActiveSlotCoefficient 1.0 + } + , protocolParameters = W.ProtocolParameters + { decentralizationLevel = + minBound + , txParameters = W.TxParameters + { getFeePolicy = + W.LinearFee (Quantity 155381) (Quantity 43.946) (Quantity 0) + , getTxMaxSize = + Quantity 4096 + } + , desiredNumberOfStakePools = 0 + , minimumUTxOvalue = W.Coin 0 + } + } + +-- NOTE +-- For MainNet and TestNet, we can get away with empty genesis blocks with +-- the following assumption: +-- +-- - Users won't ever restore a wallet that has genesis UTxO. +-- +-- This assumption is _true_ for any user using HD wallets (sequential or +-- random) which means, any user of cardano-wallet. +emptyGenesis :: W.GenesisParameters -> W.Block +emptyGenesis gp = W.Block + { transactions = [] + , delegations = [] + , header = W.BlockHeader + { slotId = + W.SlotId 0 0 + , blockHeight = + Quantity 0 + , headerHash = + coerce $ W.getGenesisBlockHash gp + , parentHeaderHash = + W.Hash (BS.replicate 32 0) + } + } + +-------------------------------------------------------------------------------- +-- +-- Genesis + + +genesisTip :: Tip ByronBlock +genesisTip = legacyTip genesisPoint genesisBlockNo + where + -- NOTE: ourobouros-network states that: + -- + -- There /is/ no block number if we are at genesis + -- ('genesisBlockNo' is the block number of the first block on the chain). + -- Usage of this function should be phased out. + genesisBlockNo = BlockNo 0 + + +-------------------------------------------------------------------------------- +-- +-- Network Parameters + +-- | Settings for configuring a MainNet network client +mainnetVersionData + :: NodeVersionData +mainnetVersionData = + ( NodeToClientVersionData + { networkMagic = + NetworkMagic $ fromIntegral $ W.getProtocolMagic W.mainnetMagic + } + , nodeToClientCodecCBORTerm + ) + +-- | Settings for configuring a TestNet network client +testnetVersionData + :: W.ProtocolMagic + -> NodeVersionData +testnetVersionData pm = + ( NodeToClientVersionData + { networkMagic = + NetworkMagic $ fromIntegral $ W.getProtocolMagic pm + } + , nodeToClientCodecCBORTerm + ) + +-------------------------------------------------------------------------------- +-- +-- Type Conversions + +-- fixme: maybe just toByronHash = ByronHash . CC.unsafeHashFromBytes +toByronHash :: W.Hash "BlockHeader" -> ByronHash +toByronHash (W.Hash bytes) = + case CC.hashFromBytes bytes of + Just h -> + ByronHash h + Nothing -> + error "unsafeHash: failed to convert bytes to hash?" + +toEpochSlots :: W.EpochLength -> EpochSlots +toEpochSlots = + EpochSlots . fromIntegral . W.unEpochLength + +-- | Magic value for the absence of a block. +hashOfNoParent :: W.Hash "BlockHeader" +hashOfNoParent = W.Hash . BS.pack $ replicate 0 32 + +toPoint + :: W.Hash "Genesis" + -> W.EpochLength + -> W.BlockHeader + -> Point ByronBlock +toPoint genesisH epLength (W.BlockHeader sid _ h _) + | h == (coerce genesisH) = O.GenesisPoint + | otherwise = O.Point $ Point.block (toSlotInEpoch epLength sid) (toByronHash h) + +toSlotInEpoch :: W.EpochLength -> W.SlotId -> SlotNo +toSlotInEpoch epLength = + SlotNo . flatSlot epLength + +-- | SealedTx are the result of rightfully constructed byron transactions so, it +-- is relatively safe to unserialize them from CBOR. +toGenTx :: HasCallStack => W.SealedTx -> GenTx ByronBlock +toGenTx = + fromMempoolPayload + . MempoolTx + . annotateTxAux + . unsafeDeserialiseCbor fromCBOR + . BL.fromStrict + . W.getSealedTx + +byronCodecConfig :: W.GenesisParameters -> CodecConfig ByronBlock +byronCodecConfig W.GenesisParameters{getEpochLength,getEpochStability} = + ByronCodecConfig (toEpochSlots getEpochLength) (SecurityParam k) + where + k = fromIntegral . getQuantity $ getEpochStability + +fromByronBlock :: W.GenesisParameters -> ByronBlock -> W.Block +fromByronBlock gp byronBlk = case byronBlockRaw byronBlk of + ABOBBlock blk -> + mkBlock $ fromTxAux <$> unTxPayload (blockTxPayload blk) + ABOBBoundary _ -> + mkBlock [] + where + W.GenesisParameters genesisHash _ _ epLength _ _ = gp + mkBlock :: [W.Tx] -> W.Block + mkBlock txs = W.Block + { header = W.BlockHeader + { slotId = + fromSlotNo epLength $ blockSlot byronBlk + , blockHeight = + fromBlockNo $ blockNo byronBlk + , headerHash = + fromByronHash $ blockHash byronBlk + , parentHeaderHash = + fromChainHash genesisHash $ headerPrevHash (byronCodecConfig gp) (getHeader byronBlk) + } + , transactions = txs + , delegations = [] + } + +fromTxAux :: TxAux -> W.Tx +fromTxAux txAux = case taTx txAux of + tx@(UnsafeTx inputs outputs _attributes) -> W.Tx + { txId = W.Hash $ CC.hashToBytes $ serializeCborHash tx + + -- TODO: Review 'W.Tx' to not require resolved inputs but only inputs + , resolvedInputs = + (, W.Coin 0) . fromTxIn <$> NE.toList inputs + + , outputs = + fromTxOut <$> NE.toList outputs + + , withdrawals = + mempty + } + +fromTxIn :: TxIn -> W.TxIn +fromTxIn (TxInUtxo id_ ix) = W.TxIn + { inputId = W.Hash $ CC.hashToBytes id_ + , inputIx = ix + } + +fromTxOut :: TxOut -> W.TxOut +fromTxOut (TxOut addr coin) = W.TxOut + { address = W.Address (serialize' addr) + , coin = W.Coin (unsafeGetLovelace coin) + } + +fromByronHash :: ByronHash -> W.Hash "BlockHeader" +fromByronHash = + W.Hash . CC.hashToBytes . unByronHash + +fromChainHash :: W.Hash "Genesis" -> ChainHash ByronBlock -> W.Hash "BlockHeader" +fromChainHash genesisHash = \case + O.GenesisHash -> coerce genesisHash + O.BlockHash h -> fromByronHash h + +fromSlotNo :: W.EpochLength -> SlotNo -> W.SlotId +fromSlotNo epLength (SlotNo sl) = + fromFlatSlot epLength sl + +-- FIXME unsafe conversion (Word64 -> Word32) +fromBlockNo :: BlockNo -> Quantity "block" Word32 +fromBlockNo (BlockNo h) = + Quantity (fromIntegral h) + +fromTip :: W.Hash "Genesis" -> W.EpochLength -> Tip ByronBlock -> W.BlockHeader +fromTip genesisHash epLength tip = case getPoint (getTipPoint tip) of + Origin -> W.BlockHeader + { slotId = W.SlotId 0 0 + , blockHeight = Quantity 0 + , headerHash = coerce genesisHash + , parentHeaderHash = hashOfNoParent + } + At blk -> W.BlockHeader + { slotId = fromSlotNo epLength $ Point.blockPointSlot blk + , blockHeight = fromBlockNo $ getLegacyTipBlockNo tip + , headerHash = fromByronHash $ Point.blockPointHash blk + -- TODO + -- We only use the parentHeaderHash in the + -- 'Cardano.Wallet.Network.BlockHeaders' chain follower only required for + -- Jörmungandr, this is therefore useless to have in 'normal' BlockHeader + -- + -- Yet, since we also serialize these to the database, this requires + -- some non-trivial changes. Not fixing this right now is also a + -- possibility. + , parentHeaderHash = W.Hash "parentHeaderHash - unused in Byron" + } + +fromTxFeePolicy :: TxFeePolicy -> W.FeePolicy +fromTxFeePolicy (TxFeePolicyTxSizeLinear (TxSizeLinear a b)) = + W.LinearFee + (Quantity (lovelaceToDouble a)) + (Quantity (rationalToDouble b)) + (Quantity 0) -- certificates do not exist for Byron + where + lovelaceToDouble :: Lovelace -> Double + lovelaceToDouble = fromIntegral . unsafeGetLovelace + + rationalToDouble :: Rational -> Double + rationalToDouble = fromRational + +fromSlotDuration :: Natural -> W.SlotLength +fromSlotDuration = + W.SlotLength . toEnum . (*1_000_000_000) . fromIntegral + +-- NOTE: Unsafe conversion from Word64 -> Word32 here. +-- +-- Although... Word64 for `k`? For real? +fromBlockCount :: BlockCount -> W.EpochLength +fromBlockCount (BlockCount k) = + W.EpochLength (10 * fromIntegral k) + +-- NOTE: Unsafe conversion from Natural -> Word16 +fromMaxTxSize :: Natural -> Quantity "byte" Word16 +fromMaxTxSize = + Quantity . fromIntegral + +protocolParametersFromPP :: Update.ProtocolParameters -> W.ProtocolParameters +protocolParametersFromPP pp = W.ProtocolParameters + { decentralizationLevel = minBound + , txParameters = W.TxParameters + { getFeePolicy = fromTxFeePolicy $ Update.ppTxFeePolicy pp + , getTxMaxSize = fromMaxTxSize $ Update.ppMaxTxSize pp + } + , desiredNumberOfStakePools = 0 + , minimumUTxOvalue = W.Coin 0 + } + +-- | Extract the protocol parameters relevant to the wallet out of the +-- cardano-chain update state record. +protocolParametersFromUpdateState :: Update.State -> W.ProtocolParameters +protocolParametersFromUpdateState = + protocolParametersFromPP . Update.adoptedProtocolParameters + +-- | Convert non AVVM balances to genesis UTxO. +fromNonAvvmBalances :: GenesisNonAvvmBalances -> [W.TxOut] +fromNonAvvmBalances (GenesisNonAvvmBalances m) = + fromTxOut . uncurry TxOut <$> Map.toList m + +-- | Convert genesis data into blockchain params and an initial set of UTxO +fromGenesisData :: (GenesisData, GenesisHash) -> (W.NetworkParameters, [W.TxOut]) +fromGenesisData (genesisData, genesisHash) = + ( W.NetworkParameters + { genesisParameters = W.GenesisParameters + { getGenesisBlockHash = + W.Hash . CC.hashToBytes . unGenesisHash $ genesisHash + , getGenesisBlockDate = + W.StartTime . gdStartTime $ genesisData + , getSlotLength = + fromSlotDuration . ppSlotDuration . gdProtocolParameters $ genesisData + , getEpochLength = + fromBlockCount . gdK $ genesisData + , getEpochStability = + Quantity . fromIntegral . unBlockCount . gdK $ genesisData + , getActiveSlotCoefficient = + W.ActiveSlotCoefficient 1.0 + } + , protocolParameters = + protocolParametersFromPP . gdProtocolParameters $ genesisData + } + , fromNonAvvmBalances . gdNonAvvmBalances $ genesisData + ) + +fromNetworkMagic :: NetworkMagic -> W.ProtocolMagic +fromNetworkMagic (NetworkMagic magic) = + W.ProtocolMagic (fromIntegral magic) + +fromProtocolMagicId :: ProtocolMagicId -> W.ProtocolMagic +fromProtocolMagicId = W.ProtocolMagic . fromIntegral . unProtocolMagicId diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 70262ac705e..47d587aeab0 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -24,9 +24,7 @@ module Cardano.Wallet.Shelley.Compatibility ( Shelley - , ShelleyBlock , Delegations - , RewardAccounts , NodeVersionData , TPraosStandardCrypto @@ -66,19 +64,20 @@ module Cardano.Wallet.Shelley.Compatibility , getProducer , fromBlockNo - , fromShelleyBlock - , fromShelleyBlock' - , toBlockHeader + , fromCardanoBlock + , poolCertsFromCardanoBlock + , toShelleyBlockHeader , fromShelleyHash - , fromPrevHash + , fromCardanoHash , fromChainHash + , fromPrevHash + , fromShelleyChainHash , fromGenesisData , fromNetworkMagic , toByronNetworkMagic , fromSlotNo , fromTip - , fromTip' - , fromPParams + , fromShelleyPParams , fromNetworkDiscriminant -- * Internal Conversions @@ -94,8 +93,14 @@ import Cardano.Address.Derivation ( XPub, xpubPublicKey ) import Cardano.Api.Shelley.Genesis ( ShelleyGenesis (..) ) +import Cardano.Api.Typed + ( Shelley ) import Cardano.Binary ( fromCBOR, serialize' ) +import Cardano.Chain.Block + ( ABlockOrBoundary (..), blockTxPayload ) +import Cardano.Chain.UTxO + ( unTxPayload ) import Cardano.Crypto.Hash.Class ( Hash (UnsafeHash), getHash ) import Cardano.Slotting.Slot @@ -148,7 +153,7 @@ import Data.Foldable import Data.Map.Strict ( Map ) import Data.Maybe - ( fromMaybe, isJust, mapMaybe ) + ( isJust, mapMaybe ) import Data.Proxy ( Proxy ) import Data.Quantity @@ -167,8 +172,20 @@ import GHC.Stack ( HasCallStack ) import Numeric.Natural ( Natural ) +import Ouroboros.Consensus.Block.Abstract + ( headerPrevHash ) +import Ouroboros.Consensus.Byron.Ledger.Block + ( ByronBlock (..), ByronHash (..) ) +import Ouroboros.Consensus.Cardano.Block + ( CardanoBlock (..), HardForkBlock (..) ) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( OneEraHash (..) ) import Ouroboros.Consensus.Shelley.Ledger ( GenTx, ShelleyHash (..) ) +import Ouroboros.Consensus.Shelley.Ledger + ( Crypto (..) ) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( ShelleyBlock (..) ) import Ouroboros.Consensus.Shelley.Protocol.Crypto ( TPraosStandardCrypto ) import Ouroboros.Network.Block @@ -199,9 +216,11 @@ import Shelley.Spec.Ledger.BaseTypes import Type.Reflection ( Typeable, typeRep ) -import qualified Cardano.Api as Cardano +import qualified Cardano.Api.Typed as Cardano import qualified Cardano.Byron.Codec.Cbor as CBOR +import qualified Cardano.Chain.Block as Chain import qualified Cardano.Chain.Common as Byron +import qualified Cardano.Crypto.Hashing as CC import qualified Cardano.Wallet.Primitive.Types as W import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.Binary.Bech32.TH as Bech32 @@ -222,28 +241,22 @@ import qualified Shelley.Spec.Ledger.Credential as SL import qualified Shelley.Spec.Ledger.Delegation.Certificates as SL import qualified Shelley.Spec.Ledger.Genesis as SL import qualified Shelley.Spec.Ledger.Keys as SL -import qualified Shelley.Spec.Ledger.LedgerState as SL import qualified Shelley.Spec.Ledger.PParams as SL import qualified Shelley.Spec.Ledger.Scripts as SL import qualified Shelley.Spec.Ledger.Tx as SL import qualified Shelley.Spec.Ledger.TxData as SL import qualified Shelley.Spec.Ledger.UTxO as SL -data Shelley - type NodeVersionData = (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) --- | Concrete block type, using shelley crypto. -type ShelleyBlock = O.ShelleyBlock TPraosStandardCrypto +-- Old Cardano.Api +type ShelleyCredentialStaking crypto = SL.Credential 'SL.Staking crypto -- | Shorthand for shelley delegations. Maps staking credentials to stake pool -- key hash. -type Delegations = - Map Cardano.ShelleyCredentialStaking Cardano.ShelleyVerificationKeyHashStakePool - --- | Concrete type for a shelley reward account. -type RewardAccounts = SL.RewardAccounts TPraosStandardCrypto +type Delegations crypto = + Map (ShelleyCredentialStaking crypto) (SL.KeyHash SL.StakePool crypto) -------------------------------------------------------------------------------- -- @@ -278,7 +291,7 @@ emptyGenesis gp = W.Block -- Genesis -genesisTip :: Tip (O.ShelleyBlock TPraosStandardCrypto) +genesisTip :: Tip (CardanoBlock sc) genesisTip = legacyTip genesisPoint genesisBlockNo where -- NOTE: ourobouros-network states that: @@ -338,25 +351,25 @@ toPoint :: W.Hash "Genesis" -> W.EpochLength -> W.BlockHeader - -> Point ShelleyBlock + -> Point (CardanoBlock sc) toPoint genesisH epLength (W.BlockHeader sid _ h _) | h == (coerce genesisH) = O.GenesisPoint - | otherwise = O.Point $ Point.block (toSlotNo epLength sid) (toShelleyHash h) + | otherwise = error "toPoint HFB" + -- | otherwise = Point $ Point.block (toSlotNo epLength sid) (toShelleyHash h) toSlotNo :: W.EpochLength -> W.SlotId -> SlotNo toSlotNo epLength = SlotNo . flatSlot epLength -toBlockHeader - :: W.Hash "Genesis" +toShelleyBlockHeader + :: O.Crypto sc + => W.Hash "Genesis" -> W.EpochLength - -> ShelleyBlock + -> ShelleyBlock sc -> W.BlockHeader -toBlockHeader genesisHash epLength blk = - let - O.ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk - in - W.BlockHeader +toShelleyBlockHeader genesisHash epLength blk = + let ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk + in W.BlockHeader { slotId = fromSlotNo epLength $ SL.bheaderSlotNo header , blockHeight = @@ -368,48 +381,87 @@ toBlockHeader genesisHash epLength blk = SL.bheaderPrev header } -getProducer :: ShelleyBlock -> W.PoolId -getProducer blk = - let - O.ShelleyBlock (SL.Block (SL.BHeader header _) _) _ = blk - in - fromPoolKeyHash $ SL.hashKey (SL.bheaderVk header) +getProducer :: O.Crypto sc => ShelleyBlock sc -> W.PoolId +getProducer (ShelleyBlock (SL.Block (SL.BHeader header _) _) _) = + fromPoolKeyHash $ SL.hashKey (SL.bheaderVk header) -fromShelleyBlock - :: W.Hash "Genesis" +fromCardanoBlock + :: O.Crypto sc + => W.Hash "Genesis" -> W.EpochLength - -> ShelleyBlock + -> CardanoBlock sc -> W.Block -fromShelleyBlock genesisHash epLength blk = - let - O.ShelleyBlock (SL.Block _ txSeq) _ = blk - SL.TxSeq txs' = txSeq - (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' - - in W.Block - { header = toBlockHeader genesisHash epLength blk - , transactions = txs - , delegations = mconcat certs - } +fromCardanoBlock genesisHash epLength = \case + BlockByron blk -> + fromByronBlock blk + BlockShelley blk -> + fromShelleyBlock blk + where + fromShelleyBlock blk@(ShelleyBlock (SL.Block _ (SL.TxSeq txs')) headerHash) = + let + (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' + + in W.Block + { header = toShelleyBlockHeader genesisHash epLength blk + , transactions = txs + , delegations = mconcat certs + } -fromShelleyBlock' - :: W.EpochLength - -> ShelleyBlock + fromByronBlock :: ByronBlock -> W.Block + fromByronBlock byronBlk = case byronBlockRaw byronBlk of + ABOBBlock blk -> + mkBlock $ fromTxAux <$> unTxPayload (blockTxPayload blk) + ABOBBoundary _ -> + mkBlock [] + where + mkBlock :: [W.Tx] -> W.Block + mkBlock txs = W.Block + { header = W.BlockHeader + { slotId = + fromSlotNo epLength $ O.blockSlot byronBlk + , blockHeight = + fromBlockNo $ O.blockNo byronBlk + , headerHash = + fromByronHash $ O.blockHash byronBlk + , parentHeaderHash = + fromByronChainHash genesisHash $ headerPrevHash cfg (O.getHeader byronBlk) + } + , transactions = txs + , delegations = [] + } + -- cfg = byronCodecConfig gp -- wat? + cfg = error "fixme: byronCodecConfig" + -- fromTxAux :: TxAux -> W.Tx + fromTxAux _ = error "fixme: fromTxAux" + +poolCertsFromCardanoBlock + :: O.Crypto sc + => W.EpochLength + -> CardanoBlock sc -> (W.SlotId, [W.PoolCertificate]) -fromShelleyBlock' epLength blk = - let - O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk - SL.TxSeq txs' = txSeq - (_, _, certs) = unzip3 $ map fromShelleyTx $ toList txs' - in - (fromSlotNo epLength $ SL.bheaderSlotNo header, mconcat certs) +poolCertsFromCardanoBlock epLength = \case + BlockByron blk -> + (fromSlotNo epLength $ O.blockSlot blk, []) + BlockShelley (ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _) -> + let + SL.TxSeq txs' = txSeq + (_, _, certs) = unzip3 $ map fromShelleyTx $ toList txs' + in + (fromSlotNo epLength $ SL.bheaderSlotNo header, mconcat certs) fromShelleyHash :: ShelleyHash c -> W.Hash "BlockHeader" fromShelleyHash (ShelleyHash (SL.HashHeader h)) = W.Hash (getHash h) +fromCardanoHash :: O.HeaderHash (CardanoBlock sc) -> W.Hash "BlockHeader" +fromCardanoHash = W.Hash . getOneEraHash + +fromByronHash :: ByronHash -> W.Hash "BlockHeader" +fromByronHash = + W.Hash . CC.hashToBytes . unByronHash + fromPrevHash :: W.Hash "BlockHeader" - -> SL.PrevHash TPraosStandardCrypto + -> SL.PrevHash sc -> W.Hash "BlockHeader" fromPrevHash genesisHash = \case SL.GenesisHash -> genesisHash @@ -417,12 +469,28 @@ fromPrevHash genesisHash = \case fromChainHash :: W.Hash "Genesis" - -> ChainHash ShelleyBlock + -> ChainHash (CardanoBlock sc) -> W.Hash "BlockHeader" fromChainHash genesisHash = \case + O.GenesisHash -> coerce genesisHash + O.BlockHash (OneEraHash h) -> W.Hash h + +fromShelleyChainHash + :: W.Hash "Genesis" + -> ChainHash (ShelleyBlock sc) + -> W.Hash "BlockHeader" +fromShelleyChainHash genesisHash = \case O.GenesisHash -> coerce genesisHash O.BlockHash h -> fromShelleyHash h +fromByronChainHash + :: W.Hash "Genesis" + -> ChainHash ByronBlock + -> W.Hash "BlockHeader" +fromByronChainHash genesisHash = \case + O.GenesisHash -> coerce genesisHash + O.BlockHash h -> fromByronHash h + fromSlotNo :: W.EpochLength -> SlotNo -> W.SlotId fromSlotNo epLength (SlotNo sl) = fromFlatSlot epLength sl @@ -435,7 +503,7 @@ fromBlockNo (BlockNo h) = fromTip :: W.Hash "Genesis" -> W.EpochLength - -> Tip ShelleyBlock + -> Tip (CardanoBlock sc) -> W.BlockHeader fromTip genesisHash epLength tip = case getPoint (getTipPoint tip) of Origin -> W.BlockHeader @@ -447,7 +515,7 @@ fromTip genesisHash epLength tip = case getPoint (getTipPoint tip) of At blk -> W.BlockHeader { slotId = fromSlotNo epLength $ Point.blockPointSlot blk , blockHeight = fromBlockNo $ getLegacyTipBlockNo tip - , headerHash = fromShelleyHash $ Point.blockPointHash blk + , headerHash = fromCardanoHash $ Point.blockPointHash blk -- TODO -- We only use the parentHeaderHash in the -- 'Cardano.Wallet.Network.BlockHeaders' chain follower only required for @@ -459,21 +527,13 @@ fromTip genesisHash epLength tip = case getPoint (getTipPoint tip) of , parentHeaderHash = W.Hash "parentHeaderHash - unused in Shelley" } -fromTip' :: W.GenesisParameters -> Tip ShelleyBlock -> W.BlockHeader -fromTip' gp = fromTip getGenesisBlockHash getEpochLength - where - W.GenesisParameters - { getEpochLength - , getGenesisBlockHash - } = gp - -- NOTE: Unsafe conversion from Natural -> Word16 fromMaxTxSize :: Natural -> Quantity "byte" Word16 fromMaxTxSize = Quantity . fromIntegral -fromPParams :: SL.PParams -> W.ProtocolParameters -fromPParams pp = W.ProtocolParameters +fromShelleyPParams :: SL.PParams -> W.ProtocolParameters +fromShelleyPParams pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp , txParameters = @@ -519,14 +579,17 @@ txParametersFromPParams txParametersFromPParams pp = W.TxParameters { getFeePolicy = W.LinearFee (Quantity (naturalToDouble (SL._minfeeB pp))) - (Quantity (fromIntegral (SL._minfeeA pp))) - (Quantity (fromIntegral (SL._keyDeposit pp))) + (Quantity (naturalToDouble (SL._minfeeA pp))) + (Quantity (coinToDouble (SL._keyDeposit pp))) , getTxMaxSize = fromMaxTxSize $ SL._maxTxSize pp } where naturalToDouble :: Natural -> Double naturalToDouble = fromIntegral + coinToDouble :: SL.Coin -> Double + coinToDouble (SL.Coin c) = fromIntegral c + desiredNumberOfStakePoolsFromPParams :: SL.PParams -> Word16 @@ -535,12 +598,13 @@ desiredNumberOfStakePoolsFromPParams pp = fromIntegral (SL._nOpt pp) minimumUTxOvalueFromPParams :: SL.PParams -> W.Coin -minimumUTxOvalueFromPParams pp = W.Coin . fromIntegral $ SL._minUTxOValue pp +minimumUTxOvalueFromPParams pp = toWalletCoin $ SL._minUTxOValue pp -- | Convert genesis data into blockchain params and an initial set of UTxO fromGenesisData - :: ShelleyGenesis TPraosStandardCrypto - -> [(SL.Addr TPraosStandardCrypto, SL.Coin)] + :: forall crypto. (O.Crypto crypto) + => ShelleyGenesis crypto + -> [(SL.Addr crypto, SL.Coin)] -> (W.NetworkParameters, W.Block) fromGenesisData g initialFunds = ( W.NetworkParameters @@ -557,7 +621,7 @@ fromGenesisData g initialFunds = , getActiveSlotCoefficient = W.ActiveSlotCoefficient . fromRational . sgActiveSlotsCoeff $ g } - , protocolParameters = fromPParams . sgProtocolParams $ g + , protocolParameters = fromShelleyPParams . sgProtocolParams $ g } , genesisBlockFromTxOuts initialFunds ) @@ -576,7 +640,7 @@ fromGenesisData g initialFunds = -- block0 on jormungandr. This function is a method to deal with the -- discrepancy. genesisBlockFromTxOuts - :: [(SL.Addr TPraosStandardCrypto, SL.Coin)] -> W.Block + :: [(SL.Addr crypto, SL.Coin)] -> W.Block genesisBlockFromTxOuts outs = W.Block { delegations = [] , header = W.BlockHeader @@ -599,7 +663,7 @@ fromGenesisData g initialFunds = mempty where W.TxIn pseudoHash _ = fromShelleyTxIn $ - SL.initialFundsPseudoTxIn @TPraosStandardCrypto addr + SL.initialFundsPseudoTxIn @crypto addr fromNetworkMagic :: NetworkMagic -> W.ProtocolMagic fromNetworkMagic (NetworkMagic magic) = @@ -613,7 +677,7 @@ fromPoolId :: SL.KeyHash 'SL.StakePool crypto -> W.PoolId fromPoolId (SL.KeyHash x) = W.PoolId $ getHash x fromPoolDistr - :: SL.PoolDistr TPraosStandardCrypto + :: SL.PoolDistr crypto -> Map W.PoolId Percentage fromPoolDistr = Map.map (unsafeMkPercentage . fst) @@ -622,10 +686,10 @@ fromPoolDistr = -- NOTE: This function disregards results that are using staking keys fromNonMyopicMemberRewards - :: O.NonMyopicMemberRewards TPraosStandardCrypto + :: O.NonMyopicMemberRewards crypto -> Map (Either W.Coin W.ChimericAccount) (Map W.PoolId (Quantity "lovelace" Word64)) fromNonMyopicMemberRewards = - Map.map (Map.map (Quantity . fromIntegral) . Map.mapKeys fromPoolId) + Map.map (Map.map lovelaceFromCoin . Map.mapKeys fromPoolId) . Map.mapKeys (bimap fromShelleyCoin fromStakeCredential) . O.unNonMyopicMemberRewards @@ -642,8 +706,9 @@ optimumNumberOfPools = unsafeConvert . SL._nOpt -- | SealedTx are the result of rightfully constructed shelley transactions so, it -- is relatively safe to unserialize them from CBOR. -toGenTx :: HasCallStack => W.SealedTx -> GenTx ShelleyBlock -toGenTx = unsafeDeserialiseCbor fromCBOR +toGenTx :: HasCallStack => W.SealedTx -> GenTx (CardanoBlock c) +toGenTx = -- unsafeDeserialiseCbor fromCBOR + error "fixme: deserialise CardanoBlock" . BL.fromStrict . W.getSealedTx @@ -680,7 +745,8 @@ toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c -- NOTE: For resolved inputs we have to pass in a dummy value of 0. fromShelleyTx - :: SL.Tx TPraosStandardCrypto + :: Crypto crypto + => SL.Tx crypto -> ( W.Tx , [W.DelegationCertificate] , [W.PoolCertificate] @@ -695,14 +761,14 @@ fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs wdrls _ _ _ _) _ _) = , mapMaybe fromShelleyRegistrationCert (toList certs) ) -fromShelleyWdrl :: SL.Wdrl TPraosStandardCrypto -> Map W.ChimericAccount W.Coin +fromShelleyWdrl :: SL.Wdrl crypto -> Map W.ChimericAccount W.Coin fromShelleyWdrl (SL.Wdrl wdrl) = Map.fromList $ bimap (fromStakeCredential . SL.getRwdCred) fromShelleyCoin <$> Map.toList wdrl -- Convert & filter Shelley certificate into delegation certificate. Returns -- 'Nothing' if certificates aren't delegation certificate. fromShelleyDelegationCert - :: SL.DCert TPraosStandardCrypto + :: SL.DCert crypto -> Maybe W.DelegationCertificate fromShelleyDelegationCert = \case SL.DCertDeleg (SL.Delegate delegation) -> @@ -722,7 +788,7 @@ fromShelleyDelegationCert = \case -- Convert & filter Shelley certificate into delegation certificate. Returns -- 'Nothing' if certificates aren't delegation certificate. fromShelleyRegistrationCert - :: SL.DCert TPraosStandardCrypto + :: SL.DCert crypto -> Maybe (W.PoolCertificate) fromShelleyRegistrationCert = \case SL.DCertPool (SL.RegPool pp) -> Just $ Registration @@ -730,8 +796,8 @@ fromShelleyRegistrationCert = \case { W.poolId = fromPoolKeyHash $ SL._poolPubKey pp , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp) , W.poolMargin = fromUnitInterval (SL._poolMargin pp) - , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp) - , W.poolPledge = Quantity $ fromIntegral (SL._poolPledge pp) + , W.poolCost = lovelaceFromCoin (SL._poolCost pp) + , W.poolPledge = lovelaceFromCoin (SL._poolPledge pp) , W.poolMetadata = fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) } ) @@ -744,27 +810,38 @@ fromShelleyRegistrationCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing +lovelaceFromCoin :: SL.Coin -> Quantity "lovelace" Word64 +lovelaceFromCoin = Quantity . unsafeCoinToWord64 + +toWalletCoin :: SL.Coin -> W.Coin +toWalletCoin = W.Coin . unsafeCoinToWord64 + +-- | The reverse of 'word64ToCoin', without overflow checks. +unsafeCoinToWord64 :: SL.Coin -> Word64 +unsafeCoinToWord64 (SL.Coin c) = fromIntegral c + fromPoolMetaData :: SL.PoolMetaData -> (W.StakePoolMetadataUrl, W.StakePoolMetadataHash) fromPoolMetaData meta = ( W.StakePoolMetadataUrl (urlToText (SL._poolMDUrl meta)) , W.StakePoolMetadataHash (SL._poolMDHash meta) ) + -- | Convert a stake credentials to a 'ChimericAccount' type. Unlike with -- Jörmungandr, the Chimeric payload doesn't represent a public key but a HASH -- of a public key. -fromStakeCredential :: Cardano.ShelleyCredentialStaking -> W.ChimericAccount +fromStakeCredential :: ShelleyCredentialStaking crypto -> W.ChimericAccount fromStakeCredential = \case SL.ScriptHashObj (SL.ScriptHash h) -> W.ChimericAccount (getHash h) SL.KeyHashObj (SL.KeyHash h) -> W.ChimericAccount (getHash h) -fromPoolKeyHash :: SL.KeyHash rol TPraosStandardCrypto -> W.PoolId +fromPoolKeyHash :: SL.KeyHash rol sc -> W.PoolId fromPoolKeyHash (SL.KeyHash h) = W.PoolId (getHash h) -fromOwnerKeyHash :: SL.KeyHash 'SL.Staking TPraosStandardCrypto -> W.PoolOwner +fromOwnerKeyHash :: SL.KeyHash 'SL.Staking crypto -> W.PoolOwner fromOwnerKeyHash (SL.KeyHash h) = W.PoolOwner (getHash h) @@ -795,7 +872,7 @@ toByronNetworkMagic pm@(W.ProtocolMagic magic) = Byron.NetworkTestnet (fromIntegral magic) -- NOTE: Arguably breaks naming conventions. Perhaps fromCardanoSignedTx instead -toSealed :: SL.Tx TPraosStandardCrypto -> (W.Tx, W.SealedTx) +toSealed :: Crypto crypto => SL.Tx crypto -> (W.Tx, W.SealedTx) toSealed tx = let (wtx, _, _) = fromShelleyTx tx @@ -807,15 +884,7 @@ toCardanoTxId (W.Hash h) = Cardano.TxId $ UnsafeHash h toCardanoTxIn :: W.TxIn -> Cardano.TxIn toCardanoTxIn (W.TxIn tid ix) = - Cardano.TxIn (toCardanoTxId tid) (fromIntegral ix) - --- NOTE: Only creates Shelley addresses. -toCardanoAddress :: W.Address -> Cardano.Address -toCardanoAddress (W.Address bytes) = - Cardano.AddressShelley - . fromMaybe (error "toCardanoAddress: invalid address") - . SL.deserialiseAddr @TPraosStandardCrypto - $ bytes + Cardano.TxIn (toCardanoTxId tid) (Cardano.TxIx (fromIntegral ix)) toCardanoLovelace :: W.Coin -> Cardano.Lovelace toCardanoLovelace (W.Coin c) = Cardano.Lovelace $ safeCast c @@ -823,31 +892,33 @@ toCardanoLovelace (W.Coin c) = Cardano.Lovelace $ safeCast c safeCast :: Word64 -> Integer safeCast = fromIntegral -toCardanoTxOut :: W.TxOut -> Cardano.TxOut -toCardanoTxOut (W.TxOut addr coin) = - Cardano.TxOut (toCardanoAddress addr) (toCardanoLovelace coin) +toCardanoTxOut :: Cardano.NetworkId -> Cardano.PaymentCredential -> Cardano.StakeAddressReference -> W.TxOut -> Cardano.TxOut Cardano.Shelley +toCardanoTxOut net cred stake (W.TxOut addr coin) = + Cardano.TxOut addr' (toCardanoLovelace coin) + where + addr' = Cardano.makeShelleyAddress net cred stake -- | Convert from a chimeric account address (which is a hash of a public key) -- to a shelley ledger stake credential. -toStakeCredential :: W.ChimericAccount -> Cardano.ShelleyCredentialStaking -toStakeCredential = Cardano.mkShelleyStakingCredential +toStakeCredential :: W.ChimericAccount -> SL.StakeCredential crypto +toStakeCredential = SL.KeyHashObj . SL.KeyHash . UnsafeHash . W.unChimericAccount toStakeKeyDeregCert :: XPub -> Cardano.Certificate toStakeKeyDeregCert xpub = - Cardano.shelleyDeregisterStakingAddress - (SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) + Cardano.makeStakeAddressDeregistrationCertificate + (Cardano.StakeCredentialByKey $ Cardano.StakeKeyHash $ SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) toStakeKeyRegCert :: XPub -> Cardano.Certificate toStakeKeyRegCert xpub = - Cardano.shelleyRegisterStakingAddress - (SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) + Cardano.makeStakeAddressRegistrationCertificate + (Cardano.StakeCredentialByKey $ Cardano.StakeKeyHash $ SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) toStakePoolDlgCert :: XPub -> W.PoolId -> Cardano.Certificate toStakePoolDlgCert xpub (W.PoolId pid) = - Cardano.shelleyDelegateStake - (SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) - (SL.KeyHash $ UnsafeHash pid) + Cardano.makeStakeAddressDelegationCertificate + (Cardano.StakeCredentialByKey $ Cardano.StakeKeyHash $ SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) + (Cardano.StakePoolKeyHash $ SL.KeyHash $ UnsafeHash pid) {------------------------------------------------------------------------------- Address Encoding / Decoding @@ -893,7 +964,7 @@ _decodeStakeAddress _decodeStakeAddress serverNetwork txt = do (_, dp) <- left (const errBech32) $ Bech32.decodeLenient txt bytes <- maybe (Left errBech32) Right $ dataPartToBytes dp - rewardAcnt <- runGetOrFail' SL.getRewardAcnt bytes + rewardAcnt <- runGetOrFail' (SL.getRewardAcnt @TPraosStandardCrypto) bytes guardNetwork (SL.getRwdNetwork rewardAcnt) serverNetwork diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index 3bea3acb98d..a194fc91d45 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -38,6 +39,8 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Wallet.Byron.Compatibility + ( protocolParametersFromUpdateState ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network @@ -51,18 +54,13 @@ import Cardano.Wallet.Network ) import Cardano.Wallet.Shelley.Compatibility ( Delegations - , RewardAccounts - , Shelley - , ShelleyBlock - , TPraosStandardCrypto + , fromCardanoHash , fromChainHash , fromNonMyopicMemberRewards - , fromPParams , fromPoolDistr - , fromShelleyHash + , fromShelleyPParams , fromSlotNo , fromTip - , fromTip' , optimumNumberOfPools , toGenTx , toPoint @@ -88,6 +86,7 @@ import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM ( MonadSTM , TQueue + , TVar , atomically , newTMVarM , newTQueue @@ -137,12 +136,23 @@ import GHC.Stack ( HasCallStack ) import Network.Mux ( MuxError (..), MuxErrorType (..), WithMuxBearer (..) ) +import Ouroboros.Consensus.Cardano + ( CardanoBlock ) +import Ouroboros.Consensus.Cardano.Block + ( CardanoApplyTxErr, CardanoEras, CodecConfig (..), Query (..) ) +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( MismatchEraInfo ) import Ouroboros.Consensus.Network.NodeToClient ( ClientCodecs, Codecs' (..), DefaultCodecs, clientCodecs, defaultCodecs ) import Ouroboros.Consensus.Shelley.Ledger - ( GenTx, Query (..), ShelleyNodeToClientVersion (..) ) + ( Crypto (..) ) +import Ouroboros.Consensus.Shelley.Ledger + ( GenTx ) import Ouroboros.Consensus.Shelley.Ledger.Config ( CodecConfig (..) ) +import Ouroboros.Consensus.Shelley.Protocol + ( TPraosCrypto ) import Ouroboros.Network.Block ( Point , SlotNo (..) @@ -215,23 +225,25 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Ouroboros.Consensus.Shelley.Ledger as OC +import qualified Ouroboros.Consensus.Byron.Ledger as Byron +import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import qualified Ouroboros.Network.Point as Point import qualified Shelley.Spec.Ledger.Coin as SL -import qualified Shelley.Spec.Ledger.PParams as SL +import qualified Shelley.Spec.Ledger.LedgerState as SL {- HLINT ignore "Use readTVarIO" -} -- | Network layer cursor for Shelley. Mostly useless since the protocol itself is -- stateful and the node's keep track of the associated connection's cursor. -data instance Cursor (m Shelley) = Cursor +data instance Cursor (m (CardanoBlock sc)) = Cursor (Async ()) - (Point ShelleyBlock) - (TQueue m (ChainSyncCmd ShelleyBlock m)) + (Point (CardanoBlock sc)) + (TQueue m (ChainSyncCmd (CardanoBlock sc) m)) -- | Create an instance of the network layer withNetworkLayer - :: Tracer IO NetworkLayerLog + :: forall sc a. (TPraosCrypto sc) + => Tracer IO (NetworkLayerLog sc) -- ^ Logging of network layer startup -> W.NetworkParameters -- ^ Initial blockchain parameters @@ -239,7 +251,7 @@ withNetworkLayer -- ^ Socket for communicating with the node -> (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) -- ^ Codecs for the node's client - -> (NetworkLayer IO (IO Shelley) ShelleyBlock -> IO a) + -> (NetworkLayer IO (IO (CardanoBlock sc)) (CardanoBlock sc) -> IO a) -- ^ Callback function with the network layer -> IO a withNetworkLayer tr np addrInfo versionData action = do @@ -256,7 +268,7 @@ withNetworkLayer tr np addrInfo versionData action = do queryRewardQ <- connectDelegationRewardsClient handlers - nodeTipVar <- atomically $ newTVar TipGenesis + nodeTipVar <- atomically $ newTVar TipGenesis :: IO (TVar IO (Tip (CardanoBlock sc))) let updateNodeTip = readChan nodeTipChan >>= (atomically . writeTVar nodeTipVar) link =<< async (forever updateNodeTip) @@ -269,7 +281,7 @@ withNetworkLayer tr np addrInfo versionData action = do , cursorSlotId = _cursorSlotId , getProtocolParameters = atomically $ readTVar protocolParamsVar , postTx = _postTx localTxSubmissionQ - , stakeDistribution = _stakeDistribution queryRewardQ + -- , stakeDistribution = _stakeDistribution queryRewardQ , getAccountBalance = _getAccountBalance nodeTipVar queryRewardQ } where @@ -335,15 +347,16 @@ withNetworkLayer tr np addrInfo versionData action = do let bh = fromTip' gp tip liftIO $ traceWith tr $ MsgGetRewardAccountBalance bh acct let cred = toStakeCredential acct - let q = OC.GetFilteredDelegationsAndRewardAccounts (Set.singleton cred) + let q = QueryIfCurrentShelley (Shelley.GetFilteredDelegationsAndRewardAccounts (Set.singleton cred)) let cmd = CmdQueryLocalState (getTipPoint tip) q liftIO (queryRewardQ `send` cmd) >>= \case - Right (deleg, rewardAccounts) -> do + Right (Right (deleg, rewardAccounts)) -> do liftIO $ traceWith tr $ MsgAccountDelegationAndRewards acct deleg rewardAccounts case Map.elems rewardAccounts of [SL.Coin amt] -> pure (Quantity (fromIntegral amt)) _ -> throwE $ ErrGetAccountBalanceAccountNotFound acct + Right (Left _) -> pure minBound -- wrong era Left acqFail -> do -- NOTE: this could possibly happen in rare circumstances when -- the chain is switched and the local state query is made @@ -366,18 +379,19 @@ withNetworkLayer tr np addrInfo versionData action = do SubmitSuccess -> pure () SubmitFail err -> throwE $ ErrPostTxBadRequest $ T.pack (show err) + handleQueryFailure :: forall e r. Show e => IO (Either e r) -> ExceptT ErrNetworkUnavailable IO r handleQueryFailure = withExceptT - (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected" ++ show e) . ExceptT + (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected " ++ show e) . ExceptT _stakeDistribution queue pt coin = do stakeMap <- fromPoolDistr <$> handleQueryFailure - (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution) + (queue `send` CmdQueryLocalState pt Shelley.GetStakeDistribution) let toStake = Set.singleton $ Left $ toShelleyCoin coin liftIO $ traceWith tr $ MsgWillQueryRewardsForStake coin rewardsPerAccount <- fromNonMyopicMemberRewards <$> handleQueryFailure - (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake)) + (queue `send` CmdQueryLocalState pt (Shelley.GetNonMyopicMemberRewards toStake)) pparams <- handleQueryFailure - (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams) + (queue `send` CmdQueryLocalState pt Shelley.GetCurrentPParams) let rewardMap = fromMaybe (error "stakeDistribution: requested rewards not included in response") @@ -401,8 +415,8 @@ withNetworkLayer tr np addrInfo versionData action = do bracketTracer (contramap (MsgWatcherUpdate header) tr) $ cb header -type instance GetStakeDistribution (IO Shelley) m - = (Point ShelleyBlock +type instance GetStakeDistribution (CardanoBlock sc) (IO (CardanoBlock sc)) m + = (Point (CardanoBlock sc) -> W.Coin -> ExceptT ErrNetworkUnavailable m NodePoolLsqData) @@ -419,6 +433,9 @@ instance Buildable NodePoolLsqData where , "Optimum number of pools: " <> pretty nOpt ] +fromTip' :: Crypto sc => W.GenesisParameters -> Tip (CardanoBlock sc) -> W.BlockHeader +fromTip' _ _ = error "fixme: fromTip' should be removed" + -------------------------------------------------------------------------------- -- -- Network Client @@ -443,11 +460,11 @@ type NetworkClient m = OuroborosApplication -- | Construct a network client with the given communication channel, for the -- purposes of syncing blocks to a single wallet. mkWalletClient - :: (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m) + :: (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m, Crypto sc, TPraosCrypto sc) => Tracer m (ChainSyncLog Text Text) -> W.GenesisParameters -- ^ Static blockchain parameters - -> TQueue m (ChainSyncCmd ShelleyBlock m) + -> TQueue m (ChainSyncCmd (CardanoBlock sc) m) -- ^ Communication channel with the ChainSync client -> m (NetworkClient m) mkWalletClient tr gp chainSyncQ = do @@ -475,17 +492,17 @@ mkWalletClient tr gp chainSyncQ = do [ "(slotNo " , T.pack $ show $ unSlotNo $ Point.blockPointSlot blk , ", " - , pretty $ fromShelleyHash $ Point.blockPointHash blk + , pretty $ fromCardanoHash $ Point.blockPointHash blk , ")" ] -- | Construct a network client with the given communication channel, for the -- purposes of querying delegations and rewards. mkDelegationRewardsClient - :: forall m. (MonadThrow m, MonadST m, MonadTimer m) - => Tracer m NetworkLayerLog + :: forall sc m. (MonadThrow m, MonadST m, MonadTimer m, TPraosCrypto sc) + => Tracer m (NetworkLayerLog sc) -- ^ Base trace for underlying protocols - -> TQueue m (LocalStateQueryCmd ShelleyBlock m) + -> TQueue m (LocalStateQueryCmd (CardanoBlock sc) m) -- ^ Communication channel with the LocalStateQuery client -> NetworkClient m mkDelegationRewardsClient tr queryRewardQ = @@ -507,11 +524,13 @@ mkDelegationRewardsClient tr queryRewardQ = tr' = contramap (MsgLocalStateQuery DelegationRewardsClient) tr codec = cStateQueryCodec serialisedCodecs -codecs :: MonadST m => ClientCodecs ShelleyBlock m -codecs = clientCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 +codecs :: (MonadST m, TPraosCrypto sc) => ClientCodecs (CardanoBlock sc) m +codecs = clientCodecs cfg CardanoNodeToClientVersion1 + where cfg = CardanoCodecConfig (error "fixme: byron codec config") ShelleyCodecConfig -serialisedCodecs :: MonadST m => DefaultCodecs ShelleyBlock m -serialisedCodecs = defaultCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 +serialisedCodecs :: (MonadST m, TPraosCrypto sc) => DefaultCodecs (CardanoBlock sc) m +serialisedCodecs = defaultCodecs cfg CardanoNodeToClientVersion1 + where cfg = CardanoCodecConfig (error "fixme: byron codec config") ShelleyCodecConfig -- | Construct a network client with the given communication channel, for the -- purpose of: @@ -520,18 +539,18 @@ serialisedCodecs = defaultCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 -- * Tracking the node tip -- * Tracking the latest protocol parameters state. mkTipSyncClient - :: forall m. (HasCallStack, MonadThrow m, MonadST m, MonadTimer m) - => Tracer m NetworkLayerLog + :: forall sc m. (HasCallStack, MonadThrow m, MonadST m, MonadTimer m, TPraosCrypto sc) + => Tracer m (NetworkLayerLog sc) -- ^ Base trace for underlying protocols -> W.NetworkParameters -- ^ Initial blockchain parameters -> TQueue m (LocalTxSubmissionCmd - (GenTx ShelleyBlock) - (OC.ApplyTxError TPraosStandardCrypto) - (m)) + (GenTx (CardanoBlock sc)) + (CardanoApplyTxErr sc) + m) -- ^ Communication channel with the LocalTxSubmission client - -> (Tip ShelleyBlock -> m ()) + -> (Tip (CardanoBlock sc) -> m ()) -- ^ Notifier callback for when tip changes -> (W.ProtocolParameters -> m ()) -- ^ Notifier callback for when parameters for tip change. @@ -546,28 +565,35 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do let queryLocalState - :: Point ShelleyBlock + :: Point (CardanoBlock sc) -> m () queryLocalState pt = do + pp <- localStateQueryQ `send` + CmdQueryLocalState pt (QueryIfCurrentShelley Shelley.GetCurrentPParams) + handleParamsUpdate fromShelleyPParams pp + st <- localStateQueryQ `send` - CmdQueryLocalState pt OC.GetCurrentPParams - handleLocalState st + CmdQueryLocalState pt (QueryIfCurrentByron Byron.GetUpdateInterfaceState) + handleParamsUpdate protocolParametersFromUpdateState st - handleLocalState - :: Either AcquireFailure SL.PParams + handleParamsUpdate + :: (p -> W.ProtocolParameters) + -> Either AcquireFailure (Either (MismatchEraInfo (CardanoEras sc)) p) -> m () - handleLocalState = \case + handleParamsUpdate convert = \case Left (e :: AcquireFailure) -> traceWith tr $ MsgLocalStateQueryError TipSyncClient $ show e - Right ls -> - onPParamsUpdate' $ fromPParams ls + Right (Right ls) -> + onPParamsUpdate' $ convert ls + Right (Left mismatch) -> + traceWith tr $ MsgLocalStateQueryEraMismatch mismatch W.GenesisParameters { getGenesisBlockHash , getEpochLength } = W.genesisParameters np - onTipUpdate' <- debounce @(Tip ShelleyBlock) @m $ \tip' -> do + onTipUpdate' <- debounce @(Tip (CardanoBlock sc)) @m $ \tip' -> do let tip = castTip tip' traceWith tr $ MsgNodeTip $ fromTip getGenesisBlockHash getEpochLength tip @@ -629,7 +655,7 @@ doNothingProtocol = -- -- >>> connectClient (mkWalletClient tr gp queue) mainnetVersionData addrInfo connectClient - :: Tracer IO NetworkLayerLog + :: Tracer IO (NetworkLayerLog sc) -> [RetryStatus -> Handler IO Bool] -> NetworkClient IO -> (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) @@ -653,7 +679,7 @@ connectClient tr handlers client (vData, vCodec) addr = withIOManager $ \iocp -> -- | Handlers that are retrying on every connection lost. retryOnConnectionLost - :: Tracer IO NetworkLayerLog + :: Tracer IO (NetworkLayerLog sc) -> [RetryStatus -> Handler IO Bool] retryOnConnectionLost tr = [ const $ Handler $ handleIOException tr' True @@ -664,7 +690,7 @@ retryOnConnectionLost tr = -- | Handlers that are failing if the connection is lost failOnConnectionLost - :: Tracer IO NetworkLayerLog + :: Tracer IO (NetworkLayerLog sc) -> [RetryStatus -> Handler IO Bool] failOnConnectionLost tr = [ const $ Handler $ handleIOException tr' False @@ -720,37 +746,39 @@ handleMuxError tr onResourceVanished = pure . errorType >=> \case Logging -------------------------------------------------------------------------------} -data NetworkLayerLog - = MsgCouldntConnect Int - | MsgConnectionLost (Maybe IOException) - | MsgTxSubmission - (TraceSendRecv - (LocalTxSubmission - (GenTx ShelleyBlock) - (OC.ApplyTxError TPraosStandardCrypto))) - | MsgLocalStateQuery QueryClientName - (TraceSendRecv - (LocalStateQuery ShelleyBlock (Query ShelleyBlock))) - | MsgHandshakeTracer - (WithMuxBearer (ConnectionId LocalAddress) HandshakeTrace) - | MsgFindIntersection [W.BlockHeader] - | MsgIntersectionFound (W.Hash "BlockHeader") - | MsgFindIntersectionTimeout - | MsgPostSealedTx W.SealedTx - | MsgNodeTip W.BlockHeader - | MsgProtocolParameters W.ProtocolParameters - | MsgLocalStateQueryError QueryClientName String - | MsgGetRewardAccountBalance W.BlockHeader W.ChimericAccount - | MsgAccountDelegationAndRewards W.ChimericAccount - Delegations RewardAccounts - | MsgDestroyCursor ThreadId - | MsgWillQueryRewardsForStake W.Coin - | MsgFetchedNodePoolLsqData NodePoolLsqData - | MsgFetchedNodePoolLsqDataSummary Int Int - -- ^ Number of pools in stake distribution, and rewards map, - -- respectively. - | MsgWatcherUpdate W.BlockHeader BracketLog - | MsgChainSyncCmd (ChainSyncLog Text Text) +data NetworkLayerLog sc where + MsgCouldntConnect :: Int -> NetworkLayerLog sc + MsgConnectionLost :: (Maybe IOException) -> NetworkLayerLog sc + MsgTxSubmission + :: (TraceSendRecv + (LocalTxSubmission (GenTx (CardanoBlock sc)) (CardanoApplyTxErr sc))) + -> NetworkLayerLog sc + MsgLocalStateQuery + :: QueryClientName + -> (TraceSendRecv + (LocalStateQuery (CardanoBlock sc) (Query (CardanoBlock sc)))) + -> NetworkLayerLog sc + MsgHandshakeTracer :: + (WithMuxBearer (ConnectionId LocalAddress) HandshakeTrace) -> NetworkLayerLog sc + MsgFindIntersection :: [W.BlockHeader] -> NetworkLayerLog sc + MsgIntersectionFound :: (W.Hash "BlockHeader") -> NetworkLayerLog sc + MsgFindIntersectionTimeout :: NetworkLayerLog sc + MsgPostSealedTx :: W.SealedTx -> NetworkLayerLog sc + MsgNodeTip :: W.BlockHeader -> NetworkLayerLog sc + MsgProtocolParameters :: W.ProtocolParameters -> NetworkLayerLog sc + MsgLocalStateQueryError :: QueryClientName -> String -> NetworkLayerLog sc + MsgLocalStateQueryEraMismatch :: MismatchEraInfo (CardanoEras sc) -> NetworkLayerLog sc + MsgGetRewardAccountBalance :: W.BlockHeader -> W.ChimericAccount -> NetworkLayerLog sc + MsgAccountDelegationAndRewards :: W.ChimericAccount -> + Delegations sc -> SL.RewardAccounts sc -> NetworkLayerLog sc + MsgDestroyCursor :: ThreadId -> NetworkLayerLog sc + MsgWillQueryRewardsForStake :: W.Coin -> NetworkLayerLog sc + MsgFetchedNodePoolLsqData :: NodePoolLsqData -> NetworkLayerLog sc + MsgFetchedNodePoolLsqDataSummary :: Int -> Int -> NetworkLayerLog sc + -- ^ Number of pools in stake distribution, and rewards map, + -- respectively. + MsgWatcherUpdate :: W.BlockHeader -> BracketLog -> NetworkLayerLog sc + MsgChainSyncCmd :: (ChainSyncLog Text Text) -> NetworkLayerLog sc data QueryClientName = TipSyncClient @@ -759,7 +787,7 @@ data QueryClientName type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) -instance ToText NetworkLayerLog where +instance ToText (NetworkLayerLog b) where toText = \case MsgCouldntConnect n -> T.unwords [ "Couldn't connect to node (x" <> toText (n + 1) <> ")." @@ -772,7 +800,8 @@ instance ToText NetworkLayerLog where , T.pack (show e) ] MsgTxSubmission msg -> - T.pack (show msg) + "fixme: show MsgTxSubmission" + -- T.pack (show msg) MsgHandshakeTracer (WithMuxBearer conn h) -> pretty conn <> " " <> T.pack (show h) MsgFindIntersectionTimeout -> @@ -788,7 +817,8 @@ instance ToText NetworkLayerLog where , T.decodeUtf8 $ convertToBase Base16 bytes ] MsgLocalStateQuery client msg -> - T.pack (show client <> " " <> show msg) + -- T.pack (show client <> " " <> show msg) + "fixme: show MsgLocalStateQuery" MsgNodeTip bh -> T.unwords [ "Network node tip is" , pretty bh @@ -803,6 +833,8 @@ instance ToText NetworkLayerLog where , ": " , e ] + MsgLocalStateQueryEraMismatch _mismatch -> + "Local state query for the wrong era - this is fine." MsgGetRewardAccountBalance bh acct -> T.unwords [ "Querying the reward account balance for" , pretty acct @@ -834,8 +866,8 @@ instance ToText NetworkLayerLog where ". Callback " <> toText b <> "." MsgChainSyncCmd a -> toText a -instance HasPrivacyAnnotation NetworkLayerLog -instance HasSeverityAnnotation NetworkLayerLog where +instance HasPrivacyAnnotation (NetworkLayerLog b) +instance HasSeverityAnnotation (NetworkLayerLog b) where getSeverityAnnotation = \case MsgCouldntConnect 0 -> Debug MsgCouldntConnect 1 -> Notice @@ -851,6 +883,7 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgNodeTip{} -> Debug MsgProtocolParameters{} -> Info MsgLocalStateQueryError{} -> Error + MsgLocalStateQueryEraMismatch{} -> Debug MsgGetRewardAccountBalance{} -> Info MsgAccountDelegationAndRewards{} -> Info MsgDestroyCursor{} -> Notice diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 6661d61f597..53085486178 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -68,11 +68,10 @@ import Cardano.Wallet.Primitive.Types ) import Cardano.Wallet.Shelley.Compatibility ( Shelley - , ShelleyBlock - , fromShelleyBlock' , getProducer - , toBlockHeader + , poolCertsFromCardanoBlock , toPoint + , toShelleyBlockHeader ) import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) @@ -112,6 +111,10 @@ import Fmt ( fixedF, pretty ) import GHC.Generics ( Generic ) +import Ouroboros.Consensus.Cardano + ( CardanoBlock ) +import Ouroboros.Consensus.Shelley.Protocol + ( TPraosCrypto ) import qualified Cardano.Wallet.Api.Types as Api import qualified Data.Map.Merge.Strict as Map @@ -340,9 +343,10 @@ readPoolDbData DBLayer {..} = atomically $ do -- monitorStakePools - :: Tracer IO StakePoolLog + :: forall t sc. (TPraosCrypto sc) + => Tracer IO StakePoolLog -> GenesisParameters - -> NetworkLayer IO t ShelleyBlock + -> NetworkLayer IO t (CardanoBlock sc) -> DBLayer IO -> IO () monitorStakePools tr gp nl db@DBLayer{..} = do @@ -366,16 +370,16 @@ monitorStakePools tr gp nl db@DBLayer{..} = do initCursor = atomically $ readPoolProductionCursor (max 100 k) where k = fromIntegral $ getQuantity getEpochStability - getHeader :: ShelleyBlock -> BlockHeader - getHeader = toBlockHeader getGenesisBlockHash getEpochLength + getHeader :: CardanoBlock sc -> BlockHeader + getHeader = toShelleyBlockHeader getGenesisBlockHash getEpochLength forward - :: NonEmpty ShelleyBlock + :: NonEmpty (CardanoBlock sc) -> (BlockHeader, ProtocolParameters) -> IO (FollowAction ()) forward blocks (_nodeTip, _pparams) = do atomically $ forM_ blocks $ \blk -> do - let (slot, certificates) = fromShelleyBlock' getEpochLength blk + let (slot, certificates) = poolCertsFromCardanoBlock getEpochLength blk runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case Left e -> diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index 4f05e3212a0..2c04b501492 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -76,7 +76,6 @@ import Cardano.Wallet.Primitive.Types ) import Cardano.Wallet.Shelley.Compatibility ( Shelley - , TPraosStandardCrypto , fromNetworkDiscriminant , toByronNetworkMagic , toCardanoLovelace @@ -112,6 +111,8 @@ import Data.Quantity ( Quantity (..) ) import Data.Word ( Word16, Word64, Word8 ) +import Ouroboros.Consensus.Shelley.Protocol.Crypto + ( TPraosStandardCrypto ) import Ouroboros.Consensus.Shelley.Protocol.Crypto ( Crypto (..) ) import Ouroboros.Network.Block @@ -119,8 +120,7 @@ import Ouroboros.Network.Block import Type.Reflection ( Typeable ) -import qualified Cardano.Api as Cardano -import qualified Cardano.Api.Typed as CardanoTyped +import qualified Cardano.Api.Typed as Cardano import qualified Cardano.Chain.Common as Byron import qualified Cardano.Crypto as Crypto import qualified Cardano.Crypto.Hash.Class as Hash @@ -370,8 +370,8 @@ _decodeSignedTx :: ByteString -> Either ErrDecodeSignedTx (Tx, SealedTx) _decodeSignedTx bytes = do - case CardanoTyped.deserialiseFromCBOR CardanoTyped.AsShelleyTx bytes of - Right (CardanoTyped.ShelleyTx txValid) -> + case Cardano.deserialiseFromCBOR Cardano.AsShelleyTx bytes of + Right (Cardano.ShelleyTx txValid) -> pure $ toSealed txValid Left decodeErr -> Left $ ErrDecodeSignedTxWrongPayload (T.pack $ show decodeErr) @@ -421,18 +421,20 @@ computeTxSize proxy pm witTag action cs = dummyOutput = TxOut $ Address $ BS.pack (1:replicate 56 0) dummyKeyHash = SL.KeyHash . Hash.UnsafeHash $ dummyKeyHashRaw + dummyStakeCredential = Cardano.StakeCredentialByKey $ Cardano.StakeKeyHash dummyKeyHash + dummyPoolId = Cardano.StakePoolKeyHash dummyKeyHash certs = case action of Nothing -> [] Just RegisterKeyAndJoin{} -> - [ Cardano.shelleyRegisterStakingAddress dummyKeyHash - , Cardano.shelleyDelegateStake dummyKeyHash dummyKeyHash + [ Cardano.makeStakeAddressRegistrationCertificate dummyStakeCredential + , Cardano.makeStakeAddressDelegationCertificate dummyStakeCredential dummyPoolId ] Just Join{} -> - [ Cardano.shelleyDelegateStake dummyKeyHash dummyKeyHash + [ Cardano.makeStakeAddressDelegationCertificate dummyStakeCredential dummyPoolId ] Just Quit -> - [ Cardano.shelleyDeregisterStakingAddress dummyKeyHash + [ Cardano.makeStakeAddressDeregistrationCertificate dummyStakeCredential ] dummyKeyHashRaw = BS.pack (replicate 28 0) @@ -445,7 +447,7 @@ computeTxSize proxy pm witTag action cs = (addrWits, certWits) = ( Set.union (Set.map dummyWitnessUniq $ Set.fromList (fst <$> CS.inputs cs)) - (if Map.null wdrls then Set.empty else Set.singleton (dummyWitness "0")) + (if null wdrls then Set.empty else Set.singleton (dummyWitness "0")) , case action of Nothing -> Set.empty Just{} -> Set.singleton (dummyWitness "a") @@ -526,34 +528,40 @@ lookupPrivateKey keyFrom addr = mkUnsignedTx :: Cardano.SlotNo -> CoinSelection - -> Map (SL.RewardAcnt TPraosStandardCrypto) SL.Coin + -> [(Cardano.StakeAddress, Cardano.Lovelace)] -> [Cardano.Certificate] - -> Cardano.ShelleyTxBody + -> Cardano.TxBody Cardano.Shelley mkUnsignedTx ttl cs wdrls certs = - let - Cardano.TxUnsignedShelley unsigned = Cardano.buildShelleyTransaction - (toCardanoTxIn . fst <$> CS.inputs cs) - (map toCardanoTxOut $ CS.outputs cs) + Cardano.makeShelleyTransaction + extra ttl (toCardanoLovelace $ Coin $ feeBalance cs) - certs - (Cardano.WithdrawalsShelley $ SL.Wdrl wdrls) - Nothing -- Update - Nothing -- Metadata hash - in - unsigned + (toCardanoTxIn . fst <$> CS.inputs cs) + (map mkOut $ CS.outputs cs) + where + extra = Cardano.TxExtraContent + { Cardano.txMetadata = Nothing + , Cardano.txWithdrawals = wdrls + , Cardano.txCertificates = certs + , Cardano.txUpdateProposal = Nothing + } + mkOut = toCardanoTxOut net cred stake + net = error "fixme: mkUnsignedAddress net" + cred = error "fixme: mkUnsignedAddress cred" + stake = error "fixme: mkUnsignedAddress stake" + mkWithdrawals :: forall (n :: NetworkDiscriminant). (Typeable n) => Proxy n -> ChimericAccount -> Word64 - -> Map (SL.RewardAcnt TPraosStandardCrypto) SL.Coin + -> [(Cardano.StakeAddress, Cardano.Lovelace)] mkWithdrawals proxy (ChimericAccount keyHash) amount | amount == 0 = mempty - | otherwise = Map.fromList - [ ( SL.RewardAcnt (fromNetworkDiscriminant proxy) keyHashObj - , SL.Coin $ fromIntegral amount + | otherwise = + [ ( Cardano.StakeAddress (fromNetworkDiscriminant proxy) keyHashObj + , Cardano.Lovelace $ fromIntegral amount ) ] where @@ -570,16 +578,16 @@ defaultTTL epochLength slot = (toSlotNo epochLength slot) + 7200 mkShelleyWitness - :: SL.TxBody TPraosStandardCrypto + :: Cardano.TxBody Shelley -> (XPrv, Passphrase "encryption") - -> SL.WitVKey TPraosStandardCrypto 'SL.Witness + -> Cardano.Witness Shelley mkShelleyWitness body (prv, pwd) = - SL.WitVKey key sig + makeShelleyKeyWitness body (WitnessPaymentKey key) where - sig = SignedDSIGN - $ fromMaybe (error "error converting signatures") - $ rawDeserialiseSigDSIGN - $ serialize' (SL.hashTxBody body) `signWith` (prv, pwd) + -- sig = SignedDSIGN + -- $ fromMaybe (error "error converting signatures") + -- $ rawDeserialiseSigDSIGN + -- $ serialize' (SL.hashTxBody body) `signWith` (prv, pwd) key = SL.VKey $ VerKeyEd25519DSIGN