add primitive certificates to Read hierarchy

lib/wallet/cardano-wallet.cabal

@@ -358,10 +358,13 @@ library
     Cardano.Wallet.Read.Primitive.Tx.Alonzo
     Cardano.Wallet.Read.Primitive.Tx.Babbage
     Cardano.Wallet.Read.Primitive.Tx.Byron
+    Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
     Cardano.Wallet.Read.Primitive.Tx.Mary
     Cardano.Wallet.Read.Primitive.Tx.Shelley
     Cardano.Wallet.Read.Tx
     Cardano.Wallet.Read.Tx.CBOR
+    Cardano.Wallet.Read.Tx.Certificates
+    Cardano.Wallet.Read.Tx.Eras
     Cardano.Wallet.Read.Tx.Hash
     Cardano.Wallet.Registry
     Cardano.Wallet.Shelley

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx.hs

@@ -12,8 +12,6 @@ module Cardano.Wallet.Read.Primitive.Tx (fromCardanoTx)
 
 import Prelude
 
-import Cardano.Wallet.Primitive.Types
-    ( Certificate (..) )
 import Cardano.Wallet.Read.Primitive.Tx.Allegra
     ( fromAllegraTx )
 import Cardano.Wallet.Read.Primitive.Tx.Alonzo
@@ -36,14 +34,15 @@ import qualified Cardano.Api as Cardano
 import qualified Cardano.Api.Byron as Cardano
     ( Tx (ByronTx) )
 import qualified Cardano.Api.Shelley as Cardano
+import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
 
 fromCardanoTx
     :: Cardano.Tx era
     ->  ( W.Tx
         , TokenMapWithScripts
         , TokenMapWithScripts
-        , [Certificate]
+        , [W.Certificate]
         , Maybe ValidityIntervalExplicit
         )
 fromCardanoTx = \case
@@ -68,3 +67,5 @@ fromCardanoTx = \case
   where
     extract (tx, certs, mint, burn, validity) =
         (tx, mint, burn, certs, validity)
+
+

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Allegra.hs

@@ -26,9 +26,10 @@ import Cardano.Api
     ( AllegraEra )
 import Cardano.Wallet.Read.Eras
     ( allegra, inject )
+import Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
+    ( anyEraCerts )
 import Cardano.Wallet.Read.Primitive.Tx.Shelley
-    ( fromShelleyCert
-    , fromShelleyCoin
+    ( fromShelleyCoin
     , fromShelleyMD
     , fromShelleyTxIn
     , fromShelleyTxOut
@@ -61,7 +62,6 @@ import qualified Cardano.Wallet.Primitive.Types.Coin as W
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
 import qualified Ouroboros.Network.Block as O
 
-
 -- NOTE: For resolved inputs we have to pass in a dummy value of 0.
 
 fromAllegraTx
@@ -97,7 +97,7 @@ fromAllegraTx tx =
         , scriptValidity =
             Nothing
         }
-    , map fromShelleyCert (toList certs)
+    , anyEraCerts certs
     , emptyTokenMapWithScripts
     , emptyTokenMapWithScripts
     , Just (fromLedgerTxValidity ttl)

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Alonzo.hs

@@ -29,11 +29,12 @@ import Cardano.Wallet.Read.Eras
     ( alonzo, inject )
 import Cardano.Wallet.Read.Primitive.Tx.Allegra
     ( fromLedgerTxValidity )
+import Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
+    ( anyEraCerts )
 import Cardano.Wallet.Read.Primitive.Tx.Mary
     ( fromCardanoValue, fromLedgerMintValue, getScriptMap )
 import Cardano.Wallet.Read.Primitive.Tx.Shelley
     ( fromShelleyAddress
-    , fromShelleyCert
     , fromShelleyCoin
     , fromShelleyMD
     , fromShelleyTxIn
@@ -126,7 +127,7 @@ fromAlonzoTx tx@(Alonzo.ValidatedTx bod wits (Alonzo.IsValid isValid) aux) =
         , scriptValidity =
             validity
         }
-    , map fromShelleyCert (toList certs)
+    , anyEraCerts certs
     , TokenMapWithScripts assetsToMint mintScriptMap
     , TokenMapWithScripts assetsToBurn burnScriptMap
     , Just (fromLedgerTxValidity ttl)

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Babbage.hs

@@ -32,11 +32,12 @@ import Cardano.Wallet.Read.Primitive.Tx.Allegra
     ( fromLedgerTxValidity )
 import Cardano.Wallet.Read.Primitive.Tx.Alonzo
     ( alonzoTxHash )
+import Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
+    ( anyEraCerts )
 import Cardano.Wallet.Read.Primitive.Tx.Mary
     ( fromCardanoValue, fromLedgerMintValue, getScriptMap )
 import Cardano.Wallet.Read.Primitive.Tx.Shelley
     ( fromShelleyAddress
-    , fromShelleyCert
     , fromShelleyCoin
     , fromShelleyMD
     , fromShelleyTxIn
@@ -111,7 +112,7 @@ fromBabbageTx tx@(Alonzo.ValidatedTx bod wits (Alonzo.IsValid isValid) aux) =
         , scriptValidity =
             validity
         }
-    , map fromShelleyCert (toList certs)
+    , anyEraCerts certs
     , TokenMapWithScripts assetsToMint mintScriptMap
     , TokenMapWithScripts assetsToBurn burnScriptMap
     , Just (fromLedgerTxValidity ttl)

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Mary.hs

@@ -28,9 +28,10 @@ import Cardano.Wallet.Read.Eras
     ( inject, mary )
 import Cardano.Wallet.Read.Primitive.Tx.Allegra
     ( fromLedgerTxValidity )
+import Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
+    ( anyEraCerts )
 import Cardano.Wallet.Read.Primitive.Tx.Shelley
     ( fromShelleyAddress
-    , fromShelleyCert
     , fromShelleyCoin
     , fromShelleyMD
     , fromShelleyTxIn
@@ -120,7 +121,7 @@ fromMaryTx tx =
         , scriptValidity =
             Nothing
         }
-    , map fromShelleyCert (toList certs)
+    , anyEraCerts certs
     , TokenMapWithScripts assetsToMint mintScriptMap
     , TokenMapWithScripts assetsToBurn burnScriptMap
     , Just (fromLedgerTxValidity ttl)

lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Shelley.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -15,7 +14,6 @@ module Cardano.Wallet.Read.Primitive.Tx.Shelley
     , fromShelleyCoin
     , fromShelleyWdrl
     , fromShelleyMD
-    , fromShelleyCert
     , fromShelleyTx
     , fromShelleyAddress
     )
