Skip to content

Commit 4da36e3

Browse files
palaspalas
committed
Add anchor hash checks to transaction build 
1 parent 2570f88 commit 4da36e3

File tree

4 files changed

+144
-0
lines changed

4 files changed

+144
-0
lines changed

‎cardano-cli/cardano-cli.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -84,6 +84,7 @@ library
8484
Cardano.CLI.EraBased.Commands.StakePool
8585
Cardano.CLI.EraBased.Commands.TextView
8686
Cardano.CLI.EraBased.Commands.Transaction
87+
Cardano.CLI.EraBased.HashChecking
8788
Cardano.CLI.EraBased.Options.Common
8889
Cardano.CLI.EraBased.Options.Genesis
8990
Cardano.CLI.EraBased.Options.Governance
@@ -207,6 +208,7 @@ library
207208
cardano-crypto-wrapper ^>=1.5.1,
208209
cardano-data >=1.1,
209210
cardano-git-rev ^>=0.2.2,
211+
cardano-ledger-api,
210212
cardano-ping ^>=0.5,
211213
cardano-prelude,
212214
cardano-slotting ^>=0.2.0.0,

‎cardano-cli/src/Cardano/CLI/EraBased/HashChecking.hs‎

Lines changed: 123 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,123 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
3+
module Cardano.CLI.EraBased.HashChecking
4+
( checkCertificateHashes
5+
, checkVotingProcedureHashes
6+
, checkProposalHashes
7+
)
8+
where
9+
10+
import Cardano.Api (Certificate (..), ExceptT, firstExceptT)
11+
import qualified Cardano.Api.Ledger as L
12+
import qualified Cardano.Api.Shelley as Shelley
13+
14+
import Cardano.CLI.Run.Hash (carryHashChecks)
15+
import Cardano.CLI.Types.Common (MustCheckHash (..), PotentiallyCheckedAnchor (..))
16+
import Cardano.CLI.Types.Errors.TxCmdError (TxCmdError (..))
17+
import qualified Cardano.Ledger.Api.Governance as L
18+
19+
import Control.Monad (forM_)
20+
import Control.Monad.Trans.Except.Extra (left)
21+
22+
-- | Check the hash of the anchor data against the hash in the anchor
23+
checkAnchorMetadataHash :: L.Anchor L.StandardCrypto -> ExceptT TxCmdError IO ()
24+
checkAnchorMetadataHash anchor =
25+
firstExceptT (TxCmdHashCheckError $ L.anchorUrl anchor) $
26+
carryHashChecks
27+
( PotentiallyCheckedAnchor
28+
{ pcaMustCheck = CheckHash
29+
, pcaAnchor = anchor
30+
}
31+
)
32+
33+
-- | Find references to anchor data and check the hashes are valid
34+
-- and they match the linked data.
35+
checkCertificateHashes :: Certificate era -> ExceptT TxCmdError IO ()
36+
checkCertificateHashes c =
37+
case c of
38+
ShelleyRelatedCertificate _ shelleyCert ->
39+
case shelleyCert of
40+
L.ShelleyTxCertDelegCert shelleyDelegCert ->
41+
case shelleyDelegCert of
42+
L.ShelleyRegCert _ -> return ()
43+
L.ShelleyUnRegCert _ -> return ()
44+
L.ShelleyDelegCert _ _ -> return ()
45+
L.ShelleyTxCertPool shelleyPoolCert ->
46+
case shelleyPoolCert of
47+
L.RegPool poolParams -> forM_ (L.ppMetadata poolParams) checkPoolMetadataHash
48+
L.RetirePool _ _ -> return ()
49+
L.ShelleyTxCertGenesisDeleg _ -> return ()
50+
L.ShelleyTxCertMir _ -> return ()
51+
ConwayCertificate ceo conwayCert ->
52+
Shelley.conwayEraOnwardsConstraints ceo $
53+
case conwayCert of
54+
L.ConwayTxCertDeleg _ -> return ()
55+
L.ConwayTxCertPool conwayPoolCert ->
56+
case conwayPoolCert of
57+
L.RegPool poolParams -> forM_ (L.ppMetadata poolParams) checkPoolMetadataHash
58+
L.RetirePool _ _ -> return ()
59+
L.ConwayTxCertGov govCert ->
60+
case govCert of
61+
L.ConwayRegDRep _ _ mAnchor -> forM_ mAnchor checkAnchorMetadataHash
62+
L.ConwayUnRegDRep _ _ -> return ()
63+
L.ConwayUpdateDRep _ mAnchor -> forM_ mAnchor checkAnchorMetadataHash
64+
L.ConwayAuthCommitteeHotKey _ _ -> return ()
65+
L.ConwayResignCommitteeColdKey _ mAnchor -> forM_ mAnchor checkAnchorMetadataHash
66+
where
67+
checkPoolMetadataHash :: L.PoolMetadata -> ExceptT TxCmdError IO ()
68+
checkPoolMetadataHash (L.PoolMetadata{L.pmUrl = url, L.pmHash = hashBytes}) = do
69+
let mHash = L.hashFromBytes hashBytes
70+
hash <- maybe (left $ TxCmdPoolMetadataHashError url) return mHash
71+
let safeHash = L.unsafeMakeSafeHash hash
72+
checkAnchorMetadataHash
73+
( L.Anchor
74+
{ L.anchorUrl = url
75+
, L.anchorDataHash = safeHash
76+
}
77+
)
78+
79+
-- | Find references to anchor data in voting procedures and check the hashes are valid
80+
-- and they match the linked data.
81+
checkVotingProcedureHashes
82+
:: Shelley.ShelleyBasedEra era -> Shelley.VotingProcedures era -> ExceptT TxCmdError IO ()
83+
checkVotingProcedureHashes eon (Shelley.VotingProcedures (L.VotingProcedures voterMap)) =
84+
Shelley.shelleyBasedEraConstraints eon $
85+
forM_
86+
voterMap
87+
( \vpMap ->
88+
forM_
89+
vpMap
90+
( \(L.VotingProcedure _ mAnchor) ->
91+
forM_ mAnchor checkAnchorMetadataHash
92+
)
93+
)
94+
95+
-- | Find references to anchor data in proposals and check the hashes are valid
96+
-- and they match the linked data.
97+
checkProposalHashes
98+
:: forall era. Shelley.ShelleyBasedEra era -> Shelley.Proposal era -> ExceptT TxCmdError IO ()
99+
checkProposalHashes
100+
eon
101+
( Shelley.Proposal
102+
( L.ProposalProcedure
103+
{ L.pProcGovAction = govAction
104+
, L.pProcAnchor = anchor
105+
}
106+
)
107+
) =
108+
Shelley.shelleyBasedEraConstraints eon $ do
109+
checkAnchorMetadataHash anchor
110+
checkGovActionHashes govAction
111+
where
112+
checkGovActionHashes
113+
:: L.GovAction (Shelley.ShelleyLedgerEra era) -> ExceptT TxCmdError IO ()
114+
checkGovActionHashes govAction' =
115+
Shelley.shelleyBasedEraConstraints eon $
116+
case govAction' of
117+
L.ParameterChange{} -> return ()
118+
L.HardForkInitiation _ _ -> return ()
119+
L.TreasuryWithdrawals _ _ -> return ()
120+
L.NoConfidence _ -> return ()
121+
L.UpdateCommittee{} -> return ()
122+
L.NewConstitution _ constitution -> checkAnchorMetadataHash $ L.constitutionAnchor constitution
123+
L.InfoAction -> return ()

