[ADP-3198] era dependent functions to read transactions and header fr…

…om block (#4179)

- [x] rename Read.Block to Read.ConsensusBlock to free the Block type
name
- [x] add era dependent value for blocks
- [x] add era dependent function from block to transactions
- [x] add era dependent extraction from block to slot nubmber
- [x] add era dependent extraction from block to block number (height)
- [x] add header block extraction using Read.Block
- [x] add era dependent extraction from block to header hash and
previous hash

lib/read/cardano-wallet-read.cabal

@@ -48,6 +48,9 @@ library
     exposed-modules:
         Cardano.Wallet.Read
         Cardano.Wallet.Read.Block
+        Cardano.Wallet.Read.Block.BlockNo
+        Cardano.Wallet.Read.Block.HeaderHash
+        Cardano.Wallet.Read.Block.SlotNo
         Cardano.Wallet.Read.Eras
         Cardano.Wallet.Read.Eras.EraFun
         Cardano.Wallet.Read.Eras.EraValue
@@ -90,6 +93,7 @@ library
         , cardano-ledger-core
         , cardano-ledger-mary
         , cardano-ledger-shelley
+        , cardano-protocol-tpraos
         , cardano-strict-containers
         , containers
         , deepseq
@@ -99,7 +103,10 @@ library
         , generics-sop
         , lens
         , memory
+        , ouroboros-network-api
+        , ouroboros-consensus
         , ouroboros-consensus-cardano
+        , ouroboros-consensus-protocol
         , text
         , text-class
 

lib/read/lib/Cardano/Wallet/Read/Block.hs

@@ -1,18 +1,145 @@
-{- |
-Copyright: © 2022 IOHK
-License: Apache-2.0
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
-The 'Block' type represents blocks as they are read from the mainnet ledger.
-It is compatible with the era-specific types from @cardano-ledger@.
--}
+-- |
+-- Copyright: © 2022 IOHK
+-- License: Apache-2.0
+--
+-- The 'Block' type represents blocks as they are read from the mainnet ledger.
+-- It is compatible with the era-specific types from @cardano-ledger@.
 module Cardano.Wallet.Read.Block
-    ( Block
+    ( ConsensusBlock
+    , Block (..)
+    , fromConsensusBlock
+    , getTxs
     ) where
 
+import Prelude
+
+import Cardano.Api
+    ( AllegraEra
+    , AlonzoEra
+    , BabbageEra
+    , ByronEra
+    , ConwayEra
+    , MaryEra
+    , ShelleyEra
+    )
+import Cardano.Ledger.Api
+    ( StandardCrypto
+    )
+import Cardano.Ledger.Binary
+    ( EncCBOR
+    )
+import Cardano.Wallet.Read.Eras
+    ( (:.:) (..)
+    , EraFun (..)
+    , EraValue
+    , allegra
+    , alonzo
+    , applyEraFun
+    , babbage
+    , byron
+    , conway
+    , inject
+    , mary
+    , sequenceEraValue
+    , shelley
+    )
+import Cardano.Wallet.Read.Tx
+    ( Tx (..)
+    , TxT
+    )
+import Data.Foldable
+    ( toList
+    )
+import Ouroboros.Consensus.Protocol.Praos
+    ( Praos
+    )
+import Ouroboros.Consensus.Protocol.TPraos
+    ( TPraos
+    )
+import Ouroboros.Consensus.Shelley.Protocol.Abstract
+    ( ShelleyProtocolHeader
+    )
+
+import qualified Cardano.Chain.Block as Byron
+import qualified Cardano.Chain.UTxO as Byron
+import qualified Cardano.Ledger.Api as Ledger
+import qualified Cardano.Ledger.Era as Shelley
+import qualified Cardano.Ledger.Shelley.API as Shelley
+import qualified Ouroboros.Consensus.Byron.Ledger as Byron
+import qualified Ouroboros.Consensus.Byron.Ledger as O
 import qualified Ouroboros.Consensus.Cardano.Block as O
+import qualified Ouroboros.Consensus.Shelley.Ledger as O
 
 {-------------------------------------------------------------------------------
     Block type
 -------------------------------------------------------------------------------}
 -- | Type synonym for 'CardanoBlock' with cryptography as used on mainnet.
-type Block = O.CardanoBlock O.StandardCrypto
+type ConsensusBlock = O.CardanoBlock O.StandardCrypto
+
+-- Family of era-specific block types
+type family BlockT era where
+    BlockT ByronEra = O.ByronBlock
+    BlockT ShelleyEra =
+        O.ShelleyBlock (TPraos StandardCrypto) (O.ShelleyEra StandardCrypto)
+    BlockT AllegraEra =
+        O.ShelleyBlock (TPraos StandardCrypto) (O.AllegraEra StandardCrypto)
+    BlockT MaryEra =
+        O.ShelleyBlock (TPraos StandardCrypto) (O.MaryEra StandardCrypto)
+    BlockT AlonzoEra =
+        O.ShelleyBlock (TPraos StandardCrypto) (O.AlonzoEra StandardCrypto)
+    BlockT BabbageEra =
+        O.ShelleyBlock (Praos StandardCrypto) (O.BabbageEra StandardCrypto)
+    BlockT ConwayEra =
+        O.ShelleyBlock (Praos StandardCrypto) (O.ConwayEra StandardCrypto)
+
+newtype Block era = Block {unBlock :: BlockT era}
+
+-- | Get sequence of transactions in the block.
+txsFromBlockE :: EraFun Block ([] :.: Tx)
+txsFromBlockE =
+    EraFun
+        { byronFun = getTxs' getTxsFromBlockByron
+        , shelleyFun = getTxs' getTxsFromBlockShelleyAndOn
+        , maryFun = getTxs' getTxsFromBlockShelleyAndOn
+        , allegraFun = getTxs' getTxsFromBlockShelleyAndOn
+        , alonzoFun = getTxs' getTxsFromBlockShelleyAndOn
+        , babbageFun = getTxs' getTxsFromBlockShelleyAndOn
+        , conwayFun = getTxs' getTxsFromBlockShelleyAndOn
+        }
+  where
+    getTxs' f (Block block) = Comp $ Tx <$> f block
+
+getTxsFromBlockByron :: O.ByronBlock -> [TxT ByronEra]
+getTxsFromBlockByron block =
+    case Byron.byronBlockRaw block of
+        Byron.ABOBBlock b ->
+            map (() <$) . Byron.unTxPayload . Byron.blockTxPayload $ b
+        Byron.ABOBBoundary _ -> []
+
+getTxsFromBlockShelleyAndOn
+    :: (Shelley.EraSegWits era, EncCBOR (ShelleyProtocolHeader proto))
+    => O.ShelleyBlock proto era
+    -> [Ledger.Tx era]
+getTxsFromBlockShelleyAndOn (O.ShelleyBlock (Shelley.Block _ txs) _) =
+    toList (Shelley.fromTxSeq txs)
+
+-- | Convert block as received from cardano-node
+-- via Haskell library of mini-protocol.
+fromConsensusBlock :: ConsensusBlock -> EraValue Block
+fromConsensusBlock = \case
+    O.BlockByron b -> inject byron $ Block b
+    O.BlockShelley block -> inject shelley $ Block block
+    O.BlockAllegra block -> inject allegra $ Block block
+    O.BlockMary block -> inject mary $ Block block
+    O.BlockAlonzo block -> inject alonzo $ Block block
+    O.BlockBabbage block -> inject babbage $ Block block
+    O.BlockConway block -> inject conway $ Block block
+
+getTxs :: O.CardanoBlock StandardCrypto -> [EraValue Tx]
+getTxs = sequenceEraValue . applyEraFun txsFromBlockE . fromConsensusBlock

lib/read/lib/Cardano/Wallet/Read/Block/BlockNo.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Cardano.Wallet.Read.Block.BlockNo
+    ( getEraBlockNo
+    , BlockNo (..)
+    ) where
+
+import Prelude
+
+import Cardano.Ledger.Binary.Group
+    ( EncCBORGroup
+    )
+import Cardano.Ledger.Crypto
+    ( Crypto
+    )
+import Cardano.Ledger.Era
+    ( Era
+    , EraSegWits (..)
+    )
+import Cardano.Wallet.Read
+    ( Block (..)
+    )
+import Cardano.Wallet.Read.Eras.EraFun
+    ( EraFun (..)
+    )
+import Generics.SOP
+    ( K (..)
+    )
+import Numeric.Natural
+    ( Natural
+    )
+import Ouroboros.Consensus.Protocol.Praos
+    ( Praos
+    )
+import Ouroboros.Consensus.Protocol.TPraos
+    ( TPraos
+    )
+
+import qualified Cardano.Ledger.Shelley.API as Shelley
+import qualified Cardano.Protocol.TPraos.BHeader as Shelley
+import qualified Ouroboros.Consensus.Protocol.Praos.Header as O
+import qualified Ouroboros.Consensus.Shelley.Ledger.Block as O
+import qualified Ouroboros.Network.Block as O
+
+getEraBlockNo :: EraFun Block (K BlockNo)
+getEraBlockNo =
+    EraFun
+        { byronFun = \(Block block) -> k $ O.blockNo block
+        , shelleyFun = \(Block block) -> k $ getBlockNoShelley block
+        , allegraFun = \(Block block) -> k $ getBlockNoShelley block
+        , maryFun = \(Block block) -> k $ getBlockNoShelley block
+        , alonzoFun = \(Block block) -> k $ getBlockNoShelley block
+        , babbageFun = \(Block block) -> k $ getBlockNoBabbage block
+        , conwayFun = \(Block block) -> k $ getBlockNoBabbage block
+        }
+    where
+        k = K . BlockNo . fromIntegral . O.unBlockNo
+
+newtype BlockNo = BlockNo {unBlockNo :: Natural}
+
+getBlockNoShelley
+    :: (Era era, EncCBORGroup (TxSeq era), Crypto c)
+    => O.ShelleyBlock (TPraos c) era
+    -> O.BlockNo
+getBlockNoShelley
+    (O.ShelleyBlock (Shelley.Block (Shelley.BHeader header _) _) _) =
+        Shelley.bheaderBlockNo header
+getBlockNoBabbage
+    :: (Era era, EncCBORGroup (TxSeq era), Crypto crypto)
+    => O.ShelleyBlock (Praos crypto) era
+    -> O.BlockNo
+getBlockNoBabbage
+    (O.ShelleyBlock (Shelley.Block (O.Header header _) _) _) =
+        O.hbBlockNo header

lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Wallet.Read.Block.HeaderHash
+    ( getEraHeaderHash
+    , HeaderHash (..)
+    , HeaderHashT
+    , PrevHeaderHash (..)
+    , PrevHeaderHashT
+    , getEraPrevHeaderHash
+    )
+where
+
+import Prelude
+
+import Cardano.Api
+    ( AllegraEra
+    , AlonzoEra
+    , BabbageEra
+    , ByronEra
+    , ConwayEra
+    , MaryEra
+    , ShelleyEra
+    )
+import Cardano.Ledger.Binary
+    ( EncCBOR
+    , EncCBORGroup
+    )
+import Cardano.Ledger.Crypto
+    ( StandardCrypto
+    )
+import Cardano.Ledger.Era
+    ( Era
+    , EraSegWits (..)
+    )
+import Cardano.Protocol.TPraos.BHeader
+    ( PrevHash
+    )
+import Cardano.Wallet.Read
+    ( Block (..)
+    )
+import Cardano.Wallet.Read.Eras.EraFun
+    ( EraFun (..)
+    )
+import Ouroboros.Consensus.Block.Abstract
+    ( headerPrevHash
+    )
+import Ouroboros.Consensus.Byron.Ledger
+    ( ByronBlock
+    , ByronHash
+    )
+import Ouroboros.Consensus.Shelley.Ledger
+    ( ShelleyHash
+    )
+import Ouroboros.Consensus.Shelley.Protocol.Abstract
+    ( ProtoCrypto
+    )
+
+import qualified Cardano.Ledger.Shelley.API as Shelley
+import qualified Ouroboros.Consensus.Shelley.Ledger.Block as O
+import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Shelley
+import qualified Ouroboros.Network.Block as O
+
+type family HeaderHashT era where
+    HeaderHashT ByronEra = ByronHash
+    HeaderHashT ShelleyEra = ShelleyHash StandardCrypto
+    HeaderHashT AllegraEra = ShelleyHash StandardCrypto
+    HeaderHashT MaryEra = ShelleyHash StandardCrypto
+    HeaderHashT AlonzoEra = ShelleyHash StandardCrypto
+    HeaderHashT BabbageEra = ShelleyHash StandardCrypto
+    HeaderHashT ConwayEra = ShelleyHash StandardCrypto
+
+newtype HeaderHash era = HeaderHash (HeaderHashT era)
+
+getEraHeaderHash :: EraFun Block HeaderHash
+getEraHeaderHash =
+    EraFun
+        { byronFun = \(Block block) -> HeaderHash $ O.blockHash block
+        , shelleyFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        , allegraFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        , maryFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        , alonzoFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        , babbageFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        , conwayFun = \(Block block) -> HeaderHash $ getHeaderHashShelley block
+        }
+
+getHeaderHashShelley
+    :: ( ProtoCrypto (praos StandardCrypto) ~ StandardCrypto
+       , Shelley.ProtocolHeaderSupportsEnvelope (praos StandardCrypto)
+       , Era era
+       , EncCBORGroup (TxSeq era)
+       , EncCBOR (Shelley.ShelleyProtocolHeader (praos StandardCrypto))
+       )
+    => O.ShelleyBlock (praos StandardCrypto) era
+    -> ShelleyHash StandardCrypto
+getHeaderHashShelley
+    (O.ShelleyBlock (Shelley.Block header _) _) = Shelley.pHeaderHash header
+
+type family PrevHeaderHashT era where
+    PrevHeaderHashT ByronEra = O.ChainHash ByronBlock
+    PrevHeaderHashT ShelleyEra = PrevHash StandardCrypto
+    PrevHeaderHashT AllegraEra = PrevHash StandardCrypto
+    PrevHeaderHashT MaryEra = PrevHash StandardCrypto
+    PrevHeaderHashT AlonzoEra = PrevHash StandardCrypto
+    PrevHeaderHashT BabbageEra = PrevHash StandardCrypto
+    PrevHeaderHashT ConwayEra = PrevHash StandardCrypto
+
+newtype PrevHeaderHash era = PrevHeaderHash (PrevHeaderHashT era)
+
+getPrevHeaderHashShelley
+    :: ( Era era
+       , EncCBORGroup (TxSeq era)
+       , EncCBOR (Shelley.ShelleyProtocolHeader proto)
+       , Shelley.ProtocolHeaderSupportsEnvelope proto
+       )
+    => O.ShelleyBlock proto era
+    -> PrevHash (ProtoCrypto proto)
+getPrevHeaderHashShelley (O.ShelleyBlock (Shelley.Block header _) _) =
+    Shelley.pHeaderPrevHash header
+
+getEraPrevHeaderHash :: EraFun Block PrevHeaderHash
+getEraPrevHeaderHash =
+    EraFun
+        { byronFun = \(Block block) ->
+            PrevHeaderHash $ headerPrevHash $ O.getHeader block
+        , shelleyFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        , allegraFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        , maryFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        , alonzoFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        , babbageFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        , conwayFun = \(Block block) ->
+            PrevHeaderHash $ getPrevHeaderHashShelley block
+        }