Skip to content

Commit b5ee8da

Browse files
Soupstrawlehins
Soupstraw
and
lehins
committed
Addressed review comments
Fixed native script nonemptyness check Co-authored-by: Alexey Kuleshevich <alexey.kuleshevich@iohk.io>
1 parent 66b9794 commit b5ee8da

File tree

5 files changed

+89
-85
lines changed

5 files changed

+89
-85
lines changed

‎eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs‎

Lines changed: 72 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -119,6 +119,7 @@ import Cardano.Ledger.Shelley.TxWits (
119119
import Control.DeepSeq (NFData)
120120
import Control.Monad (when, (>=>))
121121
import Control.Monad.Trans.Fail (runFail)
122+
import Data.Coerce (coerce)
122123
import qualified Data.List.NonEmpty as NE
123124
import Data.Map.Strict (Map)
124125
import qualified Data.Map.Strict as Map
@@ -309,16 +310,46 @@ unTxDatsL :: forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
309310
unTxDatsL f = fmap TxDats . f . unTxDats
310311
{-# INLINE unTxDatsL #-}
311312

313+
-- | Decodes a set of `a`'s and maps a function over it to get key-value pairs.
314+
-- If the key-value pairs create a non-empty Map without duplicates, then that map is returned,
315+
-- otherwise fail
316+
noDuplicateNonEmptySetAsMapDecoderAnn ::
317+
(Ord k, DecCBOR (Annotator a)) =>
318+
(a -> (k, v)) ->
319+
Decoder s (Annotator (Map k v))
320+
noDuplicateNonEmptySetAsMapDecoderAnn toKV = do
321+
allowTag setTag
322+
vals <- decodeList decCBOR
323+
pure $ go (Map.empty, 0) vals
324+
where
325+
go (m, n) []
326+
| Map.null m = fail "Empty script Set is not allowed"
327+
| length m /= n = fail "Duplicate elements in the scripts Set were encountered"
328+
| otherwise = pure m
329+
go (!m, !n) (x : xs) = do
330+
(k, v) <- toKV <$> x
331+
go (Map.insert k v m, n + 1) xs
332+
{-# INLINE noDuplicateNonEmptySetAsMapDecoderAnn #-}
333+
312334
instance Era era => DecCBOR (Annotator (TxDatsRaw era)) where
313335
decCBOR =
314336
ifDecoderVersionAtLeast
315337
(natVersion @9)
316-
( allowTag setTag
317-
>> mapTraverseableDecoderA
318-
(decodeNonEmptyList decCBOR)
319-
(TxDatsRaw . Map.fromElems hashData . NE.toList)
338+
( ifDecoderVersionAtLeast
339+
(natVersion @12)
340+
noDuplicatesDatsDecoder
341+
( allowTag setTag
342+
>> mapTraverseableDecoderA
343+
(decodeNonEmptyList decCBOR)
344+
(TxDatsRaw . Map.fromElems hashData . NE.toList)
345+
)
320346
)
321347
(mapTraverseableDecoderA (decodeList decCBOR) (TxDatsRaw . Map.fromElems hashData))
348+
where
349+
noDuplicatesDatsDecoder :: Decoder s (Annotator (TxDatsRaw era))
350+
noDuplicatesDatsDecoder =
351+
coerce . noDuplicateNonEmptySetAsMapDecoderAnn $ \dat -> (hashData dat, dat)
352+
{-# INLINE noDuplicatesDatsDecoder #-}
322353
{-# INLINE decCBOR #-}
323354

324355
-- | Note that 'TxDats' are based on 'MemoBytes' since we must preserve
@@ -580,14 +611,22 @@ instance
580611
txWitnessField
581612
[]
582613
where
583-
setDecoder :: (Ord a, DecCBOR a) => Decoder s (Annotator (Set a))
584-
setDecoder =
585-
pure
586-
<$> ifDecoderVersionAtLeast
587-
(natVersion @12)
588-
(decodeSetLikeEnforceNoDuplicates Set.insert (\s -> (length s, s)) decCBOR)
589-
(allowTag setTag >> Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR)
590-
{-# INLINE setDecoder #-}
614+
addrWitsSetDecoder :: (Ord a, DecCBOR a) => Decoder s (Annotator (Set a))
615+
addrWitsSetDecoder =
616+
pure <$> do
617+
let
618+
nonEmptyDecoder = do
619+
allowTag setTag
620+
Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR
621+
nonEmptyNoDuplicatesDecoder = do
622+
s <- decodeSetLikeEnforceNoDuplicates Set.insert (\s -> (length s, s)) decCBOR
623+
when (Set.null s) $ fail "Set cannot be empty"
624+
pure s
625+
ifDecoderVersionAtLeast
626+
(natVersion @9)
627+
(ifDecoderVersionAtLeast (natVersion @12) nonEmptyNoDuplicatesDecoder nonEmptyDecoder)
628+
(Set.fromList <$> decodeList decCBOR)
629+
{-# INLINE addrWitsSetDecoder #-}
591630

592631
txWitnessField :: Word -> Field (Annotator (AlonzoTxWitsRaw era))
593632
txWitnessField 0 =
@@ -596,77 +635,48 @@ instance
596635
( D $
597636
ifDecoderVersionAtLeast
598637
(natVersion @9)
599-
setDecoder
638+
addrWitsSetDecoder
600639
(mapTraverseableDecoderA (decodeList decCBOR) Set.fromList)
601640
)
602641
txWitnessField 1 =
603-
fieldAA addScriptsTxWitsRaw (D scriptsDecoder)
642+
fieldAA addScriptsTxWitsRaw (D nativeScriptsDecoder)
604643
txWitnessField 2 =
605644
fieldAA
606645
(\x wits -> wits {atwrBootAddrTxWits = x})
607646
( D $
608647
ifDecoderVersionAtLeast
609648
(natVersion @9)
610-
setDecoder
649+
addrWitsSetDecoder
611650
(mapTraverseableDecoderA (decodeList decCBOR) Set.fromList)
612651
)
613652
txWitnessField 3 = fieldA addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV1)
614-
txWitnessField 4 =
615-
fieldAA
616-
(\x wits -> wits {atwrDatsTxWits = x})
617-
( D $
618-
ifDecoderVersionAtLeast
619-
(natVersion @12)
620-
noDuplicatesDatsDecoder
621-
decCBOR
622-
)
653+
txWitnessField 4 = fieldAA (\x wits -> wits {atwrDatsTxWits = x}) From
623654
txWitnessField 5 = fieldAA (\x wits -> wits {atwrRdmrsTxWits = x}) From
624655
txWitnessField 6 = fieldA addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV2)
625656
txWitnessField 7 = fieldA addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV3)
626657
txWitnessField n = invalidField n
627658
{-# INLINE txWitnessField #-}
628659

629-
pairDecoder :: Decoder s (Annotator (ScriptHash, Script era))
630-
pairDecoder = fmap (asHashedScriptPair @era . fromNativeScript) <$> decCBOR
631-
{-# INLINE pairDecoder #-}
632-
633-
noDuplicatesDatsDecoder :: Decoder s (Annotator (TxDats era))
634-
noDuplicatesDatsDecoder = do
635-
allowTag setTag
636-
dats <- decodeList decCBOR
637-
pure $ TxDats <$> go Map.empty dats
638-
where
639-
go m [] = pure m
640-
go m (x : xs) = do
641-
x' <- x
642-
let dh = hashData x'
643-
if dh `Map.member` m
644-
then fail $ "Duplicate dats found: " <> show dh
645-
else go (Map.insert dh x' m) xs
646-
{-# INLINE noDuplicatesDatsDecoder #-}
660+
hashedNativeSciptDecoder :: Decoder s (Annotator (ScriptHash, Script era))
661+
hashedNativeSciptDecoder = fmap (asHashedScriptPair @era . fromNativeScript) <$> decCBOR
662+
{-# INLINE hashedNativeSciptDecoder #-}
663+
664+
noDuplicateNativeScriptsDecoder :: Decoder s (Annotator (Map ScriptHash (Script era)))
665+
noDuplicateNativeScriptsDecoder =
666+
noDuplicateNonEmptySetAsMapDecoderAnn
667+
(\ns -> (hashScript $ fromNativeScript ns, fromNativeScript ns))
668+
{-# INLINE noDuplicateNativeScriptsDecoder #-}
647669

648-
noDuplicatesScriptsDecoder :: Decoder s (Annotator (Map ScriptHash (Script era)))
649-
noDuplicatesScriptsDecoder = do
650-
allowTag setTag
651-
scripts <- decodeList $ fmap (fromNativeScript @era) <$> decCBOR
652-
pure $ go Map.empty scripts
653-
where
654-
go m [] = pure m
655-
go m (x : xs) = do
656-
x' <- x
657-
let sh = hashScript x'
658-
if sh `Map.member` m
659-
then fail $ "Duplicate scripts found: " <> show sh
660-
else go (Map.insert sh x' m) xs
661-
{-# INLINE noDuplicatesScriptsDecoder #-}
662-
663-
scriptsDecoder :: Decoder s (Annotator (Map ScriptHash (Script era)))
664-
scriptsDecoder =
670+
nativeScriptsDecoder :: Decoder s (Annotator (Map ScriptHash (Script era)))
671+
nativeScriptsDecoder =
665672
ifDecoderVersionAtLeast
666673
(natVersion @12)
667-
noDuplicatesScriptsDecoder
668-
(allowTag setTag >> mapTraverseableDecoderA (decodeList pairDecoder) Map.fromList)
669-
{-# INLINE scriptsDecoder #-}
674+
noDuplicateNativeScriptsDecoder
675+
( do
676+
allowTag setTag
677+
mapTraverseableDecoderA (decodeNonEmptyList hashedNativeSciptDecoder) (Map.fromList . NE.toList)
678+
)
679+
{-# INLINE nativeScriptsDecoder #-}
670680
{-# INLINE decCBOR #-}
671681

672682
deriving via

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs‎

Lines changed: 10 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -155,11 +155,15 @@ instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoTxW
155155
where
156156
setDecoder :: (Ord a, DecCBOR a) => Decoder s (Set a)
157157
setDecoder =
158-
allowTag setTag
159-
>> ifDecoderVersionAtLeast
160-
(natVersion @12)
161-
(decodeSetLikeEnforceNoDuplicates Set.insert (\s -> (length s, s)) decCBOR)
162-
(Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR)
158+
ifDecoderVersionAtLeast
159+
(natVersion @9)
160+
( allowTag setTag
161+
>> ifDecoderVersionAtLeast
162+
(natVersion @12)
163+
(decodeSetLikeEnforceNoDuplicates Set.insert (\s -> (length s, s)) decCBOR)
164+
(Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR)
165+
)
166+
(Set.fromList <$> decodeList decCBOR)
163167
{-# INLINE setDecoder #-}
164168

165169
txWitnessField :: Word -> Field (AlonzoTxWitsRaw era)
@@ -183,20 +187,7 @@ instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoTxW
183187
(Set.fromList <$> decodeList decCBOR)
184188
)
185189
txWitnessField 3 = field addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV1)
186-
txWitnessField 4 =
187-
field
188-
(\x wits -> wits {atwrDatsTxWits = x})
189-
( D $
190-
ifDecoderVersionAtLeast
191-
(natVersion @12)
192-
( TxDats
193-
<$> decodeSetLikeEnforceNoDuplicates
194-
(\x -> Map.insert (hashData x) x)
195-
(\m -> (length m, m))
196-
decCBOR
197-
)
198-
decCBOR
199-
)
190+
txWitnessField 4 = field (\x wits -> wits {atwrDatsTxWits = x}) From
200191
txWitnessField 5 = field (\x wits -> wits {atwrRdmrsTxWits = x}) From
201192
txWitnessField 6 = field addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV2)
202193
txWitnessField 7 = field addScriptsTxWitsRaw (decodeAlonzoPlutusScript SPlutusV3)

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,8 +48,9 @@ emptyFieldsProps = do
4848
where
4949
emptyFieldProp :: Int -> Property
5050
emptyFieldProp k =
51-
property $
52-
expectDeserialiseFailureFromVersion @era
51+
counterexample ("Key: " <> show k)
52+
. property
53+
$ expectDeserialiseFailureFromVersion @era
5354
(natVersion @9)
5455
(emptyEnc k)
5556
"Empty list"

‎eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -117,6 +117,7 @@ spec = do
117117
huddleRoundTripCborSpec @(Datum DijkstraEra) v "datum_option"
118118
-- TODO NoDatum is encoded as an empty bytestring
119119
xdescribe "fix NoDatum" $ huddleRoundTripArbitraryValidate @(Datum DijkstraEra) v "datum_option"
120+
-- TODO enable once CDDL sets no longer generate duplicate elements
120121
xdescribe "fix duplicates in maps" $ do
121122
huddleRoundTripAnnCborSpec @(TxWits DijkstraEra) v "transaction_witness_set"
122123
huddleRoundTripCborSpec @(TxWits DijkstraEra) v "transaction_witness_set"

‎eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Golden.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,7 @@ witsDuplicatePlutus slang =
111111
SPlutusV1 -> 3
112112
SPlutusV2 -> 6
113113
SPlutusV3 -> 7
114+
-- TODO add PlutusV4 support once the CDDL for TxWits is updated to include V4 scripts
114115
l -> error $ "Unsupported plutus version: " <> show l
115116
, Em
116117
[ E $ TkTag 258
@@ -186,7 +187,7 @@ goldenDuplicateNativeScriptsDisallowed =
186187
witsDuplicateNativeScripts
187188
( DecoderErrorCustom
188189
"Annotator"
189-
"Duplicate scripts found: ScriptHash \"d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf\""
190+
"Duplicate elements in the scripts Set were encountered"
190191
)
191192
where
192193
version = eraProtVerLow @era
@@ -218,5 +219,5 @@ goldenDuplicatePlutusDataDisallowed =
218219
witsDuplicatePlutusData
219220
( DecoderErrorCustom
220221
"Annotator"
221-
"Duplicate dats found: SafeHash \"03170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c111314\""
222+
"Duplicate elements in the scripts Set were encountered"
222223
)

0 commit comments

Comments
 (0)