‎cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,8 @@ import Cardano.Api.Shelley
4343

4444
import qualified Cardano.Binary as CBOR
4545
import qualified Cardano.CLI.EraBased.Commands.Transaction as Cmd
46+
import Cardano.CLI.EraBased.HashChecking (checkCertificateHashes, checkProposalHashes,
47+
checkVotingProcedureHashes)
4648
import Cardano.CLI.EraBased.Run.Genesis.Common (readProtocolParameters)
4749
import Cardano.CLI.EraBased.Run.Query
4850
import Cardano.CLI.Read
@@ -66,6 +68,7 @@ import qualified Data.ByteString.Char8 as BS
6668
import qualified Data.ByteString.Lazy.Char8 as LBS
6769
import Data.Containers.ListUtils (nubOrd)
6870
import Data.Data ((:~:) (..))
71+
import Data.Foldable (forM_)
6972
import qualified Data.Foldable as Foldable
7073
import Data.Function ((&))
7174
import qualified Data.List as List
@@ -162,6 +165,9 @@ runTransactionBuildCmd
162165
)
163166
| (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
164167
]
168+
169+
forM_ certsAndMaybeScriptWits (checkCertificateHashes . fst)
170+
165171
withdrawalsAndMaybeScriptWits <-
166172
firstExceptT TxCmdScriptWitnessError $
167173
readScriptWitnessFilesTuple eon withdrawals
@@ -193,11 +199,15 @@ runTransactionBuildCmd
193199
(\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles))
194200
era'
195201

