From e38582b14f0520dab795d509bb4d4ba5d9a7db58 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 15 Jul 2020 13:14:18 +1000 Subject: [PATCH] =?UTF-8?q?Cardano.Api=20=E2=86=92=20Cardano.Api.Typed=20a?= =?UTF-8?q?nd=20HardForkBlock=20support?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/core/src/Cardano/Wallet/Network.hs | 6 +- .../src/Cardano/Wallet/Primitive/Slotting.hs | 88 +-- .../src/Ouroboros/Network/Client/Wallet.hs | 2 +- lib/shelley/cardano-wallet-shelley.cabal | 5 + .../src/Cardano/Wallet/Byron/Compatibility.hs | 511 ++++++++++++++++++ lib/shelley/src/Cardano/Wallet/Shelley.hs | 14 +- .../Cardano/Wallet/Shelley/Compatibility.hs | 340 +++++++----- .../src/Cardano/Wallet/Shelley/Launch.hs | 109 +++- .../src/Cardano/Wallet/Shelley/Network.hs | 378 ++++++++----- .../src/Cardano/Wallet/Shelley/Pools.hs | 100 ++-- .../src/Cardano/Wallet/Shelley/Transaction.hs | 176 +++--- .../Wallet/Shelley/CompatibilitySpec.hs | 13 +- 12 files changed, 1261 insertions(+), 481 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 ef73aea4312..c09b3d0f7d8 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -141,11 +141,12 @@ data NetworkLayer m target block = NetworkLayer -- ^ Broadcast a transaction to the chain producer , stakeDistribution - :: GetStakeDistribution target m + :: GetStakeDistribution target block m , getAccountBalance :: ChimericAccount -> ExceptT ErrGetAccountBalance m (Quantity "lovelace" Word64) + , timeInterpreter :: TimeInterpreter m } @@ -153,6 +154,7 @@ data NetworkLayer m target block = NetworkLayer instance Functor m => Functor (NetworkLayer m target) where fmap f nl = nl { nextBlocks = fmap (fmap f) . nextBlocks nl + , stakeDistribution = error "fixme: functor instance" } {------------------------------------------------------------------------------- @@ -242,7 +244,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 d5f59f57e82..8c94f8e2bc8 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Slotting.hs @@ -27,6 +27,9 @@ module Cardano.Wallet.Primitive.Slotting -- ** Running queries , TimeInterpreter , singleEraInterpreter + , interpreterFromGenesis + , mkTimeInterpreter + , MyInterpreter(..) , Qry -- * Legacy api @@ -64,8 +67,11 @@ import Cardano.Wallet.Primitive.Types , unsafeEpochNo , wholeRange ) +import Control.Exception (throwIO) import Control.Monad ( ap, liftM ) +import Data.Coerce + ( coerce ) import Data.Functor.Identity ( Identity ) import Data.Generics.Internal.VL.Lens @@ -82,10 +88,13 @@ import GHC.Generics ( Generic ) import Numeric.Natural ( Natural ) -import Ouroboros.Consensus.HardFork.History.EraParams - ( EraParams (..), noLowerBoundSafeZone ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( SystemStart (..) ) +import Ouroboros.Consensus.HardFork.History.Qry + ( Interpreter, mkInterpreter ) import Ouroboros.Consensus.HardFork.History.Summary - ( Summary (..), neverForksSummary ) + ( neverForksSummary ) +import Ouroboros.Consensus.Util.CallStack (HasCallStack) import qualified Cardano.Slotting.Slot as Cardano import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Cardano @@ -196,43 +205,46 @@ slotAtTimeDetailed t = do -- We cannot manually specify when the fetching happens. -- -- This may or may not be what we actually want. -type TimeInterpreter m = forall a. Qry a -> m a --- --- Interpretation -- +-- fixme: this rank-2 type is inconvenient to set up in network layer. +-- fixme: this is backend-specific code -- it should be moved to the shelley package. +type TimeInterpreter m = forall a. Qry a -> m a -data Interpreter xs = Interpreter - { _iSummary :: Summary xs - , _iGenesisStartDate :: StartTime - } +-- | The hardfork query intepreter plus start time information. +data MyInterpreter xs = MyInterpreter SystemStart (Interpreter xs) -- | An 'Interpreter' for a single era, where the slotting from -- @GenesisParameters@ cannot change. -- --- Queries can never fail with @singleEraInterpreter@. -singleEraInterpreter :: GenesisParameters -> TimeInterpreter Identity -singleEraInterpreter gp q = either bomb return $ runQuery q int +-- Queries can never fail with @singleEraInterpreter@. This function will throw +-- a 'PastHorizonException' if they do. +singleEraInterpreter :: HasCallStack => GenesisParameters -> TimeInterpreter Identity +singleEraInterpreter gp = mkTimeInterpreterI gp (mkInterpreter summary) where - bomb x = error $ "singleEraIntepreter: the impossible happened: " <> show x - int = flip Interpreter (gp ^. #getGenesisBlockDate) - $ neverForksSummary - $ EraParams - { eraEpochSize = - Cardano.EpochSize - . fromIntegral - . unEpochLength - $ gp ^. #getEpochLength - - , eraSlotLength = - Cardano.mkSlotLength - . unSlotLength - $ gp ^. #getSlotLength - - , eraSafeZone = - noLowerBoundSafeZone (k * 2) - } - where - k = fromIntegral $ getQuantity $ getEpochStability gp + summary = neverForksSummary sz len + sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ gp ^. #getEpochLength + len = Cardano.mkSlotLength $ unSlotLength $ gp ^. #getSlotLength + +mkTimeInterpreterI :: HasCallStack => GenesisParameters -> Interpreter xs -> TimeInterpreter Identity +mkTimeInterpreterI gp int q = neverFails $ runQuery (MyInterpreter start int) q + where + start = coerce (gp ^. #getGenesisBlockDate) + + neverFails = either bomb pure + bomb x = error $ "singleEraInterpreter: the impossible happened: " <> show x + +interpreterFromGenesis :: GenesisParameters -> TimeInterpreter IO +interpreterFromGenesis gp = mkTimeInterpreter start (mkInterpreter summary) + where + summary = neverForksSummary sz len + sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ gp ^. #getEpochLength + len = Cardano.mkSlotLength $ unSlotLength $ gp ^. #getSlotLength + start = gp ^. #getGenesisBlockDate + +mkTimeInterpreter :: StartTime -> Interpreter xs -> TimeInterpreter IO +mkTimeInterpreter start int = either throwIO pure . runQuery mine + where + mine = MyInterpreter (coerce start) int -- | Wrapper around HF.Qry to allow converting times relative to the genesis -- block date to absolute ones @@ -254,11 +266,11 @@ instance Monad Qry where return = pure (>>=) = QBind -runQuery :: (Qry a) -> Interpreter xs -> Either HF.PastHorizonException a -runQuery qry (Interpreter summary (StartTime t0)) = go qry +runQuery :: HasCallStack => MyInterpreter xs -> Qry a -> Either HF.PastHorizonException a +runQuery (MyInterpreter systemStart int) = go where go :: Qry a -> Either HF.PastHorizonException a - go (HardForkQry q) = HF.runQuery q summary + go (HardForkQry q) = HF.interpretQuery int q go (QPure a) = return a go (QBind x f) = do @@ -267,11 +279,9 @@ runQuery qry (Interpreter summary (StartTime t0)) = go qry pure $ Cardano.fromRelativeTime systemStart rel go (UTCTimeToRel utc) -- Cardano.toRelativeTime may throw, so we need this guard: - | utc < t0 = pure Nothing + | utc < getSystemStart systemStart = pure Nothing | otherwise = pure $ Just $ Cardano.toRelativeTime systemStart utc - systemStart = Cardano.SystemStart t0 - -- ----------------------------------------------------------------------------- -- Legacy functions -- These only work for a single era. We need to stop using them diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs index ff5179bda6d..d6c01018451 100644 --- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs +++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs @@ -82,7 +82,7 @@ import Network.TypedProtocol.Pipelined import Numeric.Natural ( Natural ) import Ouroboros.Consensus.Ledger.Abstract - ( Query (..) ) + ( Query ) import Ouroboros.Network.Block ( BlockNo (..) , HasHeader (..) diff --git a/lib/shelley/cardano-wallet-shelley.cabal b/lib/shelley/cardano-wallet-shelley.cabal index ac9b0b8c693..33054f272bb 100644 --- a/lib/shelley/cardano-wallet-shelley.cabal +++ b/lib/shelley/cardano-wallet-shelley.cabal @@ -36,6 +36,7 @@ library , bech32 , bech32-th , binary + , byron-spec-ledger , bytestring , cardano-addresses , cardano-api @@ -55,6 +56,7 @@ library , cryptonite , directory , exceptions + , extra , filepath , fmt , generic-lens @@ -65,6 +67,8 @@ library , network-mux , optparse-applicative , ouroboros-consensus + , ouroboros-consensus-byron + , ouroboros-consensus-cardano , ouroboros-consensus-shelley , ouroboros-network , ouroboros-network-framework @@ -85,6 +89,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..78eeb753ad9 --- /dev/null +++ b/lib/shelley/src/Cardano/Wallet/Byron/Compatibility.hs @@ -0,0 +1,511 @@ +{-# 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 + , genesisBlockFromTxOuts + + -- * Conversions + , toByronHash + , toGenTx + , toPoint + , toSlotInEpoch + + , fromBlockNo + , fromByronBlock + , toByronBlockHeader + , 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 Crypto.Hash.Utils + ( blake2b256 ) +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 + ( 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 (..) + , 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.Consensus.Block as O +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 + { slotNo = + W.SlotNo 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 + +-- | Construct a ("fake") genesis block from genesis transaction outputs. +-- +-- The genesis data on haskell nodes is not a block at all, unlike the block0 on +-- jormungandr. This function is a method to deal with the discrepancy. +genesisBlockFromTxOuts :: W.GenesisParameters -> [W.TxOut] -> W.Block +genesisBlockFromTxOuts gp outs = W.Block + { delegations = [] + , header = W.BlockHeader + { slotNo = + SlotNo 0 + , blockHeight = + Quantity 0 + , headerHash = + coerce $ W.getGenesisBlockHash gp + , parentHeaderHash = + W.Hash (BS.replicate 32 0) + } + , transactions = mkTx <$> outs + } + where + mkTx out@(W.TxOut (W.Address bytes) _) = + W.Tx (W.Hash $ blake2b256 bytes) [] [out] mempty + +-------------------------------------------------------------------------------- +-- +-- 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.BlockHeader + -> Point ByronBlock +toPoint genesisH (W.BlockHeader sl _ h _) + | h == (coerce genesisH) = O.GenesisPoint + | otherwise = O.Point $ Point.block sl (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 + mkBlock :: [W.Tx] -> W.Block + mkBlock txs = W.Block + { header = toByronBlockHeader gp byronBlk + , transactions = txs + , delegations = [] + } + +toByronBlockHeader + :: W.GenesisParameters + -> ByronBlock + -> W.BlockHeader +toByronBlockHeader gp blk = W.BlockHeader + { slotNo = + O.blockSlot blk + , blockHeight = + fromBlockNo $ O.blockNo blk + , headerHash = + fromByronHash $ O.blockHash blk + , parentHeaderHash = + fromChainHash (W.getGenesisBlockHash gp) $ + headerPrevHash cfg (O.getHeader blk) + } + where + cfg = byronCodecConfig gp + +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" -> Tip ByronBlock -> W.BlockHeader +fromTip genesisHash tip = case getPoint (getTipPoint tip) of + Origin -> W.BlockHeader + { slotNo = W.SlotNo 0 + , blockHeight = Quantity 0 + , headerHash = coerce genesisHash + , parentHeaderHash = hashOfNoParent + } + At blk -> W.BlockHeader + { slotNo = 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.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 2025f7d7d33..d8c17eabaf1 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -45,6 +45,8 @@ module Cardano.Wallet.Shelley import Prelude +import Cardano.Api.Typed + ( Shelley ) import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer @@ -114,7 +116,7 @@ import Cardano.Wallet.Registry import Cardano.Wallet.Shelley.Api.Server ( server ) import Cardano.Wallet.Shelley.Compatibility - ( Shelley, ShelleyBlock, fromNetworkMagic, fromShelleyBlock ) + ( CardanoBlock, TPraosStandardCrypto, fromCardanoBlock, fromNetworkMagic ) import Cardano.Wallet.Shelley.Network ( NetworkLayerLog, withNetworkLayer ) import Cardano.Wallet.Shelley.Pools @@ -308,7 +310,7 @@ serveWallet withPoolsMonitoring :: Maybe FilePath -> GenesisParameters - -> NetworkLayer IO t ShelleyBlock + -> NetworkLayer IO t (CardanoBlock TPraosStandardCrypto) -> (StakePoolLayer -> IO a) -> IO a withPoolsMonitoring dir gp nl action = @@ -331,7 +333,7 @@ serveWallet , WalletKey k ) => TransactionLayer t k - -> NetworkLayer IO t ShelleyBlock + -> NetworkLayer IO t (CardanoBlock TPraosStandardCrypto) -> (WorkerCtx (ApiLayer s t k) -> WalletId -> IO ()) -> IO (ApiLayer s t k) apiLayer tl nl coworker = do @@ -351,8 +353,8 @@ serveWallet databaseDir Server.newApiLayer walletEngineTracer params nl' tl db coworker where - gp@GenesisParameters{getGenesisBlockHash} = genesisParameters np - nl' = fromShelleyBlock getGenesisBlockHash <$> nl + gp = genesisParameters np + nl' = fromCardanoBlock gp <$> nl -- FIXME: reduce duplication (see Cardano.Wallet.Jormungandr) handleApiServerStartupError :: ListenError -> IO ExitCode @@ -426,7 +428,7 @@ data Tracers' f = Tracers , poolsEngineTracer :: f (WorkerLog Text StakePoolLog) , poolsDbTracer :: f DBLog , ntpClientTracer :: f NtpTrace - , networkTracer :: f NetworkLayerLog + , networkTracer :: f (NetworkLayerLog TPraosStandardCrypto) } -- | All of the Shelley 'Tracer's. diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index a11444645b5..c8f5eb6dd05 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 + , CardanoBlock , NodeVersionData , TPraosStandardCrypto @@ -40,9 +38,9 @@ module Cardano.Wallet.Shelley.Compatibility , genesisTip -- * Conversions - , toShelleyHash + , toCardanoHash , toEpochSize - , toGenTx + , toShelleyGenTx , toPoint , toCardanoTxId , toCardanoTxIn @@ -65,18 +63,21 @@ module Cardano.Wallet.Shelley.Compatibility , getProducer , fromBlockNo - , fromShelleyBlock - , fromShelleyBlock' - , toBlockHeader + , fromCardanoBlock + , poolCertsFromShelleyBlock + , toCardanoBlockHeader + , toShelleyBlockHeader , fromShelleyHash - , fromPrevHash + , fromCardanoHash , fromChainHash + , fromPrevHash + , fromShelleyChainHash , fromGenesisData , fromNetworkMagic , toByronNetworkMagic , fromTip , fromTip' - , fromPParams + , fromShelleyPParams , fromNetworkDiscriminant -- * Internal Conversions @@ -92,10 +93,12 @@ import Cardano.Address.Derivation ( XPub, xpubPublicKey ) import Cardano.Api.Shelley.Genesis ( ShelleyGenesis (..) ) +import Cardano.Api.Typed + ( Shelley ) import Cardano.Binary ( fromCBOR, serialize' ) import Cardano.Crypto.Hash.Class - ( Hash (UnsafeHash), getHash ) + ( Hash (UnsafeHash), hashToBytes ) import Cardano.Slotting.Slot ( EpochNo (..), EpochSize (..) ) import Cardano.Wallet.Api.Types @@ -104,6 +107,8 @@ import Cardano.Wallet.Api.Types , EncodeAddress (..) , EncodeStakeAddress (..) ) +import Cardano.Wallet.Byron.Compatibility + ( fromByronBlock, toByronBlockHeader ) import Cardano.Wallet.Primitive.AddressDerivation ( NetworkDiscriminant (..) ) import Cardano.Wallet.Primitive.Types @@ -137,6 +142,8 @@ import Data.ByteString ( ByteString ) import Data.ByteString.Base58 ( bitcoinAlphabet, decodeBase58, encodeBase58 ) +import Data.ByteString.Short + ( fromShort, toShort ) import Data.Coerce ( coerce ) import Data.Foldable @@ -144,7 +151,7 @@ import Data.Foldable import Data.Map.Strict ( Map ) import Data.Maybe - ( fromMaybe, isJust, mapMaybe ) + ( isJust, mapMaybe ) import Data.Proxy ( Proxy ) import Data.Quantity @@ -163,8 +170,14 @@ import GHC.Stack ( HasCallStack ) import Numeric.Natural ( Natural ) +import Ouroboros.Consensus.Cardano.Block + ( CardanoBlock, CardanoEras, CardanoGenTx, GenTx (..), HardForkBlock (..) ) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( OneEraHash (..) ) import Ouroboros.Consensus.Shelley.Ledger - ( GenTx, ShelleyHash (..) ) + ( Crypto, ShelleyHash (..) ) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( ShelleyBlock (..) ) import Ouroboros.Consensus.Shelley.Protocol.Crypto ( TPraosStandardCrypto ) import Ouroboros.Network.Block @@ -194,7 +207,7 @@ 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.Common as Byron import qualified Cardano.Wallet.Primitive.Types as W @@ -217,29 +230,15 @@ 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 - --- | 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 - -------------------------------------------------------------------------------- -- -- Chain Parameters @@ -273,7 +272,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: @@ -320,10 +319,9 @@ hashOfNoParent :: W.Hash "BlockHeader" hashOfNoParent = W.Hash . BS.pack $ replicate 32 0 --- fixme: maybe just toShelleyHash = ShelleyHash . CC.unsafeHashFromBytes -toShelleyHash :: W.Hash "BlockHeader" -> ShelleyHash c -toShelleyHash (W.Hash bytes) = - ShelleyHash $ SL.HashHeader $ UnsafeHash bytes +toCardanoHash :: W.Hash "BlockHeader" -> OneEraHash (CardanoEras sc) +toCardanoHash (W.Hash bytes) = + OneEraHash $ toShort bytes toEpochSize :: W.EpochLength -> EpochSize toEpochSize = @@ -332,70 +330,89 @@ toEpochSize = toPoint :: W.Hash "Genesis" -> W.BlockHeader - -> Point ShelleyBlock -toPoint genesisH (W.BlockHeader sl _ h _) + -> Point (CardanoBlock sc) +toPoint genesisH (W.BlockHeader sl _ (W.Hash h) _) | h == (coerce genesisH) = O.GenesisPoint - | otherwise = O.Point $ Point.block sl (toShelleyHash h) + | otherwise = O.BlockPoint sl (OneEraHash $ toShort h) -toBlockHeader - :: W.Hash "Genesis" - -> ShelleyBlock +toCardanoBlockHeader + :: O.Crypto sc + => W.GenesisParameters + -> CardanoBlock sc + -> W.BlockHeader +toCardanoBlockHeader gp = \case + BlockByron blk -> + toByronBlockHeader gp blk + BlockShelley blk -> + toShelleyBlockHeader (W.getGenesisBlockHash gp) blk + +toShelleyBlockHeader + :: O.Crypto sc + => W.Hash "Genesis" + -> ShelleyBlock sc -> W.BlockHeader -toBlockHeader genesisHash blk = +toShelleyBlockHeader genesisHash blk = let - O.ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk + ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk in - W.BlockHeader - { slotNo = SL.bheaderSlotNo header - , blockHeight = - fromBlockNo $ SL.bheaderBlockNo header - , headerHash = - fromShelleyHash headerHash - , parentHeaderHash = - fromPrevHash (coerce genesisHash) $ - SL.bheaderPrev header - } + W.BlockHeader + { slotNo = + SL.bheaderSlotNo header + , blockHeight = + fromBlockNo $ SL.bheaderBlockNo header + , headerHash = + fromShelleyHash headerHash + , parentHeaderHash = + fromPrevHash (coerce genesisHash) $ + 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" - -> ShelleyBlock +fromCardanoBlock + :: O.Crypto sc + => W.GenesisParameters + -> CardanoBlock sc -> W.Block -fromShelleyBlock genesisHash 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 blk - , transactions = txs - , delegations = mconcat certs - } +fromCardanoBlock gp = \case + BlockByron blk -> + fromByronBlock gp blk + BlockShelley blk -> + fromShelleyBlock blk + where + fromShelleyBlock blk@(ShelleyBlock (SL.Block _ (SL.TxSeq txs')) _) = + let + (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' + + in W.Block + { header = toShelleyBlockHeader (W.getGenesisBlockHash gp) blk + , transactions = txs + , delegations = mconcat certs + } -fromShelleyBlock' - :: ShelleyBlock +poolCertsFromShelleyBlock + :: O.Crypto sc + => ShelleyBlock sc -> (W.SlotNo, [W.PoolCertificate]) -fromShelleyBlock' blk = +poolCertsFromShelleyBlock blk = let - O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk + ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk SL.TxSeq txs' = txSeq (_, _, certs) = unzip3 $ map fromShelleyTx $ toList txs' in (SL.bheaderSlotNo header, mconcat certs) fromShelleyHash :: ShelleyHash c -> W.Hash "BlockHeader" -fromShelleyHash (ShelleyHash (SL.HashHeader h)) = W.Hash (getHash h) +fromShelleyHash (ShelleyHash (SL.HashHeader h)) = W.Hash (hashToBytes h) + +fromCardanoHash :: O.HeaderHash (CardanoBlock sc) -> W.Hash "BlockHeader" +fromCardanoHash = W.Hash . fromShort . getOneEraHash fromPrevHash :: W.Hash "BlockHeader" - -> SL.PrevHash TPraosStandardCrypto + -> SL.PrevHash sc -> W.Hash "BlockHeader" fromPrevHash genesisHash = \case SL.GenesisHash -> genesisHash @@ -403,9 +420,17 @@ 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 $ fromShort h + +fromShelleyChainHash + :: W.Hash "Genesis" + -> ChainHash (ShelleyBlock sc) + -> W.Hash "BlockHeader" +fromShelleyChainHash genesisHash = \case O.GenesisHash -> coerce genesisHash O.BlockHash h -> fromShelleyHash h @@ -414,9 +439,12 @@ fromBlockNo :: BlockNo -> Quantity "block" Word32 fromBlockNo (BlockNo h) = Quantity (fromIntegral h) +fromTip' :: W.GenesisParameters -> Tip (CardanoBlock sc) -> W.BlockHeader +fromTip' gp = fromTip (W.getGenesisBlockHash gp) + fromTip :: W.Hash "Genesis" - -> Tip ShelleyBlock + -> Tip (CardanoBlock sc) -> W.BlockHeader fromTip genesisHash tip = case getPoint (getTipPoint tip) of Origin -> W.BlockHeader @@ -428,7 +456,7 @@ fromTip genesisHash tip = case getPoint (getTipPoint tip) of At blk -> W.BlockHeader { slotNo = 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 @@ -440,20 +468,13 @@ fromTip genesisHash tip = case getPoint (getTipPoint tip) of , parentHeaderHash = W.Hash "parentHeaderHash - unused in Shelley" } -fromTip' :: W.GenesisParameters -> Tip ShelleyBlock -> W.BlockHeader -fromTip' gp = fromTip getGenesisBlockHash - where - W.GenesisParameters - { 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 = @@ -499,14 +520,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 @@ -515,12 +539,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 @@ -537,7 +562,7 @@ fromGenesisData g initialFunds = , getActiveSlotCoefficient = W.ActiveSlotCoefficient . fromRational . sgActiveSlotsCoeff $ g } - , protocolParameters = fromPParams . sgProtocolParams $ g + , protocolParameters = fromShelleyPParams . sgProtocolParams $ g } , genesisBlockFromTxOuts initialFunds ) @@ -556,7 +581,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 @@ -579,7 +604,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) = @@ -590,10 +615,10 @@ fromNetworkMagic (NetworkMagic magic) = -- fromPoolId :: SL.KeyHash 'SL.StakePool crypto -> W.PoolId -fromPoolId (SL.KeyHash x) = W.PoolId $ getHash x +fromPoolId (SL.KeyHash x) = W.PoolId $ hashToBytes x fromPoolDistr - :: SL.PoolDistr TPraosStandardCrypto + :: SL.PoolDistr crypto -> Map W.PoolId Percentage fromPoolDistr = Map.map (unsafeMkPercentage . fst) @@ -602,10 +627,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 @@ -622,22 +647,26 @@ 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 +toShelleyGenTx + :: (HasCallStack, Crypto c) + => W.SealedTx + -> CardanoGenTx c +toShelleyGenTx = GenTxShelley + . unsafeDeserialiseCbor fromCBOR . BL.fromStrict . W.getSealedTx fromShelleyTxId :: SL.TxId crypto -> W.Hash "Tx" -fromShelleyTxId (SL.TxId (UnsafeHash h)) = W.Hash h +fromShelleyTxId (SL.TxId (UnsafeHash h)) = W.Hash $ fromShort h -fromShelleyTxIn :: SL.TxIn crypto -> W.TxIn +fromShelleyTxIn :: Crypto crypto => SL.TxIn crypto -> W.TxIn fromShelleyTxIn (SL.TxIn txid ix) = W.TxIn (fromShelleyTxId txid) (unsafeCast ix) where unsafeCast :: Natural -> Word32 unsafeCast = fromIntegral -fromShelleyTxOut :: SL.TxOut crypto -> W.TxOut +fromShelleyTxOut :: Crypto crypto => SL.TxOut crypto -> W.TxOut fromShelleyTxOut (SL.TxOut addr amount) = W.TxOut (fromShelleyAddress addr) (fromShelleyCoin amount) @@ -660,7 +689,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] @@ -675,14 +705,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) -> @@ -702,7 +732,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 @@ -710,8 +740,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) } ) @@ -724,29 +754,40 @@ 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 :: SL.Credential 'SL.Staking crypto -> W.ChimericAccount fromStakeCredential = \case SL.ScriptHashObj (SL.ScriptHash h) -> - W.ChimericAccount (getHash h) + W.ChimericAccount (hashToBytes h) SL.KeyHashObj (SL.KeyHash h) -> - W.ChimericAccount (getHash h) + W.ChimericAccount (hashToBytes h) -fromPoolKeyHash :: SL.KeyHash rol TPraosStandardCrypto -> W.PoolId +fromPoolKeyHash :: SL.KeyHash rol sc -> W.PoolId fromPoolKeyHash (SL.KeyHash h) = - W.PoolId (getHash h) + W.PoolId (hashToBytes 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) + W.PoolOwner (hashToBytes h) fromUnitInterval :: HasCallStack => SL.UnitInterval -> Percentage fromUnitInterval x = @@ -775,7 +816,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 @@ -783,19 +824,11 @@ toSealed tx = in (wtx, sealed) toCardanoTxId :: W.Hash "Tx" -> Cardano.TxId -toCardanoTxId (W.Hash h) = Cardano.TxId $ UnsafeHash h +toCardanoTxId (W.Hash h) = Cardano.TxId $ UnsafeHash $ toShort 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 @@ -803,31 +836,46 @@ 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 - . SL.KeyHash . UnsafeHash . W.unChimericAccount +toStakeCredential :: W.ChimericAccount -> SL.StakeCredential crypto +toStakeCredential = SL.KeyHashObj + . SL.KeyHash . UnsafeHash . toShort . W.unChimericAccount toStakeKeyDeregCert :: XPub -> Cardano.Certificate -toStakeKeyDeregCert xpub = - Cardano.shelleyDeregisterStakingAddress - (SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) +toStakeKeyDeregCert = Cardano.makeStakeAddressDeregistrationCertificate + . Cardano.StakeCredentialByKey + . Cardano.StakeKeyHash + . SL.KeyHash + . UnsafeHash + . toShort + . blake2b224 + . xpubPublicKey toStakeKeyRegCert :: XPub -> Cardano.Certificate -toStakeKeyRegCert xpub = - Cardano.shelleyRegisterStakingAddress - (SL.KeyHash $ UnsafeHash $ blake2b224 $ xpubPublicKey xpub) +toStakeKeyRegCert = Cardano.makeStakeAddressRegistrationCertificate + . Cardano.StakeCredentialByKey + . Cardano.StakeKeyHash + . SL.KeyHash + . UnsafeHash + . toShort + . blake2b224 + . xpubPublicKey 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 cred) + (Cardano.StakePoolKeyHash pool) + where + cred = SL.KeyHash $ UnsafeHash $ toShort $ blake2b224 $ xpubPublicKey xpub + pool = SL.KeyHash $ UnsafeHash $ toShort pid {------------------------------------------------------------------------------- Address Encoding / Decoding @@ -873,7 +921,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/Launch.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs index 9d5ae884504..6443d02d4b6 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs @@ -48,6 +48,8 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Chain.Genesis + ( GenesisData (..), readGenesisData ) import Cardano.CLI ( optionT ) import Cardano.Launcher @@ -58,6 +60,8 @@ import Cardano.Launcher.Node , NodePort (..) , withCardanoNode ) +import Cardano.Wallet.Byron.Compatibility + ( mainnetVersionData ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network.Ports @@ -83,9 +87,11 @@ import Control.Concurrent.MVar import Control.Exception ( SomeException, finally, handle, throwIO ) import Control.Monad - ( forM, forM_, replicateM, replicateM_, unless, void, (>=>) ) + ( forM, forM_, replicateM, replicateM_, unless, void, when, (>=>) ) import Control.Monad.Fail ( MonadFail ) +import Control.Monad.Trans.Except + ( ExceptT, withExceptT ) import Control.Monad.Trans.Except ( ExceptT (..) ) import Control.Retry @@ -117,7 +123,7 @@ import Data.Time.Clock import GHC.TypeLits ( KnownNat, Nat, SomeNat (..), someNatVal ) import Options.Applicative - ( Parser, help, long, metavar, (<|>) ) + ( Parser, flag', help, long, metavar, (<|>) ) import Ouroboros.Consensus.Shelley.Node ( sgNetworkMagic ) import Ouroboros.Consensus.Shelley.Protocol @@ -145,6 +151,7 @@ import Test.Utils.Paths import Test.Utils.StaticServer ( withStaticServer ) +import qualified Cardano.Wallet.Byron.Compatibility as Byron import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Lazy as BL @@ -158,22 +165,42 @@ import qualified Data.Yaml as Yaml import qualified Shelley.Spec.Ledger.Address as SL import qualified Shelley.Spec.Ledger.Coin as SL +-- | Shelley hard fork network configuration has two genesis datas. +-- As a special case for mainnet, we hardcode the byron genesis data. data NetworkConfiguration where + -- | Mainnet does not have network discrimination. + MainnetConfig + :: (SomeNetworkDiscriminant, NodeVersionData) + -- ^ Byron mainnet configuration + -> FilePath + -- ^ Genesis data in JSON format, for shelley era. + -> NetworkConfiguration + + -- | Testnet has network magic. TestnetConfig :: FilePath + -- ^ Genesis data in JSON format, for byron era. + -> FilePath + -- ^ Genesis data in JSON format, for shelley era. -> NetworkConfiguration + -- | Staging does not have network discrimination. StagingConfig :: FilePath + -- ^ Genesis data in JSON format, for byron era. + -> FilePath + -- ^ Genesis data in JSON format, for shelley era. -> NetworkConfiguration -- | Hand-written as there's no Show instance for 'NodeVersionData' instance Show NetworkConfiguration where show = \case - TestnetConfig genesisFile -> - "TestnetConfig " <> show genesisFile - StagingConfig genesisFile -> - "StagingConfig " <> show genesisFile + MainnetConfig _ shelleyGenesisFile -> + "MainnetConfig " <> show shelleyGenesisFile + TestnetConfig byronGenesisFile shelleyGenesisFile -> + "TestnetConfig " <> show (byronGenesisFile, shelleyGenesisFile) + StagingConfig byronGenesisFile shelleyGenesisFile -> + "StagingConfig " <> show (byronGenesisFile, shelleyGenesisFile) -- | --node-socket=FILE nodeSocketOption :: Parser FilePath @@ -182,20 +209,27 @@ nodeSocketOption = optionT $ mempty <> metavar "FILE" <> help "Path to the node's domain socket." --- | --testnet=FILE +-- | --mainnet --shelley-genesis=FILE +-- --testnet --byron-genesis=FILE --shelley-genesis=FILE +-- --staging --byron-genesis=FILE --shelley-genesis=FILE networkConfigurationOption :: Parser NetworkConfiguration -networkConfigurationOption = - (TestnetConfig <$> customNetworkOption "testnet") - <|> - (StagingConfig <$> customNetworkOption "staging") +networkConfigurationOption = mainnet <|> testnet <|> staging where - customNetworkOption - :: String - -> Parser FilePath - customNetworkOption network = optionT $ mempty - <> long network + mainnet = mainnetFlag <*> genesisFileOption "shelley" + testnet = testnetFlag <*> genesisFileOption "byron" <*> genesisFileOption "shelley" + staging = stagingFlag <*> genesisFileOption "byron" <*> genesisFileOption "shelley" + + mainnetFlag = flag' + (MainnetConfig (SomeNetworkDiscriminant $ Proxy @'Mainnet, mainnetVersionData)) + (long "mainnet") + testnetFlag = flag' TestnetConfig (long "testnet") + stagingFlag = flag' StagingConfig (long "staging") + + genesisFileOption :: String -> Parser FilePath + genesisFileOption era = optionT $ mempty + <> long (era ++ "-genesis") <> metavar "FILE" - <> help "Path to the genesis .json file." + <> help ("Path to the " <> era <> " genesis data in JSON format.") someCustomDiscriminant :: (forall (pm :: Nat). KnownNat pm => Proxy pm -> SomeNetworkDiscriminant) @@ -215,9 +249,23 @@ parseGenesisData -> ExceptT String IO (SomeNetworkDiscriminant, NetworkParameters, NodeVersionData, Block) parseGenesisData = \case - TestnetConfig genesisFile -> do + MainnetConfig (discriminant, vData) shelleyGenesisFile -> do (genesis :: ShelleyGenesis TPraosStandardCrypto) - <- ExceptT $ eitherDecode <$> BL.readFile genesisFile + <- ExceptT $ eitherDecode <$> BL.readFile shelleyGenesisFile + + let (np, block0) = fromGenesisData genesis (Map.toList $ sgInitialFunds genesis) + pure + ( discriminant + , np + , vData + , block0 + ) + + TestnetConfig byronGenesisFile shelleyGenesisFile -> do + (genesisData, genesisHash) <- + withExceptT show $ readGenesisData byronGenesisFile + (shelleyGenesis :: ShelleyGenesis TPraosStandardCrypto) + <- ExceptT $ eitherDecode <$> BL.readFile shelleyGenesisFile let mkSomeNetwork :: forall (pm :: Nat). KnownNat pm @@ -225,20 +273,29 @@ parseGenesisData = \case -> SomeNetworkDiscriminant mkSomeNetwork _ = SomeNetworkDiscriminant $ Proxy @('Testnet pm) - let nm = sgNetworkMagic genesis + let nm = sgNetworkMagic shelleyGenesis let pm = ProtocolMagic $ fromIntegral nm - let (discriminant, vData) = someCustomDiscriminant mkSomeNetwork pm - let (np, block0) = fromGenesisData genesis (Map.toList $ sgInitialFunds genesis) + let (shelleyDiscriminant, shelleyVData) = someCustomDiscriminant mkSomeNetwork pm + let (np, block0) = fromGenesisData shelleyGenesis (Map.toList $ sgInitialFunds shelleyGenesis) + + let byronPm = Byron.fromProtocolMagicId $ gdProtocolMagicId genesisData + let (_byronDiscriminant, _byronVData) = someCustomDiscriminant mkSomeNetwork byronPm + let (bnp, bouts) = Byron.fromGenesisData (genesisData, genesisHash) + let _bblock0 = Byron.genesisBlockFromTxOuts (genesisParameters bnp) bouts + + when (byronPm /= pm) $ + fail "Network discriminants in genesis files to not match." + pure - ( discriminant + ( shelleyDiscriminant , np - , vData + , shelleyVData , block0 ) - StagingConfig genesisFile -> do + StagingConfig byronGenesisFile _shelleyGenesisFile -> do (genesis :: ShelleyGenesis TPraosStandardCrypto) - <- ExceptT $ eitherDecode <$> BL.readFile genesisFile + <- ExceptT $ eitherDecode <$> BL.readFile byronGenesisFile let mkSomeNetwork :: forall (pm :: Nat). KnownNat pm diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index a610dbb7ddd..59b063b16b0 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -5,7 +5,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -38,6 +40,8 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Wallet.Byron.Compatibility + ( byronCodecConfig, protocolParametersFromUpdateState ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network @@ -50,24 +54,21 @@ import Cardano.Wallet.Network , mapCursor ) import Cardano.Wallet.Primitive.Slotting - ( singleEraInterpreter ) + ( TimeInterpreter, interpreterFromGenesis, mkTimeInterpreter ) import Cardano.Wallet.Shelley.Compatibility - ( Delegations - , RewardAccounts - , Shelley - , ShelleyBlock + ( Shelley , TPraosStandardCrypto + , fromCardanoHash , fromChainHash , fromNonMyopicMemberRewards - , fromPParams , fromPoolDistr - , fromShelleyHash + , fromShelleyPParams , fromTip , fromTip' , optimumNumberOfPools - , toGenTx , toPoint , toShelleyCoin + , toShelleyGenTx , toStakeCredential ) import Control.Concurrent @@ -89,6 +90,7 @@ import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM ( MonadSTM , TQueue + , TVar , atomically , newTMVarM , newTQueue @@ -114,16 +116,20 @@ import Data.ByteArray.Encoding ( Base (..), convertToBase ) import Data.ByteString.Lazy ( ByteString ) +import Data.Either.Extra + ( eitherToMaybe ) import Data.Function ( (&) ) -import Data.Functor.Identity - ( runIdentity ) import Data.List ( isInfixOf ) import Data.Map ( Map ) +import Data.Map + ( (!) ) import Data.Maybe ( fromMaybe ) +import Data.Proxy + ( Proxy (..) ) import Data.Quantity ( Percentage, Quantity (..) ) import Data.Text @@ -140,12 +146,32 @@ import GHC.Stack ( HasCallStack ) import Network.Mux ( MuxError (..), MuxErrorType (..), WithMuxBearer (..) ) +import Ouroboros.Consensus.Cardano + ( CardanoBlock ) +import Ouroboros.Consensus.Cardano.Block + ( CardanoApplyTxErr + , CardanoEras + , CardanoGenTx + , CodecConfig (..) + , GenTx (..) + , Query (..) + ) +import Ouroboros.Consensus.HardFork.Combinator + ( QueryHardFork (..) ) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( MismatchEraInfo ) +import Ouroboros.Consensus.HardFork.History.Qry + ( Interpreter ) import Ouroboros.Consensus.Network.NodeToClient ( ClientCodecs, Codecs' (..), DefaultCodecs, clientCodecs, defaultCodecs ) +import Ouroboros.Consensus.Node.NetworkProtocolVersion + ( HasNetworkProtocolVersion (..), SupportedNetworkProtocolVersion (..) ) import Ouroboros.Consensus.Shelley.Ledger - ( GenTx, Query (..), ShelleyNodeToClientVersion (..) ) + ( Crypto ) import Ouroboros.Consensus.Shelley.Ledger.Config ( CodecConfig (..) ) +import Ouroboros.Consensus.Shelley.Protocol + ( TPraosCrypto ) import Ouroboros.Network.Block ( Point , SlotNo (..) @@ -218,10 +244,13 @@ 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.Credential as SL +import qualified Shelley.Spec.Ledger.Keys as SL +import qualified Shelley.Spec.Ledger.LedgerState as SL {- HLINT ignore "Use readTVarIO" -} @@ -229,12 +258,13 @@ import qualified Shelley.Spec.Ledger.PParams as SL -- stateful and the node's keep track of the associated connection's cursor. data instance Cursor (m Shelley) = Cursor (Async ()) - (Point ShelleyBlock) - (TQueue m (ChainSyncCmd ShelleyBlock m)) + (Point (CardanoBlock TPraosStandardCrypto)) + (TQueue m (ChainSyncCmd (CardanoBlock TPraosStandardCrypto) m)) -- | Create an instance of the network layer withNetworkLayer - :: Tracer IO NetworkLayerLog + :: forall sc a. (sc ~ TPraosStandardCrypto) + => Tracer IO (NetworkLayerLog sc) -- ^ Logging of network layer startup -> W.NetworkParameters -- ^ Initial blockchain parameters @@ -242,7 +272,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 Shelley) (CardanoBlock sc) -> IO a) -- ^ Callback function with the network layer -> IO a withNetworkLayer tr np addrInfo versionData action = do @@ -254,12 +284,12 @@ withNetworkLayer tr np addrInfo versionData action = do -- doesn't rely on the intersection to be up-to-date. let handlers = retryOnConnectionLost tr - (nodeTipChan, protocolParamsVar, localTxSubmissionQ) <- + (nodeTipChan, protocolParamsVar, interpreterVar, localTxSubmissionQ) <- connectNodeTipClient handlers 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) @@ -271,30 +301,34 @@ withNetworkLayer tr np addrInfo versionData action = do , destroyCursor = _destroyCursor , cursorSlotNo = _cursorSlotNo , getProtocolParameters = atomically $ readTVar protocolParamsVar - , postTx = _postTx localTxSubmissionQ + , postTx = _postSealedTx localTxSubmissionQ , stakeDistribution = _stakeDistribution queryRewardQ , getAccountBalance = _getAccountBalance nodeTipVar queryRewardQ - , timeInterpreter = pure . runIdentity . singleEraInterpreter gp + , timeInterpreter = _timeInterpreterQuery interpreterVar } where gp@W.GenesisParameters { getGenesisBlockHash + , getGenesisBlockDate } = W.genesisParameters np + cfg = codecConfig gp connectNodeTipClient handlers = do localTxSubmissionQ <- atomically newTQueue nodeTipChan <- newChan protocolParamsVar <- atomically $ newTVar $ W.protocolParameters np + interpreterVar <- atomically $ newTVar Nothing nodeTipClient <- mkTipSyncClient tr np localTxSubmissionQ (writeChan nodeTipChan) (atomically . writeTVar protocolParamsVar) + (atomically . writeTVar interpreterVar . Just) link =<< async (connectClient tr handlers nodeTipClient versionData addrInfo) - pure (nodeTipChan, protocolParamsVar, localTxSubmissionQ) + pure (nodeTipChan, protocolParamsVar, interpreterVar, localTxSubmissionQ) connectDelegationRewardsClient handlers = do cmdQ <- atomically newTQueue - let cl = mkDelegationRewardsClient tr cmdQ + let cl = mkDelegationRewardsClient tr cfg cmdQ link =<< async (connectClient tr handlers cl versionData addrInfo) pure cmdQ @@ -338,15 +372,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 @@ -363,38 +398,48 @@ withNetworkLayer tr np addrInfo versionData action = do atomically (readTVar nodeTipVar) _postTx localTxSubmissionQ tx = do - liftIO $ traceWith tr $ MsgPostSealedTx tx - result <- liftIO $ localTxSubmissionQ `send` CmdSubmitTx (toGenTx tx) + liftIO $ traceWith tr $ MsgPostTx tx + result <- liftIO $ localTxSubmissionQ `send` CmdSubmitTx tx case result of SubmitSuccess -> pure () SubmitFail err -> throwE $ ErrPostTxBadRequest $ T.pack (show err) - handleQueryFailure = withExceptT - (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected" ++ show e) . ExceptT + -- fixme: only shelley transactions can be submitted like this, because they + -- are deserialised as shelley transactions before submitting. + _postSealedTx localTxSubmissionQ tx = do + liftIO $ traceWith tr $ MsgPostSealedTx tx + _postTx localTxSubmissionQ (toShelleyGenTx tx) + + handleQueryFailure :: forall e r. Show e => IO (Either e r) -> ExceptT ErrNetworkUnavailable IO r + handleQueryFailure = + withExceptT (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected " ++ show e) . ExceptT _stakeDistribution queue pt coin = do - stakeMap <- fromPoolDistr <$> handleQueryFailure - (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution) + stakeMap <- handleQueryFailure + (queue `send` CmdQueryLocalState pt (QueryIfCurrentShelley Shelley.GetStakeDistribution)) let toStake = Set.singleton $ Left $ toShelleyCoin coin liftIO $ traceWith tr $ MsgWillQueryRewardsForStake coin - rewardsPerAccount <- fromNonMyopicMemberRewards <$> handleQueryFailure - (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake)) + rewardsPerAccount <- handleQueryFailure + (queue `send` CmdQueryLocalState pt (QueryIfCurrentShelley (Shelley.GetNonMyopicMemberRewards toStake))) pparams <- handleQueryFailure - (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams) - - let rewardMap = fromMaybe - (error "stakeDistribution: requested rewards not included in response") - (Map.lookup (Left coin) rewardsPerAccount) - - let res = NodePoolLsqData - (optimumNumberOfPools pparams) - rewardMap - stakeMap - liftIO $ traceWith tr $ MsgFetchedNodePoolLsqDataSummary - (Map.size stakeMap) - (Map.size rewardMap) - liftIO $ traceWith tr $ MsgFetchedNodePoolLsqData res - return res + (queue `send` CmdQueryLocalState pt (QueryIfCurrentShelley Shelley.GetCurrentPParams)) + + let fromJustRewards = fromMaybe (error "stakeDistribution: requested rewards not included in response") + let getRewardMap = fromJustRewards . Map.lookup (Left coin) . fromNonMyopicMemberRewards + + -- The result will be Nothing if query occurs during the byron era + let mres = eitherToMaybe $ NodePoolLsqData + <$> fmap optimumNumberOfPools pparams + <*> fmap getRewardMap rewardsPerAccount + <*> fmap fromPoolDistr stakeMap + liftIO $ traceWith tr $ MsgFetchedNodePoolLsqData mres + case mres of + Just res -> do + liftIO $ traceWith tr $ MsgFetchedNodePoolLsqDataSummary + (Map.size $ stake res) + (Map.size $ rewards res) + return res + Nothing -> pure $ NodePoolLsqData 0 mempty mempty _watchNodeTip nodeTipChan cb = do chan <- dupChan nodeTipChan @@ -404,8 +449,13 @@ withNetworkLayer tr np addrInfo versionData action = do bracketTracer (contramap (MsgWatcherUpdate header) tr) $ cb header -type instance GetStakeDistribution (IO Shelley) m - = (Point ShelleyBlock + _timeInterpreterQuery :: TVar IO (Maybe (CardanoInterpreter sc)) -> TimeInterpreter IO + _timeInterpreterQuery var q = atomically (readTVar var) >>= \case + Just i -> mkTimeInterpreter getGenesisBlockDate i q + Nothing -> interpreterFromGenesis gp q + +type instance GetStakeDistribution (IO Shelley) (CardanoBlock sc) m + = (Point (CardanoBlock sc) -> W.Coin -> ExceptT ErrNetworkUnavailable m NodePoolLsqData) @@ -446,11 +496,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 @@ -458,7 +508,7 @@ mkWalletClient tr gp chainSyncQ = do pure $ nodeToClientProtocols (const $ return $ NodeToClientProtocols { localChainSyncProtocol = InitiatorProtocolOnly $ MuxPeerRaw $ \channel -> - runPipelinedPeer nullTracer (cChainSyncCodec codecs) channel + runPipelinedPeer nullTracer (cChainSyncCodec $ codecs cfg) channel $ chainSyncClientPeerPipelined $ chainSyncWithBlocks tr' (fromTip' gp) chainSyncQ stash @@ -468,7 +518,7 @@ mkWalletClient tr gp chainSyncQ = do , localStateQueryProtocol = doNothingProtocol }) - NodeToClientV_2 + NodeToClientV_3 where tr' = contramap (mapChainSyncLog showB showP) tr showB = showP . blockPoint @@ -478,20 +528,22 @@ mkWalletClient tr gp chainSyncQ = do [ "(slotNo " , T.pack $ show $ unSlotNo $ Point.blockPointSlot blk , ", " - , pretty $ fromShelleyHash $ Point.blockPointHash blk + , pretty $ fromCardanoHash $ Point.blockPointHash blk , ")" ] + cfg = codecConfig gp -- | 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) + -> CodecConfig (CardanoBlock sc) + -> TQueue m (LocalStateQueryCmd (CardanoBlock sc) m) -- ^ Communication channel with the LocalStateQuery client -> NetworkClient m -mkDelegationRewardsClient tr queryRewardQ = +mkDelegationRewardsClient tr cfg queryRewardQ = nodeToClientProtocols (const $ return $ NodeToClientProtocols { localChainSyncProtocol = doNothingProtocol @@ -505,16 +557,46 @@ mkDelegationRewardsClient tr queryRewardQ = $ localStateQueryClientPeer $ localStateQuery queryRewardQ }) - NodeToClientV_2 + NodeToClientV_3 where tr' = contramap (MsgLocalStateQuery DelegationRewardsClient) tr - codec = cStateQueryCodec serialisedCodecs + codec = cStateQueryCodec (serialisedCodecs cfg) + +{------------------------------------------------------------------------------- + Codecs +-------------------------------------------------------------------------------} + +-- | The protocol client version. Distinct from the codecs version. +nodeToClientVersion :: NodeToClientVersion +nodeToClientVersion = NodeToClientV_3 -codecs :: MonadST m => ClientCodecs ShelleyBlock m -codecs = clientCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 +codecVersion :: forall sc. TPraosCrypto sc => BlockNodeToClientVersion (CardanoBlock sc) +codecVersion = verMap ! nodeToClientVersion + where verMap = supportedNodeToClientVersions (Proxy @(CardanoBlock sc)) -serialisedCodecs :: MonadST m => DefaultCodecs ShelleyBlock m -serialisedCodecs = defaultCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 +codecConfig :: W.GenesisParameters -> CodecConfig (CardanoBlock sc) +codecConfig gp = CardanoCodecConfig (byronCodecConfig gp) ShelleyCodecConfig + +-- | A group of codecs which will deserialise block data. +codecs + :: forall m sc. (MonadST m, TPraosCrypto sc) + => CodecConfig (CardanoBlock sc) + -> ClientCodecs (CardanoBlock sc) m +codecs cfg = clientCodecs cfg codecVersion + +-- | A group of codecs which won't deserialise block data. Often only the block +-- headers are needed. It's more efficient and easier not to deserialise. +serialisedCodecs + :: forall m sc. (MonadST m, TPraosCrypto sc) + => CodecConfig (CardanoBlock sc) + -> DefaultCodecs (CardanoBlock sc) m +serialisedCodecs cfg = defaultCodecs cfg codecVersion + +{------------------------------------------------------------------------------- + Tip sync +-------------------------------------------------------------------------------} + +type CardanoInterpreter sc = Interpreter (CardanoEras sc) -- | Construct a network client with the given communication channel, for the -- purpose of: @@ -522,24 +604,27 @@ serialisedCodecs = defaultCodecs ShelleyCodecConfig ShelleyNodeToClientVersion1 -- * Submitting transactions -- * Tracking the node tip -- * Tracking the latest protocol parameters state. +-- * Querying the history interpreter as necessary. 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. + -> (CardanoInterpreter sc -> m ()) + -- ^ Notifier callback for when time interpreter is updates -> m (NetworkClient m) -mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do +mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate onInterpreterUpdate = do localStateQueryQ <- atomically newTQueue (onPParamsUpdate' :: W.ProtocolParameters -> m ()) <- @@ -549,37 +634,60 @@ 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 + queryInterpreter + :: Point (CardanoBlock sc) + -> m () + queryInterpreter pt = do + res <- localStateQueryQ `send` CmdQueryLocalState pt (QueryHardFork GetInterpreter) + case res of + Left (e :: AcquireFailure) -> + traceWith tr $ MsgLocalStateQueryError TipSyncClient $ show e + Right interpreter -> do + traceWith tr $ MsgInterpreter interpreter + onInterpreterUpdate interpreter + + gp@W.GenesisParameters { getGenesisBlockHash } = W.genesisParameters np + cfg = codecConfig gp - onTipUpdate' <- debounce @(Tip ShelleyBlock) @m $ \tip' -> do + onTipUpdate' <- debounce @(Tip (CardanoBlock sc)) @m $ \tip' -> do let tip = castTip tip' traceWith tr $ MsgNodeTip $ fromTip getGenesisBlockHash tip onTipUpdate tip queryLocalState (getTipPoint tip) + -- NOTE: interpeter is updated every block. This is far more often than + -- necessary. + queryInterpreter (getTipPoint tip) pure $ nodeToClientProtocols (const $ return $ NodeToClientProtocols { localChainSyncProtocol = let - codec = cChainSyncCodec $ serialisedCodecs @m + codec = cChainSyncCodec $ serialisedCodecs @m cfg in InitiatorProtocolOnly $ MuxPeerRaw $ \channel -> runPeer nullTracer codec channel @@ -589,7 +697,7 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do , localTxSubmissionProtocol = let tr' = contramap MsgTxSubmission tr - codec = cTxSubmissionCodec serialisedCodecs + codec = cTxSubmissionCodec $ serialisedCodecs cfg in InitiatorProtocolOnly $ MuxPeerRaw $ \channel -> runPeer tr' codec channel @@ -599,14 +707,14 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do , localStateQueryProtocol = let tr' = contramap (MsgLocalStateQuery TipSyncClient) tr - codec = cStateQueryCodec serialisedCodecs + codec = cStateQueryCodec $ serialisedCodecs cfg in InitiatorProtocolOnly $ MuxPeerRaw $ \channel -> runPeer tr' codec channel $ localStateQueryClientPeer $ localStateQuery localStateQueryQ }) - NodeToClientV_2 + NodeToClientV_3 -- | Return a function to run an action only if its single parameter has changed @@ -631,7 +739,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) @@ -639,7 +747,7 @@ connectClient -> IO () connectClient tr handlers client (vData, vCodec) addr = withIOManager $ \iocp -> do let vDict = DictVersion vCodec - let versions = simpleSingletonVersions NodeToClientV_2 vData vDict client + let versions = simpleSingletonVersions nodeToClientVersion vData vDict client let tracers = NetworkConnectTracers { nctMuxTracer = nullTracer , nctHandshakeTracer = contramap MsgHandshakeTracer tr @@ -655,7 +763,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 @@ -666,7 +774,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 @@ -722,37 +830,44 @@ 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 + MsgPostTx :: CardanoGenTx sc -> 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 + -> (Map (SL.Credential 'SL.Staking sc) (SL.KeyHash 'SL.StakePool sc)) + -> SL.RewardAccounts sc + -> NetworkLayerLog sc + MsgDestroyCursor :: ThreadId -> NetworkLayerLog sc + MsgWillQueryRewardsForStake :: W.Coin -> NetworkLayerLog sc + MsgFetchedNodePoolLsqData :: Maybe 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 + MsgInterpreter :: CardanoInterpreter sc -> NetworkLayerLog sc data QueryClientName = TipSyncClient @@ -761,7 +876,7 @@ data QueryClientName type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) -instance ToText NetworkLayerLog where +instance TPraosCrypto sc => ToText (NetworkLayerLog sc) where toText = \case MsgCouldntConnect n -> T.unwords [ "Couldn't connect to node (x" <> toText (n + 1) <> ")." @@ -770,7 +885,7 @@ instance ToText NetworkLayerLog where MsgConnectionLost Nothing -> "Connection lost with the node." MsgConnectionLost (Just e) -> T.unwords - [ toText (MsgConnectionLost Nothing) + [ toText @(NetworkLayerLog sc) (MsgConnectionLost Nothing) , T.pack (show e) ] MsgTxSubmission msg -> @@ -789,6 +904,10 @@ instance ToText NetworkLayerLog where [ "Posting transaction, serialized as:" , T.decodeUtf8 $ convertToBase Base16 bytes ] + MsgPostTx genTx -> T.unwords + [ "Posting transaction:" + , T.pack $ show genTx + ] MsgLocalStateQuery client msg -> T.pack (show client <> " " <> show msg) MsgNodeTip bh -> T.unwords @@ -805,6 +924,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 @@ -835,9 +956,11 @@ instance ToText NetworkLayerLog where "Update watcher with tip: " <> pretty tip <> ". Callback " <> toText b <> "." MsgChainSyncCmd a -> toText a + MsgInterpreter interpreter -> + "Updated the history interpreter: " <> T.pack (show interpreter) -instance HasPrivacyAnnotation NetworkLayerLog -instance HasSeverityAnnotation NetworkLayerLog where +instance HasPrivacyAnnotation (NetworkLayerLog b) +instance HasSeverityAnnotation (NetworkLayerLog b) where getSeverityAnnotation = \case MsgCouldntConnect 0 -> Debug MsgCouldntConnect 1 -> Notice @@ -849,10 +972,12 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgFindIntersection{} -> Info MsgIntersectionFound{} -> Info MsgPostSealedTx{} -> Debug + MsgPostTx{} -> Debug MsgLocalStateQuery{} -> Debug MsgNodeTip{} -> Debug MsgProtocolParameters{} -> Info MsgLocalStateQueryError{} -> Error + MsgLocalStateQueryEraMismatch{} -> Debug MsgGetRewardAccountBalance{} -> Info MsgAccountDelegationAndRewards{} -> Info MsgDestroyCursor{} -> Notice @@ -860,4 +985,5 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgFetchedNodePoolLsqData{} -> Debug MsgFetchedNodePoolLsqDataSummary{} -> Info MsgWatcherUpdate{} -> Debug - MsgChainSyncCmd cmd -> getSeverityAnnotation cmd + MsgChainSyncCmd cmd -> getSeverityAnnotation cmd + MsgInterpreter{} -> Debug diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index e17988a23d9..2d723055655 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -68,11 +69,11 @@ import Cardano.Wallet.Primitive.Types ) import Cardano.Wallet.Shelley.Compatibility ( Shelley - , ShelleyBlock - , fromShelleyBlock' , getProducer - , toBlockHeader + , poolCertsFromShelleyBlock + , toCardanoBlockHeader , toPoint + , toShelleyBlockHeader ) import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) @@ -112,6 +113,10 @@ import Fmt ( fixedF, pretty ) import GHC.Generics ( Generic ) +import Ouroboros.Consensus.Cardano.Block + ( CardanoBlock, HardForkBlock (..) ) +import Ouroboros.Consensus.Shelley.Protocol + ( TPraosCrypto ) import qualified Cardano.Wallet.Api.Types as Api import qualified Data.Map.Merge.Strict as Map @@ -135,11 +140,12 @@ data StakePoolLayer = StakePoolLayer } newStakePoolLayer - :: GenesisParameters - -> NetworkLayer IO (IO Shelley) b + :: forall sc. + GenesisParameters + -> NetworkLayer IO (IO Shelley) (CardanoBlock sc) -> DBLayer IO -> StakePoolLayer -newStakePoolLayer gp nl db = StakePoolLayer +newStakePoolLayer gp NetworkLayer{stakeDistribution,currentNodeTip} db = StakePoolLayer { knownPools = _knownPools , listStakePools = _listPools } @@ -150,7 +156,7 @@ newStakePoolLayer gp nl db = StakePoolLayer tip <- getTip let dummyCoin = Coin 0 res <- runExceptT $ map fst . Map.toList - . combineLsqData <$> stakeDistribution nl tip dummyCoin + . combineLsqData <$> stakeDistribution tip dummyCoin case res of Right x -> return x Left _e -> return [] @@ -160,7 +166,7 @@ newStakePoolLayer gp nl db = StakePoolLayer -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] _listPools userStake = do tip <- liftIO getTip - lsqData <- combineLsqData <$> stakeDistribution nl tip userStake + lsqData <- combineLsqData <$> stakeDistribution tip userStake dbData <- liftIO $ readPoolDbData db return . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) @@ -169,7 +175,7 @@ newStakePoolLayer gp nl db = StakePoolLayer $ combineDbAndLsqData (slotParams gp) lsqData dbData gh = getGenesisBlockHash gp - getTip = fmap (toPoint gh) . liftIO $ unsafeRunExceptT $ currentNodeTip nl + getTip = fmap (toPoint gh) . liftIO $ unsafeRunExceptT currentNodeTip -- -- Data Combination functions @@ -337,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 @@ -362,45 +369,48 @@ monitorStakePools tr gp nl db@DBLayer{..} = do initCursor = atomically $ readPoolProductionCursor (max 100 k) where k = fromIntegral $ getQuantity getEpochStability - getHeader :: ShelleyBlock -> BlockHeader - getHeader = toBlockHeader getGenesisBlockHash + getHeader :: CardanoBlock sc -> BlockHeader + getHeader = toCardanoBlockHeader gp forward - :: NonEmpty ShelleyBlock + :: NonEmpty (CardanoBlock sc) -> (BlockHeader, ProtocolParameters) -> IO (FollowAction ()) forward blocks (_nodeTip, _pparams) = do - atomically $ forM_ blocks $ \blk -> do - let (slot, certificates) = fromShelleyBlock' blk - runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) - >>= \case - Left e -> - liftIO $ traceWith tr $ MsgErrProduction e - Right () -> - pure () - - -- A single block can contain multiple certificates relating to the - -- same pool. - -- - -- The /order/ in which certificates appear is /significant/: - -- certificates that appear later in a block /generally/ take - -- precedence over certificates that appear earlier on. - -- - -- We record /all/ certificates within the database, together with - -- the order in which they appeared. - -- - -- Precedence is determined by the 'readPoolLifeCycleStatus' - -- function. - -- - let publicationTimes = - CertificatePublicationTime slot <$> [minBound ..] - forM_ (publicationTimes `zip` certificates) $ \case - (publicationTime, Registration cert) -> do - liftIO $ traceWith tr $ MsgStakePoolRegistration cert - putPoolRegistration publicationTime cert - (publicationTime, Retirement cert) -> do - liftIO $ traceWith tr $ MsgStakePoolRetirement cert - putPoolRetirement publicationTime cert + atomically $ forM_ blocks $ \case + BlockByron _ -> pure () + BlockShelley blk -> do + let (slot, certificates) = poolCertsFromShelleyBlock blk + let header = toShelleyBlockHeader getGenesisBlockHash blk + runExceptT (putPoolProduction header (getProducer blk)) + >>= \case + Left e -> + liftIO $ traceWith tr $ MsgErrProduction e + Right () -> + pure () + + -- A single block can contain multiple certificates relating to the + -- same pool. + -- + -- The /order/ in which certificates appear is /significant/: + -- certificates that appear later in a block /generally/ take + -- precedence over certificates that appear earlier on. + -- + -- We record /all/ certificates within the database, together with + -- the order in which they appeared. + -- + -- Precedence is determined by the 'readPoolLifeCycleStatus' + -- function. + -- + let publicationTimes = + CertificatePublicationTime slot <$> [minBound ..] + forM_ (publicationTimes `zip` certificates) $ \case + (publicationTime, Registration cert) -> do + liftIO $ traceWith tr $ MsgStakePoolRegistration cert + putPoolRegistration publicationTime cert + (publicationTime, Retirement cert) -> do + liftIO $ traceWith tr $ MsgStakePoolRetirement cert + putPoolRetirement publicationTime cert pure Continue monitorMetadata diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index a60f674dfd5..cc514159096 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -38,6 +38,8 @@ import Prelude import Cardano.Address.Derivation ( XPrv, XPub, toXPub, xpubPublicKey ) +import Cardano.Api.Typed + ( Shelley ) import Cardano.Binary ( serialize' ) import Cardano.Crypto.DSIGN @@ -73,8 +75,7 @@ import Cardano.Wallet.Primitive.Types , TxOut (..) ) import Cardano.Wallet.Shelley.Compatibility - ( Shelley - , TPraosStandardCrypto + ( TPraosStandardCrypto , fromNetworkDiscriminant , toByronNetworkMagic , toCardanoLovelace @@ -99,6 +100,8 @@ import Crypto.Error ( throwCryptoError ) import Data.ByteString ( ByteString ) +import Data.ByteString.Short + ( toShort ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -109,6 +112,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 @@ -116,8 +121,9 @@ import Ouroboros.Network.Block import Type.Reflection ( Typeable ) -import qualified Cardano.Api as Cardano -import qualified Cardano.Api.Typed as CardanoTyped +import qualified Byron.Spec.Ledger.Core as Byron +import qualified Byron.Spec.Ledger.UTxO as Byron +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 @@ -140,24 +146,23 @@ import qualified Shelley.Spec.Ledger.Tx as SL import qualified Shelley.Spec.Ledger.TxData as SL import qualified Shelley.Spec.Ledger.UTxO as SL - -- | Type encapsulating what we need to know to add things -- payloads, -- certificates -- to a transaction. -- -- Designed to allow us to have /one/ @mkTx@ which doesn't care whether we -- include certificates or not. -data TxPayload c = TxPayload +data TxPayload era = TxPayload { _certificates :: [Cardano.Certificate] -- ^ Certificates to be included in the transactions. - , _extraWitnesses :: SL.TxBody c -> SL.WitnessSet c + , _extraWitnesses :: Cardano.TxBody era -> [Cardano.Witness era] -- ^ Create payload-specific witesses given the unsigned transaction body. -- -- Caller has the freedom and responsibility to provide the correct -- witnesses for what they're trying to do. } -emptyTxPayload :: Crypto c => TxPayload c +emptyTxPayload :: TxPayload era emptyTxPayload = TxPayload mempty mempty data TxWitnessTag @@ -183,7 +188,7 @@ mkTx ) => Proxy n -> ProtocolMagic - -> TxPayload TPraosStandardCrypto + -> TxPayload Shelley -> SlotNo -- ^ Time to Live -> (k 'AddressK XPrv, Passphrase "encryption") @@ -192,6 +197,7 @@ mkTx -> CoinSelection -> Either ErrMkTx (Tx, SealedTx) mkTx proxy pm (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do + {- let wdrls = mkWithdrawals proxy (toChimericAccountRaw . getRawKey . publicKey $ rewardAcnt) @@ -199,16 +205,22 @@ mkTx proxy pm (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) key let unsigned = mkUnsignedTx timeToLive cs wdrls certs - wits <- case (txWitnessTagFor @k) of + sealed <- case (txWitnessTagFor @k) of TxWitnessShelleyUTxO -> do + let paymentKey = _ (getRawKey k, pwd) + let stakeKey + | null wdrls = [] + | otherwise = [_ (getRawKey rewardAcnt, pwdAcnt)] + + tx <- signShelleyTransaction unsigned (paymentKey:stakeKey) addrWits <- fmap Set.fromList $ forM (CS.inputs cs) $ \(_, TxOut addr _) -> do (k, pwd) <- lookupPrivateKey keyFrom addr - pure $ mkShelleyWitness unsigned (getRawKey k, pwd) + pure $ mkShelleyWitness unsigned let wdrlsWits - | Map.null wdrls = Set.empty + | null wdrls = Set.empty | otherwise = Set.singleton $ - mkShelleyWitness unsigned (getRawKey rewardAcnt, pwdAcnt) + mkShelleyWitness unsigned pure $ (SL.WitnessSet (addrWits <> wdrlsWits) mempty mempty) <> mkExtraWits unsigned @@ -222,7 +234,9 @@ mkTx proxy pm (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) key let metadata = SL.SNothing - pure $ toSealed $ SL.Tx unsigned wits metadata + pure $ (SL.Tx unsigned wits metadata, SealedTx sealed) + -} + error "fixme: mkTx" newTransactionLayer :: forall (n :: NetworkDiscriminant) k t. @@ -283,10 +297,7 @@ newTransactionLayer proxy protocolMagic = TransactionLayer else [ toStakePoolDlgCert accXPub poolId ] - let mkWits unsigned = SL.WitnessSet - (Set.singleton (mkShelleyWitness unsigned (getRawKey accXPrv, pwd'))) - mempty - mempty + let mkWits unsigned = [mkShelleyWitness unsigned (getRawKey accXPrv, pwd')] let payload = TxPayload certs mkWits let ttl = defaultTTL tip @@ -306,11 +317,7 @@ newTransactionLayer proxy protocolMagic = TransactionLayer _mkDelegationQuitTx acc@(accXPrv, pwd') keyFrom tip cs = do let accXPub = toXPub $ getRawKey accXPrv let certs = [toStakeKeyDeregCert accXPub] - let mkWits unsigned = SL.WitnessSet - (Set.singleton (mkShelleyWitness unsigned (getRawKey accXPrv, pwd'))) - mempty - mempty - + let mkWits unsigned = [mkShelleyWitness unsigned (getRawKey accXPrv, pwd')] let payload = TxPayload certs mkWits let ttl = defaultTTL tip mkTx proxy protocolMagic payload ttl acc keyFrom cs @@ -366,8 +373,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) @@ -401,11 +408,9 @@ computeTxSize -> CoinSelection -> Integer computeTxSize proxy pm witTag action cs = - SL.txsize $ SL.Tx unsigned wits metadata + SL.txsize $ SL.Tx unsigned wits (SL.maybeToStrictMaybe metadata) where - metadata = SL.SNothing - - unsigned = mkUnsignedTx maxBound cs' wdrls certs + Cardano.ShelleyTxBody unsigned metadata = mkUnsignedTx maxBound cs' wdrls certs where cs' :: CoinSelection cs' = cs @@ -416,19 +421,21 @@ computeTxSize proxy pm witTag action cs = dummyOutput :: Coin -> TxOut dummyOutput = TxOut $ Address $ BS.pack (1:replicate 56 0) - dummyKeyHash = SL.KeyHash . Hash.UnsafeHash $ dummyKeyHashRaw + dummyKeyHash = SL.KeyHash . Hash.UnsafeHash . toShort $ 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) @@ -441,7 +448,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") @@ -453,7 +460,7 @@ computeTxSize proxy pm witTag action cs = key = SL.VKey $ fromMaybe (error "error creating dummy witness ver key") $ rawDeserialiseVerKeyDSIGN - $ bloatChaff keyLen chaff + $ bloatChaff vkeyLen chaff sig = SignedDSIGN $ fromMaybe (error "error creating dummy witness sig") @@ -466,16 +473,16 @@ computeTxSize proxy pm witTag action cs = where chaff = L8.pack (show ix) <> BL.fromStrict txid - byronWits = Set.map dummyWitnessUniq $ Set.fromList (CS.inputs cs) + byronWits = map dummyWitnessUniq $ CS.inputs cs where - dummyWitness :: BL.ByteString -> Address -> SL.BootstrapWitness TPraosStandardCrypto + dummyWitness :: BL.ByteString -> Address -> Cardano.Witness Shelley dummyWitness chaff addr = - SL.BootstrapWitness key sig cc padding + Cardano.ShelleyBootstrapWitness $ SL.BootstrapWitness vkey sig cc attrs where - key = SL.VKey + vkey = SL.VKey $ fromMaybe (error "error creating dummy witness ver key") $ rawDeserialiseVerKeyDSIGN - $ bloatChaff keyLen chaff + $ bloatChaff vkeyLen chaff sig = SignedDSIGN $ fromMaybe (error "error creating dummy witness sig") @@ -485,13 +492,10 @@ computeTxSize proxy pm witTag action cs = cc = SL.ChainCode $ bloatChaff ccLen "0" - padding = SL.byronVerKeyAddressPadding - $ Byron.mkAttributes - $ Byron.AddrAttributes - (toHDPayloadAddress addr) - (toByronNetworkMagic pm) + -- attrs = serialize' $ Byron.addrAttributes addr + attrs = error "fixme: attributes of byron address" - dummyWitnessUniq :: (TxIn, TxOut) -> SL.BootstrapWitness TPraosStandardCrypto + dummyWitnessUniq :: (TxIn, TxOut) -> Cardano.Witness Shelley dummyWitnessUniq (TxIn (Hash txid) ix, TxOut addr _) = dummyWitness chaff addr where @@ -499,18 +503,19 @@ computeTxSize proxy pm witTag action cs = sigLen = sizeSigDSIGN $ Proxy @(DSIGN TPraosStandardCrypto) - keyLen = sizeVerKeyDSIGN $ Proxy @(DSIGN TPraosStandardCrypto) + vkeyLen = sizeVerKeyDSIGN $ Proxy @(DSIGN TPraosStandardCrypto) ccLen = 32 bloatChaff :: Word -> BL.ByteString -> ByteString bloatChaff n = BL.toStrict . BL.take (fromIntegral n) . BL.cycle - wits = case witTag of - TxWitnessShelleyUTxO -> - SL.WitnessSet (Set.union addrWits certWits) mempty mempty - TxWitnessByronUTxO -> - SL.WitnessSet mempty mempty byronWits + wits = error "fixme: txSize wits" + -- wits = case witTag of + -- TxWitnessShelleyUTxO -> + -- SL.WitnessSet (Set.union addrWits certWits) mempty mempty + -- TxWitnessByronUTxO -> + -- SL.WitnessSet mempty mempty byronWits lookupPrivateKey :: (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) @@ -522,61 +527,63 @@ 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 - keyHashObj = SL.KeyHashObj $ SL.KeyHash $ Hash.UnsafeHash keyHash + keyHashObj = SL.KeyHashObj $ SL.KeyHash $ Hash.UnsafeHash $ toShort keyHash -- NOTE: The (+7200) was selected arbitrarily when we were trying to get -- this working on the FF testnet. Perhaps a better motivated and/or -- configurable value would be better. -defaultTTL :: SlotNo -> SlotNo -defaultTTL slot = slot + 7200 +defaultTTL :: SlotNo -> SlotNo +defaultTTL = (+ 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 + Cardano.makeShelleyKeyWitness body (Cardano.WitnessPaymentKey $ key) where - sig = SignedDSIGN - $ fromMaybe (error "error converting signatures") - $ rawDeserialiseSigDSIGN - $ serialize' (SL.hashTxBody body) `signWith` (prv, pwd) - - key = SL.VKey - $ VerKeyEd25519DSIGN - $ unsafeMkEd25519 - $ toXPub prv + key = error "fixme: SigningKey PaymentKey" + -- vk = SL.VKey + -- $ VerKeyEd25519DSIGN + -- $ unsafeMkEd25519 + -- $ toXPub prv signWith :: ByteString @@ -596,6 +603,7 @@ mkByronWitness -> (XPrv, Passphrase "encryption") -> SL.BootstrapWitness TPraosStandardCrypto mkByronWitness body protocolMagic addr (prv, Passphrase pwd) = + -- fixme: use makeShelleyBootstrapWitness SL.makeBootstrapWitness txHash signingKey addrAttr where (SL.TxId txHash) = SL.txid body diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs index 0486f0ea457..636658fbd57 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs @@ -50,13 +50,13 @@ import Cardano.Wallet.Primitive.Types , SlotId (..) ) import Cardano.Wallet.Shelley.Compatibility - ( ShelleyBlock + ( CardanoBlock , TPraosStandardCrypto , decentralizationLevelFromPParams , fromTip , invertUnitInterval + , toCardanoHash , toPoint - , toShelleyHash ) import Cardano.Wallet.Unsafe ( unsafeMkEntropy ) @@ -87,7 +87,7 @@ import GHC.TypeLits import Ouroboros.Consensus.Shelley.Protocol.Crypto ( Crypto (..) ) import Ouroboros.Network.Block - ( BlockNo (..), SlotNo (..), Tip (..), getTipPoint ) + ( BlockNo (..), Point, SlotNo (..), Tip (..), getTipPoint ) import Test.Hspec ( Spec, describe, it, shouldBe ) import Test.Hspec.QuickCheck @@ -110,6 +110,7 @@ import Test.QuickCheck import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley +import qualified Cardano.Wallet.Primitive.Types as W import qualified Codec.Binary.Bech32 as Bech32 import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T @@ -122,7 +123,7 @@ spec = do describe "Conversions" $ it "toPoint' . fromTip' == getTipPoint" $ property $ \gh tip -> do let fromTip' = fromTip gh - let toPoint' = toPoint gh + let toPoint' = toPoint gh :: W.BlockHeader -> Point (CardanoBlock TPraosStandardCrypto) toPoint' (fromTip' tip) === (getTipPoint tip) describe "Shelley StakeAddress" $ do @@ -231,7 +232,7 @@ instance Arbitrary (Hash "BlockHeader") where instance Arbitrary ChimericAccount where arbitrary = ChimericAccount . BS.pack <$> vector 28 -instance Arbitrary (Tip ShelleyBlock) where +instance Arbitrary (Tip (CardanoBlock TPraosStandardCrypto)) where arbitrary = frequency [ (10, return TipGenesis) , (90, arbitraryTip) @@ -239,7 +240,7 @@ instance Arbitrary (Tip ShelleyBlock) where where arbitraryTip = do n <- choose (0, 100) - hash <- toShelleyHash + hash <- toCardanoHash . Hash . digest (Proxy @(HASH TPraosStandardCrypto)) . BS.pack <$> vector 5