Merge pull request #664 from IntersectMBO/add-anchor-data-extraction

Add function to extract anchor data from certificate
IntersectMBO · Nov 4, 2024 · 5c67a60 · 5c67a60
2 parents 8e5ef56 + 62a42f4
commit 5c67a60
Show file tree

Hide file tree

Showing 3 changed files with 92 additions and 1 deletion.
diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -56,6 +57,10 @@ module Cardano.Api.Certificate
   , Ledger.MIRPot (..)
   , selectStakeCredentialWitness
 
+    -- * Anchor data
+  , AnchorDataFromCertificateError (..)
+  , getAnchorDataFromCertificate
+
     -- * Internal conversion functions
   , toShelleyCertificate
   , fromShelleyCertificate
@@ -77,10 +82,12 @@ import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eon.ShelleyToBabbageEra
 import           Cardano.Api.Eras
+import           Cardano.Api.Error (Error (..))
 import           Cardano.Api.Governance.Actions.VotingProcedure
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Praos
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Pretty (Doc)
 import           Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto)
 import qualified Cardano.Api.ReexposeLedger as Ledger
 import           Cardano.Api.Script
@@ -90,9 +97,11 @@ import           Cardano.Api.StakePoolMetadata
 import           Cardano.Api.Utils (noInlineMaybeToStrictMaybe)
 import           Cardano.Api.Value
 
+import           Cardano.Ledger.BaseTypes (strictMaybe)
 import qualified Cardano.Ledger.Coin as L
 import qualified Cardano.Ledger.Keys as Ledger
 
+import           Control.Monad.Except (MonadError (..))
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import           Data.IP (IPv4, IPv6)
@@ -101,7 +110,7 @@ import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Data.Typeable
-import           GHC.Exts (IsList (..))
+import           GHC.Exts (IsList (..), fromString)
 import           Network.Socket (PortNumber)
 
 -- ----------------------------------------------------------------------------
@@ -724,3 +733,62 @@ fromShelleyPoolParams
     fromShelleyDnsName =
       Text.encodeUtf8
         . Ledger.dnsToText
+
+data AnchorDataFromCertificateError
+  = InvalidPoolMetadataHashError Ledger.Url ByteString
+  deriving (Eq, Show)
+
+instance Error AnchorDataFromCertificateError where
+  prettyError :: AnchorDataFromCertificateError -> Doc ann
+  prettyError (InvalidPoolMetadataHashError url hash) =
+    "Invalid pool metadata hash for URL " <> fromString (show url) <> ": " <> fromString (show hash)
+
+-- | Get anchor data url and hash from a certificate. A return value of `Nothing`
+-- means that the certificate does not contain anchor data.
+getAnchorDataFromCertificate
+  :: Certificate era
+  -> Either AnchorDataFromCertificateError (Maybe (Ledger.Anchor StandardCrypto))
+getAnchorDataFromCertificate c =
+  case c of
+    ShelleyRelatedCertificate stbe scert ->
+      shelleyToBabbageEraConstraints stbe $
+        case scert of
+          Ledger.RegTxCert _ -> return Nothing
+          Ledger.UnRegTxCert _ -> return Nothing
+          Ledger.DelegStakeTxCert _ _ -> return Nothing
+          Ledger.RegPoolTxCert poolParams -> strictMaybe (return Nothing) anchorDataFromPoolMetadata $ Ledger.ppMetadata poolParams
+          Ledger.RetirePoolTxCert _ _ -> return Nothing
+          Ledger.GenesisDelegTxCert{} -> return Nothing
+          Ledger.MirTxCert _ -> return Nothing
+    ConwayCertificate ceo ccert ->
+      conwayEraOnwardsConstraints ceo $
+        case ccert of
+          Ledger.RegTxCert _ -> return Nothing
+          Ledger.UnRegTxCert _ -> return Nothing
+          Ledger.RegDepositTxCert _ _ -> return Nothing
+          Ledger.UnRegDepositTxCert _ _ -> return Nothing
+          Ledger.RegDepositDelegTxCert{} -> return Nothing
+          Ledger.DelegTxCert{} -> return Nothing
+          Ledger.RegPoolTxCert poolParams -> strictMaybe (return Nothing) anchorDataFromPoolMetadata $ Ledger.ppMetadata poolParams
+          Ledger.RetirePoolTxCert _ _ -> return Nothing
+          Ledger.RegDRepTxCert _ _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
+          Ledger.UnRegDRepTxCert _ _ -> return Nothing
+          Ledger.UpdateDRepTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
+          Ledger.AuthCommitteeHotKeyTxCert _ _ -> return Nothing
+          Ledger.ResignCommitteeColdTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
+ where
+  anchorDataFromPoolMetadata
+    :: MonadError AnchorDataFromCertificateError m
+    => Ledger.PoolMetadata
+    -> m (Maybe (Ledger.Anchor StandardCrypto))
+  anchorDataFromPoolMetadata (Ledger.PoolMetadata{Ledger.pmUrl = url, Ledger.pmHash = hashBytes}) = do
+    hash <-
+      maybe (throwError $ InvalidPoolMetadataHashError url hashBytes) return $
+        Ledger.hashFromBytes hashBytes
+    return $
+      Just
+        ( Ledger.Anchor
+            { Ledger.anchorUrl = url
+            , Ledger.anchorDataHash = Ledger.unsafeMakeSafeHash hash
+            }
+        )
diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs
@@ -230,3 +230,19 @@ createAnchor url anchorData =
     { anchorUrl = url
     , anchorDataHash = hashAnchorData $ Ledger.AnchorData anchorData
     }
+
+-- | Get anchor data url and hash from a governance action. A return value of `Nothing`
+-- means that the governance action does not contain anchor data.
+getAnchorDataFromGovernanceAction
+  :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
+  => Gov.GovAction (ShelleyLedgerEra era)
+  -> Maybe (Ledger.Anchor StandardCrypto)
+getAnchorDataFromGovernanceAction govAction =
+  case govAction of
+    Gov.ParameterChange{} -> Nothing
+    Gov.HardForkInitiation _ _ -> Nothing
+    Gov.TreasuryWithdrawals _ _ -> Nothing
+    Gov.NoConfidence _ -> Nothing
+    Gov.UpdateCommittee{} -> Nothing
+    Gov.NewConstitution _ constitution -> Just $ Ledger.constitutionAnchor constitution
+    Gov.InfoAction -> Nothing
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -481,6 +481,10 @@ module Cardano.Api
   , StakePoolRelay
   , StakePoolMetadataReference
 
+    -- ** Anchor data
+  , AnchorDataFromCertificateError (..)
+  , getAnchorDataFromCertificate
+
     -- * Rewards
   , DelegationsAndRewards (..)
   , mergeDelegsAndRewards
@@ -993,6 +997,9 @@ module Cardano.Api
   , DRepMetadataReference
   , hashDRepMetadata
 
+    -- ** Governance actions
+  , getAnchorDataFromGovernanceAction
+
     -- ** Governance related certificates
   , AnchorDataHash (..)
   , AnchorUrl (..)