@@ -27,19 +25,12 @@ import Cardano.Api
     ( ShelleyEra )
 import Cardano.Api.Shelley
     ( fromShelleyMetadata )
-import Cardano.Crypto.Hash.Class
-    ( hashToBytes )
-import Cardano.Ledger.BaseTypes
-    ( strictMaybeToMaybe, urlToText )
 import Cardano.Ledger.Era
     ( Era (..) )
-import Cardano.Slotting.Slot
-    ( EpochNo (..) )
-import Cardano.Wallet.Primitive.Types
-    ( PoolCertificate (..)
-    , PoolRegistrationCertificate (..)
-    , PoolRetirementCertificate (..)
-    )
+import Cardano.Wallet.Read.Eras
+    ( inject, shelley )
+import Cardano.Wallet.Read.Primitive.Tx.Features.Certificates
+    ( anyEraCerts, fromStakeCredential )
 import Cardano.Wallet.Read.Tx
     ( Tx (..) )
 import Cardano.Wallet.Read.Tx.CBOR
@@ -51,29 +42,22 @@ import Cardano.Wallet.Transaction
     , ValidityIntervalExplicit (..)
     , emptyTokenMapWithScripts
     )
-import Cardano.Wallet.Util
-    ( internalError )
 import Data.Bifunctor
     ( bimap )
 import Data.Foldable
     ( toList )
 import Data.Map.Strict
     ( Map )
 import Data.Quantity
-    ( Percentage, Quantity (..), mkPercentage )
+    ( Quantity (..) )
 import Data.Word
     ( Word16, Word32, Word64 )
-import Fmt
-    ( (+||), (||+) )
-import GHC.Stack
-    ( HasCallStack )
 
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Api.Shelley as Cardano
 import qualified Cardano.Ledger.Address as SL
 import qualified Cardano.Ledger.BaseTypes as SL
 import qualified Cardano.Ledger.Core as SL.Core
-import qualified Cardano.Ledger.Credential as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import qualified Cardano.Ledger.Shelley.API as SLAPI
 import qualified Cardano.Wallet.Primitive.Types as W
@@ -83,9 +67,7 @@ import qualified Cardano.Wallet.Primitive.Types.Coin as W
 import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
-import Cardano.Wallet.Read.Eras
 import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
 import qualified Ouroboros.Network.Block as O
 
 fromShelleyTxIn
@@ -156,15 +138,14 @@ fromShelleyTx tx =
         , scriptValidity =
             Nothing
         }
