some better UTXOW errors

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

@@ -105,7 +105,7 @@ newtype BlockTransitionError crypto
   = BlockTransitionError [STS.PredicateFailure (STS.BBODY crypto)]
   deriving (Eq, Generic, Show)
 
-instance NoUnexpectedThunks (BlockTransitionError crypto)
+instance (Crypto crypto) => NoUnexpectedThunks (BlockTransitionError crypto)
 
 -- | Apply the block level ledger transition.
 applyBlockTransition ::

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

@@ -144,6 +144,7 @@ import Shelley.Spec.Ledger.Keys
     KeyHash,
     KeyPair,
     KeyRole (..),
+    VKey,
     asWitness,
     hash,
   )
@@ -191,6 +192,7 @@ import Shelley.Spec.Ledger.TxData
     TxIn (..),
     TxOut (..),
     Wdrl (..),
+    WitVKey (..),
     getRwdCred,
   )
 import Shelley.Spec.Ledger.UTxO
@@ -800,9 +802,13 @@ verifiedWits ::
     DSignable crypto (Hash crypto (TxBody crypto))
   ) =>
   Tx crypto ->
-  Bool
+  Either [VKey 'Witness crypto] ()
 verifiedWits (Tx txbody wits _ _) =
-  all (verifyWitVKey $ hashWithSerialiser toCBOR txbody) wits
+  case failed == mempty of
+    True -> Right ()
+    False -> Left $ fmap (\(WitVKey vk _) -> vk) failed
+  where
+    failed = filter (not . verifyWitVKey (hashWithSerialiser toCBOR txbody)) (Set.toList wits)
 
 -- | Calculate the set of hash keys of the required witnesses for update
 -- proposals.

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

@@ -74,7 +74,7 @@ instance
   initialRules = []
   transitionRules = [bbodyTransition]
 
-instance NoUnexpectedThunks (PredicateFailure (BBODY crypto))
+instance (Crypto crypto) => NoUnexpectedThunks (PredicateFailure (BBODY crypto))
 
 bbodyTransition ::
   forall crypto.

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

@@ -90,7 +90,7 @@ instance
   initialRules = []
   transitionRules = [ledgerTransition]
 
-instance NoUnexpectedThunks (PredicateFailure (LEDGER crypto))
+instance (Crypto crypto) => NoUnexpectedThunks (PredicateFailure (LEDGER crypto))
 
 instance
   (Typeable crypto, Crypto crypto) =>

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

@@ -63,7 +63,7 @@ instance
   initialRules = [pure emptyLedgerState]
   transitionRules = [ledgersTransition]
 
-instance NoUnexpectedThunks (PredicateFailure (LEDGERS crypto))
+instance (Crypto crypto) => NoUnexpectedThunks (PredicateFailure (LEDGERS crypto))
 
 instance
   (Typeable crypto, Crypto crypto) =>

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -30,6 +31,7 @@ import Control.State.Transition
 import qualified Data.Map.Strict as Map
 import qualified Data.Sequence as Seq (filter)
 import qualified Data.Sequence.Strict as StrictSeq
+import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Typeable (Typeable)
 import Data.Word (Word8)
@@ -49,6 +51,7 @@ import Shelley.Spec.Ledger.LedgerState (UTxOState (..), verifiedWits, witsVKeyNe
 import Shelley.Spec.Ledger.MetaData (hashMetaData)
 import Shelley.Spec.Ledger.PParams (_d)
 import Shelley.Spec.Ledger.STS.Utxo
+import Shelley.Spec.Ledger.Serialization (decodeList, decodeSet, encodeFoldable)
 import Shelley.Spec.Ledger.Tx
 import Shelley.Spec.Ledger.TxData
 import Shelley.Spec.Ledger.UTxO
@@ -66,8 +69,8 @@ instance
   type Environment (UTXOW crypto) = UtxoEnv crypto
   type BaseM (UTXOW crypto) = ShelleyBase
   data PredicateFailure (UTXOW crypto)
-    = InvalidWitnessesUTXOW
-    | MissingVKeyWitnessesUTXOW
+    = InvalidWitnessesUTXOW [VKey 'Witness crypto]
+    | MissingVKeyWitnessesUTXOW (Set (KeyHash 'Witness crypto))
     | MissingScriptWitnessesUTXOW
     | ScriptWitnessNotValidatingUTXOW
     | UtxoFailure (PredicateFailure (UTXO crypto))
@@ -79,15 +82,17 @@ instance
   transitionRules = [utxoWitnessed]
   initialRules = [initialLedgerStateUTXOW]
 
-instance NoUnexpectedThunks (PredicateFailure (UTXOW crypto))
+instance (Crypto crypto) => NoUnexpectedThunks (PredicateFailure (UTXOW crypto))
 
 instance
   (Typeable crypto, Crypto crypto) =>
   ToCBOR (PredicateFailure (UTXOW crypto))
   where
   toCBOR = \case
-    InvalidWitnessesUTXOW -> encodeListLen 1 <> toCBOR (0 :: Word8)
-    MissingVKeyWitnessesUTXOW -> encodeListLen 1 <> toCBOR (1 :: Word8)
+    InvalidWitnessesUTXOW wits ->
+      encodeListLen 2 <> toCBOR (0 :: Word8) <> encodeFoldable wits
+    MissingVKeyWitnessesUTXOW missing ->
+      encodeListLen 2 <> toCBOR (1 :: Word8) <> encodeFoldable missing
     MissingScriptWitnessesUTXOW -> encodeListLen 1 <> toCBOR (2 :: Word8)
     ScriptWitnessNotValidatingUTXOW -> encodeListLen 1 <> toCBOR (3 :: Word8)
     (UtxoFailure a) ->
@@ -104,8 +109,14 @@ instance
   fromCBOR = do
     n <- decodeListLen
     decodeWord >>= \case
-      0 -> matchSize "InvalidWitnessesUTXOW" 1 n >> pure InvalidWitnessesUTXOW
-      1 -> matchSize "MissingVKeyWitnessesUTXOW" 1 n >> pure MissingVKeyWitnessesUTXOW
+      0 -> do
+        matchSize "InvalidWitnessesUTXOW" 2 n
+        wits <- decodeList fromCBOR
+        pure $ InvalidWitnessesUTXOW wits
+      1 -> do
+        matchSize "MissingVKeyWitnessesUTXOW" 1 n
+        missing <- decodeSet fromCBOR
+        pure $ MissingVKeyWitnessesUTXOW missing
       2 -> matchSize "MissingScriptWitnessesUTXOW" 1 n >> pure MissingScriptWitnessesUTXOW
       3 ->
         matchSize "ScriptWitnessNotValidatingUTXOW" 1 n
@@ -160,10 +171,14 @@ utxoWitnessed =
         ?! MissingScriptWitnessesUTXOW
 
       -- check VKey witnesses
-      verifiedWits tx ?! InvalidWitnessesUTXOW
+      verifiedWits tx ?!: InvalidWitnessesUTXOW
 
       let needed = witsVKeyNeeded utxo tx genDelegs
-      needed `Set.isSubsetOf` witsKeyHashes ?! MissingVKeyWitnessesUTXOW
+          missingWitnesses = needed `Set.difference` witsKeyHashes
+          haveNeededWitnesses = case missingWitnesses == Set.empty of
+            True -> Right ()
+            False -> Left missingWitnesses
+      haveNeededWitnesses ?!: MissingVKeyWitnessesUTXOW
 
       -- check metadata hash
       case (_mdHash txbody) of

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/NonTraceProperties/Generator.hs

@@ -449,11 +449,11 @@ convertPredicateFailuresToValidationErrors pfs =
   map predicateFailureToValidationError $ foldr (++) [] pfs
 
 predicateFailureToValidationError :: PredicateFailure LEDGER -> ValidationError
-predicateFailureToValidationError (UtxowFailure (MissingVKeyWitnessesUTXOW)) =
+predicateFailureToValidationError (UtxowFailure (MissingVKeyWitnessesUTXOW _)) =
   MissingWitnesses
 predicateFailureToValidationError (UtxowFailure (MissingScriptWitnessesUTXOW)) =
   MissingWitnesses
-predicateFailureToValidationError (UtxowFailure (InvalidWitnessesUTXOW)) =
+predicateFailureToValidationError (UtxowFailure (InvalidWitnessesUTXOW [])) =
   InvalidWitness
 predicateFailureToValidationError (UtxowFailure (UtxoFailure InputSetEmptyUTxO)) =
   InputSetEmpty

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/NonTraceProperties/Validity.hs

@@ -190,9 +190,9 @@ verifiedWits' ::
   Tx crypto ->
   Validity
 verifiedWits' tx =
-  if verifiedWits tx
-    then Valid
-    else Invalid [InvalidWitness]
+  case verifiedWits tx of
+    (Right ()) -> Valid
+    (Left _failures) -> Invalid [InvalidWitness]
 
 -- | Given a ledger state, determine if the UTxO witnesses in a given
 --  transaction are sufficient.

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

@@ -7,8 +7,9 @@ import Control.State.Transition.Extended (TRC (..), applySTS)
 import Control.State.Transition.Trace ((.-), (.->), checkTrace)
 import Data.Either (fromRight, isRight)
 import qualified Data.Map.Strict as Map (empty, singleton)
+import qualified Data.Set as Set
 import Shelley.Spec.Ledger.Credential (pattern ScriptHashObj)
-import Shelley.Spec.Ledger.Keys (asWitness)
+import Shelley.Spec.Ledger.Keys (asWitness, hashKey, vKey)
 import Shelley.Spec.Ledger.STS.Chain (totalAda)
 import Shelley.Spec.Ledger.STS.Utxow (PredicateFailure (..))
 import Shelley.Spec.Ledger.Tx (hashScript)
@@ -334,7 +335,7 @@ testScriptAndSKey =
 
 testScriptAndSKey' :: Assertion
 testScriptAndSKey' =
-  utxoSt' @?= Left [[MissingVKeyWitnessesUTXOW]]
+  utxoSt' @?= Left [[MissingVKeyWitnessesUTXOW wits]]
   where
     utxoSt' =
       applyTxWithScript
@@ -343,6 +344,7 @@ testScriptAndSKey' =
         (Wdrl Map.empty)
         1000
         [asWitness bobPay]
+    wits = Set.singleton $ asWitness $ hashKey $ vKey alicePay
 
 testScriptAndSKey'' :: Assertion
 testScriptAndSKey'' =

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

@@ -261,7 +261,8 @@ testWitnessNotIncluded =
           SNothing
           SNothing
       tx = Tx txbody Set.empty Map.empty SNothing
-   in testInvalidTx [UtxowFailure MissingVKeyWitnessesUTXOW] tx
+      wits = Set.singleton (asWitness $ hashKey $ vKey alicePay)
+   in testInvalidTx [UtxowFailure $ MissingVKeyWitnessesUTXOW wits] tx
 
 testSpendNotOwnedUTxO :: Assertion
 testSpendNotOwnedUTxO =
@@ -277,7 +278,8 @@ testSpendNotOwnedUTxO =
           SNothing
       aliceWit = makeWitnessVKey (hashTxBody txbody) alicePay
       tx = Tx txbody (Set.fromList [aliceWit]) Map.empty SNothing
-   in testInvalidTx [UtxowFailure MissingVKeyWitnessesUTXOW] tx
+      wits = Set.singleton (asWitness $ hashKey $ vKey bobPay)
+   in testInvalidTx [UtxowFailure $ MissingVKeyWitnessesUTXOW wits] tx
 
 testWitnessWrongUTxO :: Assertion
 testWitnessWrongUTxO =
@@ -303,9 +305,10 @@ testWitnessWrongUTxO =
           SNothing
       aliceWit = makeWitnessVKey (hashTxBody tx2body) alicePay
       tx = Tx txbody (Set.fromList [aliceWit]) Map.empty SNothing
+      wits = Set.singleton (asWitness $ hashKey $ vKey bobPay)
    in testInvalidTx
-        [ UtxowFailure InvalidWitnessesUTXOW,
-          UtxowFailure MissingVKeyWitnessesUTXOW
+        [ UtxowFailure $ InvalidWitnessesUTXOW [asWitness $ vKey alicePay],
+          UtxowFailure $ MissingVKeyWitnessesUTXOW wits
         ]
         tx
 
@@ -384,7 +387,7 @@ testInvalidWintess =
       txb' = txb {_ttl = SlotNo 2}
       wits = makeWitnessesVKey (hashTxBody txb') [alicePay]
       tx = Tx txb wits Map.empty SNothing
-      errs = [UtxowFailure InvalidWitnessesUTXOW]
+      errs = [UtxowFailure $ InvalidWitnessesUTXOW [asWitness $ vKey alicePay]]
    in testLEDGER (utxoState, dpState) tx ledgerEnv (Left [errs])
 
 testWithdrawalNoWit :: Assertion
@@ -405,7 +408,8 @@ testWithdrawalNoWit =
           SNothing
       wits = Set.singleton $ makeWitnessVKey (hashTxBody txb) alicePay
       tx = Tx txb wits Map.empty SNothing
-      errs = [UtxowFailure MissingVKeyWitnessesUTXOW]
+      missing = Set.singleton (asWitness $ hashKey $ vKey bobStake)
+      errs = [UtxowFailure $ MissingVKeyWitnessesUTXOW missing]
       dpState' = addReward dpState (mkVKeyRwdAcnt bobStake) (Coin 10)
    in testLEDGER (utxoState, dpState') tx ledgerEnv (Left [errs])