Fix WitVKey instance for Ord

alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs

@@ -54,6 +54,7 @@ import Cardano.Ledger.Serialization
 import Control.Monad (unless)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as BSL
+import Data.ByteString.Short (fromShort)
 import Data.Coders
   ( decodeList,
     decodeMap,
@@ -180,16 +181,18 @@ hashTxSeq ::
   Hash (Crypto era) EraIndependentBlockBody
 hashTxSeq (TxSeq' _ bodies ws md vs) =
   coerce $
-    hashStrict
-      ( hashPart bodies
-          <> hashPart ws
-          <> hashPart md
-          <> hashPart vs
-      )
+    hashStrict $
+      fromShort $
+        mconcat
+          [ hashPart bodies,
+            hashPart ws,
+            hashPart md,
+            hashPart vs
+          ]
   where
     hashStrict :: ByteString -> Hash (Crypto era) ByteString
     hashStrict = Hash.hashWith id
-    hashPart = Hash.hashToBytes . hashStrict . BSL.toStrict
+    hashPart = Hash.hashToBytesShort . hashStrict . BSL.toStrict
 
 instance
   ( FromCBOR (Annotator (Core.AuxiliaryData era)),

alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs

@@ -37,7 +37,6 @@ import Cardano.Ledger.Alonzo.TxWitness
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..))
 import Cardano.Ledger.Hashes (ScriptHash)
-import Cardano.Ledger.SafeHash (HasAlgorithm, SafeHash, unsafeMakeSafeHash)
 import Cardano.Ledger.Shelley.Constraints (UsesScript, UsesValue)
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -129,9 +128,6 @@ genScripts = keyBy (hashScript @era) <$> (arbitrary :: Gen [Core.Script era])
 genData :: forall era. Era era => Gen (TxDats era)
 genData = TxDats <$> keyBy hashData <$> arbitrary
 
-instance HasAlgorithm c => Arbitrary (SafeHash c i) where
-  arbitrary = unsafeMakeSafeHash <$> arbitrary
-
 instance
   ( Era era,
     UsesValue era,

cardano-ledger-core/src/Cardano/Ledger/Keys.hs

@@ -29,6 +29,7 @@ module Cardano.Ledger.Keys
     KeyPair (..),
     signedDSIGN,
     verifySignedDSIGN,
+    hashSignature,
 
     -- * Key hashes
     KeyHash (..),
@@ -216,6 +217,13 @@ verifySignedDSIGN ::
 verifySignedDSIGN (VKey vk) vd sigDSIGN =
   either (const False) (const True) $ DSIGN.verifySignedDSIGN () vk vd sigDSIGN
 
+-- | Hash a given signature
+hashSignature ::
+  (Crypto crypto) =>
+  SignedDSIGN crypto (Hash crypto h) ->
+  Hash crypto (SignedDSIGN crypto (Hash crypto h))
+hashSignature = Hash.hashWith (DSIGN.rawSerialiseSigDSIGN . coerce)
+
 --------------------------------------------------------------------------------
 -- Key Hashes
 --------------------------------------------------------------------------------

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs

@@ -128,6 +128,7 @@ import Cardano.Ledger.Keys
     decodeSignedDSIGN,
     encodeSignedDSIGN,
     hashKey,
+    hashSignature,
   )
 import Cardano.Ledger.SafeHash
   ( HashAnnotated,
@@ -952,28 +953,24 @@ pattern WitVKey k s <-
           hash = asWitness $ hashKey k
        in WitVKey' k s hash bytes
 
-{-
--- | Compute an era-independent transaction body hash
-eraIndTxBodyHash ::
-  forall era.
-  Era era =>
-  TxBody era ->
-  SafeHash (Crypto era) EraIndependentTxBody
-eraIndTxBodyHash x = hashAnnotated x
--}
-
 {-# COMPLETE WitVKey #-}
 
 witKeyHash ::
   WitVKey kr crypto ->
   KeyHash 'Witness crypto
 witKeyHash (WitVKey' _ _ kh _) = kh
 
-instance
-  (Typeable kr, CC.Crypto crypto) =>
-  Ord (WitVKey kr crypto)
-  where
-  compare = comparing wvkKeyHash
+instance (Typeable kr, CC.Crypto crypto) => Ord (WitVKey kr crypto) where
+  compare x y =
+    -- It is advised against comparison on keys and signatures directly,
+    -- therefore we use hashes of verification keys and signatures for
+    -- implementing this Ord instance. Note that we do not need to memoize the
+    -- hash of a signature, like it is done with the hash of a key, because Ord
+    -- instance is only used for Sets of WitVKeys and it would be a mistake to
+    -- have two WitVKeys in a same Set for different transactions. Therefore
+    -- comparison on signatures is unlikely to happen and is only needed for
+    -- compliance with Ord laws.
+    comparing wvkKeyHash x y <> comparing (hashSignature @crypto . wvkSig') x y
 
 newtype StakeCreds crypto = StakeCreds
   { unStakeCreds :: Map (Credential 'Staking crypto) SlotNo

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs

@@ -161,7 +161,7 @@ showBalance
 -- need to be discarded. In that case we try to compute a Delta, that when
 -- added (applyDelta) to the transaction, repairs it. The repair is made
 -- by adding additional inputs from which more Ada can flow into the fee.
--- If that doesn't fix it, we add add more inputs to the Delta.
+-- If that doesn't fix it, we add more inputs to the Delta.
 -- Experience shows that this converges quite quickly (in traces we never saw
 -- more than 3 iterations).
 

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs

@@ -167,8 +167,8 @@ genHash = mkDummyHash <$> arbitrary
 mkDummyHash :: forall h a. HashAlgorithm h => Int -> Hash.Hash h a
 mkDummyHash = coerce . hashWithSerialiser @h toCBOR
 
-genSafeHash :: HasAlgorithm c => Gen (SafeHash c i)
-genSafeHash = unsafeMakeSafeHash <$> arbitrary
+instance HasAlgorithm c => Arbitrary (SafeHash c i) where
+  arbitrary = unsafeMakeSafeHash <$> arbitrary
 
 {-------------------------------------------------------------------------------
   Generators
@@ -259,17 +259,14 @@ sizedMetadatum 0 =
       MD.S <$> (T.pack <$> arbitrary)
     ]
 sizedMetadatum n =
-  oneof
-    [ MD.Map
-        <$> ( zip
-                <$> (resize maxMetadatumListLens (listOf (sizedMetadatum (n -1))))
-                <*> (listOf (sizedMetadatum (n -1)))
-            ),
-      MD.List <$> resize maxMetadatumListLens (listOf (sizedMetadatum (n -1))),
-      MD.I <$> arbitrary,
-      MD.B <$> arbitrary,
-      MD.S <$> (T.pack <$> arbitrary)
-    ]
+  let xsGen = listOf (sizedMetadatum (n - 1))
+   in oneof
+        [ MD.Map <$> (zip <$> resize maxMetadatumListLens xsGen <*> xsGen),
+          MD.List <$> resize maxMetadatumListLens xsGen,
+          MD.I <$> arbitrary,
+          MD.B <$> arbitrary,
+          MD.S <$> (T.pack <$> arbitrary)
+        ]
 
 instance Arbitrary MD.Metadatum where
   arbitrary = sizedMetadatum maxMetadatumDepth
@@ -281,12 +278,12 @@ maxTxWits :: Int
 maxTxWits = 5
 
 instance CC.Crypto crypto => Arbitrary (TxId crypto) where
-  arbitrary = TxId <$> genSafeHash
+  arbitrary = TxId <$> arbitrary
 
 instance CC.Crypto crypto => Arbitrary (TxIn crypto) where
   arbitrary =
     TxIn
-      <$> (TxId <$> genSafeHash)
+      <$> (TxId <$> arbitrary)
       <*> arbitrary
 
 instance
@@ -407,7 +404,7 @@ instance CC.Crypto crypto => Arbitrary (ScriptHash crypto) where
   arbitrary = ScriptHash <$> genHash
 
 instance CC.Crypto crypto => Arbitrary (AuxiliaryDataHash crypto) where
-  arbitrary = AuxiliaryDataHash <$> genSafeHash
+  arbitrary = AuxiliaryDataHash <$> arbitrary
 
 instance HashAlgorithm h => Arbitrary (Hash.Hash h a) where
   arbitrary = genHash

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs

@@ -132,6 +132,7 @@ import Shelley.Spec.Ledger.BlockChain (BHBody (..), Block, TxSeq, bhbody, bheade
 import Shelley.Spec.Ledger.OCert (KESPeriod (..))
 import Shelley.Spec.Ledger.PParams (PParamsUpdate)
 import Shelley.Spec.Ledger.Tx (Tx, TxOut, WitnessSet)
+import Test.QuickCheck (Arbitrary (..))
 import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock)
 import Test.Tasty.HUnit
   ( Assertion,
@@ -179,6 +180,10 @@ type GenesisKeyPair crypto = KeyPair 'Genesis crypto
 data RawSeed = RawSeed !Word64 !Word64 !Word64 !Word64 !Word64
   deriving (Eq, Show)
 
+instance Arbitrary RawSeed where
+  arbitrary =
+    RawSeed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
 instance ToCBOR RawSeed where
   toCBOR (RawSeed w1 w2 w3 w4 w5) = toCBOR (w1, w2, w3, w4, w5)
   encodedSizeExpr size _ = 1 + size (Proxy :: Proxy Word64) * 5

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs

@@ -28,26 +28,30 @@ module Test.Shelley.Spec.Ledger.PropertyTests
 where
 
 import Cardano.Binary (ToCBOR)
-import Cardano.Ledger.BaseTypes
-  ( StrictMaybe (..),
-  )
+import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Crypto)
-import Cardano.Ledger.Keys (KeyRole (Witness))
+import qualified Cardano.Ledger.Crypto as CC (Crypto)
+import Cardano.Ledger.Era (Era (Crypto))
+import Cardano.Ledger.Hashes (EraIndependentTxBody)
+import Cardano.Ledger.Keys (DSignable, Hash, KeyRole (Witness))
+import Cardano.Ledger.SafeHash (SafeHash)
 import Cardano.Ledger.Shelley.Constraints (TransValue)
 import Control.State.Transition
 import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC
+import Data.List (nub, sort)
 import Data.Map (Map)
 import Data.Sequence (Seq)
 import Data.Sequence.Strict (StrictSeq)
-import Data.Set (Set)
+import Data.Set as Set (Set, fromList, singleton)
 import GHC.Records (HasField (..))
 import Shelley.Spec.Ledger.API (CHAIN, DPState, DelegsEnv, PPUPState, UTxOState, UtxoEnv)
 import Shelley.Spec.Ledger.Delegation.Certificates (DCert)
 import Shelley.Spec.Ledger.PParams (Update (..))
 import Shelley.Spec.Ledger.STS.Ledger (LEDGER)
 import Shelley.Spec.Ledger.Scripts (ScriptHash)
 import Shelley.Spec.Ledger.TxBody (TxIn, Wdrl, WitVKey)
+import Shelley.Spec.Ledger.UTxO (makeWitnessVKey)
+import Test.QuickCheck (conjoin, (===), (==>))
 import Test.Shelley.Spec.Ledger.Address.Bootstrap
   ( bootstrapHashTest,
   )
@@ -73,13 +77,31 @@ import Test.Shelley.Spec.Ledger.Rules.TestChain
     poolProperties,
     removedAfterPoolreap,
   )
+import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators ()
 import Test.Shelley.Spec.Ledger.ShelleyTranslation (testGroupShelleyTranslation)
-import Test.Shelley.Spec.Ledger.Utils (ChainProperty)
+import Test.Shelley.Spec.Ledger.Utils (ChainProperty, RawSeed, mkKeyPair')
 import Test.Tasty (TestTree, localOption, testGroup)
 import qualified Test.Tasty.QuickCheck as TQC
 
 -- =====================================================================
 
+propWitVKeys ::
+  forall c.
+  (CC.Crypto c, DSignable c (Hash c EraIndependentTxBody)) =>
+  RawSeed ->
+  SafeHash c EraIndependentTxBody ->
+  SafeHash c EraIndependentTxBody ->
+  TQC.Property
+propWitVKeys seed h1 h2 =
+  let kp = mkKeyPair' seed
+      w1 = makeWitnessVKey h1 kp
+      w2 = makeWitnessVKey h2 kp
+   in conjoin
+        [ sort [w1, w2] === sort [w2, w1],
+          length (nub [w1, w2]) === length (Set.fromList [w1, w2]),
+          w1 /= w2 ==> length (Set.singleton w1 <> Set.singleton w2) === 2
+        ]
+
 minimalPropertyTests ::
   forall era.
   ( EraGen era,
@@ -116,7 +138,9 @@ minimalPropertyTests =
           TQC.testProperty "determining address type doesn't force contents" (propDecompactAddrLazy @(Crypto era)),
           TQC.testProperty "reading the keyhash doesn't force the stake reference" (propDecompactShelleyLazyAddr @(Crypto era)),
           TQC.testProperty "isBootstrapRedeemer is equivalent for CompactAddr and Addr" (propIsBootstrapRedeemer @(Crypto era))
-        ]
+        ],
+      TQC.testProperty "WitVKey does not brake containers due to invalid Ord" $
+        propWitVKeys @(Crypto era)
     ]
 
 -- | 'TestTree' of property-based testing properties.