-    , map fromShelleyCert (toList certs)
+    , anyEraCerts certs
     , emptyTokenMapWithScripts
     , emptyTokenMapWithScripts
     , Just (ValidityIntervalExplicit (Quantity 0) (Quantity ttl))
     )
   where
     SL.Tx (SL.TxBody ins outs certs wdrls fee (O.SlotNo ttl) _ _) _ mmd = tx
 
-
 fromShelleyWdrl :: SL.Wdrl crypto -> Map W.RewardAccount W.Coin
 fromShelleyWdrl (SL.Wdrl wdrl) = Map.fromList $
     bimap (fromStakeCredential . SL.getRwdCred) fromShelleyCoin
@@ -174,72 +155,4 @@ fromShelleyMD :: SL.Metadata c -> Cardano.TxMetadata
 fromShelleyMD (SL.Metadata m) =
     Cardano.makeTransactionMetadata . fromShelleyMetadata $ m
 
-fromShelleyCert
-    :: SL.DCert crypto
-    -> W.Certificate
-fromShelleyCert = \case
-    SL.DCertDeleg (SL.Delegate delegation)  ->
-        W.CertificateOfDelegation $ W.CertDelegateFull
-            (fromStakeCredential (SL._delegator delegation))
-            (fromPoolKeyHash (SL._delegatee delegation))
-
-    SL.DCertDeleg (SL.DeRegKey credentials) ->
-        W.CertificateOfDelegation $ W.CertDelegateNone (fromStakeCredential credentials)
-
-    SL.DCertDeleg (SL.RegKey cred) ->
-        W.CertificateOfDelegation $ W.CertRegisterKey $ fromStakeCredential cred
-
-    SL.DCertPool (SL.RegPool pp) -> W.CertificateOfPool $ Registration
-        ( W.PoolRegistrationCertificate
-            { W.poolId = fromPoolKeyHash $ SL._poolId pp
-            , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp)
-            , W.poolMargin = fromUnitInterval (SL._poolMargin pp)
-            , W.poolCost = toWalletCoin (SL._poolCost pp)
-            , W.poolPledge = toWalletCoin (SL._poolPledge pp)
-            , W.poolMetadata = fromPoolMetadata <$> strictMaybeToMaybe (SL._poolMD pp)
-            }
-        )
-
-    SL.DCertPool (SL.RetirePool pid (EpochNo e)) ->
-        W.CertificateOfPool $ Retirement $ PoolRetirementCertificate (fromPoolKeyHash pid)
-        (W.EpochNo $ fromIntegral e)
-
-    SL.DCertGenesis{} -> W.CertificateOther W.GenesisCertificate
-
-    SL.DCertMir{}     -> W.CertificateOther W.MIRCertificate
 
-toWalletCoin :: HasCallStack => SL.Coin -> W.Coin
-toWalletCoin (SL.Coin c) = Coin.unsafeFromIntegral 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 'RewardAccount' type.
---
--- Unlike with Jörmungandr, the reward account payload doesn't represent a
--- public key but a HASH of a public key.
---
-fromStakeCredential :: SL.Credential 'SL.Staking crypto -> W.RewardAccount
-fromStakeCredential = \case
-    SL.ScriptHashObj (SL.ScriptHash h) ->
-        W.RewardAccount (hashToBytes h)
-    SL.KeyHashObj (SL.KeyHash h) ->
-        W.RewardAccount (hashToBytes h)
-
-fromPoolKeyHash :: SL.KeyHash rol sc -> W.PoolId
-fromPoolKeyHash (SL.KeyHash h) =
-    W.PoolId (hashToBytes h)
-
-fromOwnerKeyHash :: SL.KeyHash 'SL.Staking crypto -> W.PoolOwner
-fromOwnerKeyHash (SL.KeyHash h) =
-    W.PoolOwner (hashToBytes h)
-
-fromUnitInterval :: HasCallStack => SL.UnitInterval -> Percentage
-fromUnitInterval x =
-    either bomb id . mkPercentage . toRational . SL.unboundRational $ x
-  where
-    bomb = internalError $
-        "fromUnitInterval: encountered invalid parameter value: "+||x||+""

lib/wallet/src/Cardano/Wallet/Read/Tx/Eras.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Wallet.Read.Tx.Eras
+ ( onTx )
+ where
+
+import Cardano.Wallet.Read.Tx
+    ( Tx (..), TxT )
+
+onTx :: (TxT era -> t) -> Tx era -> t
+onTx f (Tx x) = f x