202+
forM_ votingProceduresAndMaybeScriptWits (checkVotingProcedureHashes eon . fst)
203+
196204
proposals <-
197205
newExceptT $
198206
first TxCmdProposalError
199207
<$> readTxGovernanceActions eon proposalFiles
200208

209+
forM_ proposals (checkProposalHashes eon . fst)
210+
201211
-- the same collateral input can be used for several plutus scripts
202212
let filteredTxinsc = nubOrd txinsc
203213

‎cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,11 +15,13 @@ module Cardano.CLI.Types.Errors.TxCmdError
1515
where
1616

1717
import Cardano.Api
18+
import qualified Cardano.Api.Ledger as L
1819
import Cardano.Api.Shelley
1920

2021
import Cardano.CLI.Read
2122
import Cardano.CLI.Types.Common
2223
import Cardano.CLI.Types.Errors.BootstrapWitnessError
24+
import Cardano.CLI.Types.Errors.HashCmdError (HashCheckError)
2325
import Cardano.CLI.Types.Errors.NodeEraMismatchError
2426
import qualified Cardano.CLI.Types.Errors.NodeEraMismatchError as NEM
2527
import Cardano.CLI.Types.Errors.ProtocolParamsError
@@ -29,6 +31,7 @@ import Cardano.CLI.Types.TxFeature
2931
import qualified Cardano.Prelude as List
3032
import Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
3133

34+
import Control.Exception (displayException)
3235
import Data.Text (Text)
3336

3437
{- HLINT ignore "Use let" -}
@@ -84,6 +87,8 @@ data TxCmdError
8487
| TxCmdProtocolParamsConverstionError ProtocolParametersConversionError
8588
| forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era)
8689
| forall era. TxCmdFeeEstimationError (TxFeeEstimationError era)
90+
| TxCmdPoolMetadataHashError L.Url
91+
| TxCmdHashCheckError L.Url HashCheckError
8792

8893
renderTxCmdError :: TxCmdError -> Doc ann
8994
renderTxCmdError = \case
@@ -217,6 +222,10 @@ renderTxCmdError = \case
217222
prettyError e
218223
TxCmdFeeEstimationError e ->
219224
prettyError e
225+
TxCmdPoolMetadataHashError url ->
226+
"Hash of the pool metadata file is not valid. Url:" <+> pretty (L.urlToText url)
227+
TxCmdHashCheckError url e ->
228+
"Hash of the file is not valid. Url:" <+> pretty (L.urlToText url) <+> pretty (displayException e)
220229

221230
prettyPolicyIdList :: [PolicyId] -> Doc ann
222231
prettyPolicyIdList =

0 commit comments

Comments
 (0)