diff --git a/infra/src/Pos/Infra/Communication/Types/Protocol.hs b/infra/src/Pos/Infra/Communication/Types/Protocol.hs index d11f516c287..c99adb0c458 100644 --- a/infra/src/Pos/Infra/Communication/Types/Protocol.hs +++ b/infra/src/Pos/Infra/Communication/Types/Protocol.hs @@ -186,8 +186,9 @@ buildBS :: ByteString -> B.Builder buildBS = bprint base16F data HandlerSpec - = ConvHandler { hsReplyType :: MessageCode } - | UnknownHandler Word8 ByteString + -- | ConvHandler hsReplyType + = ConvHandler !MessageCode + | UnknownHandler !Word8 !ByteString deriving (Show, Generic, Eq) instance Bi HandlerSpec where diff --git a/wallet-new/test/unit/Test/Spec/Translation.hs b/wallet-new/test/unit/Test/Spec/Translation.hs index e100abc749d..7493b66b786 100644 --- a/wallet-new/test/unit/Test/Spec/Translation.hs +++ b/wallet-new/test/unit/Test/Spec/Translation.hs @@ -292,17 +292,17 @@ data ValidationResult h a = ExpectedValid -- | We expected the chain to be invalid; DSL and Cardano both agree - | ExpectedInvalid { - validationErrorDsl :: Text - , validationErrorCardano :: Cardano.VerifyBlocksException - } + -- ExpectedInvalid + -- validationErrorDsl + -- validationErrorCardano + | ExpectedInvalid !Text !Cardano.VerifyBlocksException -- | Variation on 'ExpectedInvalid', where we cannot even /construct/ -- the Cardano chain, much less validate it. - | ExpectedInvalid' { - validationErrorDsl :: Text - , validationErrorInt :: IntException - } + -- ExpectedInvalid + -- validationErrorDsl + -- validationErrorInt + | ExpectedInvalid' !Text !IntException -- | Disagreement between the DSL and Cardano -- @@ -315,10 +315,10 @@ data ValidationResult h a = -- -- We record the error message from Cardano, if Cardano thought the chain -- was invalid, as well as the ledger that causes the problem. - | Disagreement { - validationLedger :: Ledger h a - , validationDisagreement :: Disagreement h a - } + -- Disagreement + -- validationLedger + -- validationDisagreement + | Disagreement !(Ledger h a) !(Disagreement h a) -- | Disagreement between Cardano and the DSL -- @@ -357,7 +357,9 @@ expectInvalid _otherwise = False instance (Hash h a, Buildable a) => Buildable (ValidationResult h a) where build ExpectedValid = "ExpectedValid" - build ExpectedInvalid{..} = bprint + build (ExpectedInvalid + validationErrorDsl + validationErrorCardano) = bprint ( "ExpectedInvalid" % ", errorDsl: " % build % ", errorCardano: " % build @@ -365,7 +367,9 @@ instance (Hash h a, Buildable a) => Buildable (ValidationResult h a) where ) validationErrorDsl validationErrorCardano - build ExpectedInvalid'{..} = bprint + build (ExpectedInvalid' + validationErrorDsl + validationErrorInt) = bprint ( "ExpectedInvalid'" % ", errorDsl: " % build % ", errorInt: " % build @@ -373,7 +377,9 @@ instance (Hash h a, Buildable a) => Buildable (ValidationResult h a) where ) validationErrorDsl validationErrorInt - build Disagreement{..} = bprint + build (Disagreement + validationLedger + validationDisagreement) = bprint ( "Disagreement " % "{ ledger: " % build % ", disagreement: " % build diff --git a/wallet-new/test/unit/Wallet/Inductive/Invariants.hs b/wallet-new/test/unit/Wallet/Inductive/Invariants.hs index 48303e8b238..efc0721fbee 100644 --- a/wallet-new/test/unit/Wallet/Inductive/Invariants.hs +++ b/wallet-new/test/unit/Wallet/Inductive/Invariants.hs @@ -56,20 +56,12 @@ invariant name e p = void . interpret notChecked ((:[]) . e) p' notChecked :: History h a -> InvalidInput h a -> InvariantViolation h a - notChecked history reason = InvariantNotChecked { - invariantNotCheckedName = name - , invariantNotCheckedReason = reason - , invariantNotCheckedEvents = history - } + notChecked history reason = InvariantNotChecked name reason history violation :: History h a -> InvariantViolationEvidence -> InvariantViolation h a - violation history ev = InvariantViolation { - invariantViolationName = name - , invariantViolationEvidence = ev - , invariantViolationEvents = history - } + violation history ev = InvariantViolation name ev history p' :: History h a -> [Wallet h a] @@ -82,28 +74,18 @@ invariant name e p = void . interpret notChecked ((:[]) . e) p' -- | Invariant violation data InvariantViolation h a = -- | Invariance violation - InvariantViolation { - -- | Name of the invariant - invariantViolationName :: Text - - -- | Evidence that the invariant was violated - , invariantViolationEvidence :: InvariantViolationEvidence - - -- | The evens that led to the error - , invariantViolationEvents :: History h a - } + -- invariantViolationName = Name of the invariant + -- invariantViolationEvidence = Evidence that the invariant + -- was violated + -- invariantViolationEvents = The evennts that led to the error + InvariantViolation !Text !InvariantViolationEvidence !(History h a) -- | The invariant was not checked because the input was invalid - | InvariantNotChecked { - -- | Name of the invariant - invariantNotCheckedName :: Text - - -- | Why did we not check the invariant - , invariantNotCheckedReason :: InvalidInput h a - - -- | The events that led to the error - , invariantNotCheckedEvents :: History h a - } + -- InvariantNotChecked + -- invariantNotCheckedName = Name of the invariant + -- invariantNotCheckedReason = Why did we not check the invariant + -- invariantNotCheckedEvents = The events that led to the error + | InvariantNotChecked !Text !(InvalidInput h a) !(History h a) {------------------------------------------------------------------------------- Evidence that an invariant was violated @@ -288,20 +270,12 @@ walletEquivalent lbl e e' = void . notChecked :: History h a -> InvalidInput h a -> InvariantViolation h a - notChecked history reason = InvariantNotChecked { - invariantNotCheckedName = lbl - , invariantNotCheckedReason = reason - , invariantNotCheckedEvents = history - } + notChecked history reason = InvariantNotChecked lbl reason history violation :: History h a -> InvariantViolationEvidence -> InvariantViolation h a - violation history ev = InvariantViolation { - invariantViolationName = lbl - , invariantViolationEvidence = ev - , invariantViolationEvents = history - } + violation history ev = InvariantViolation lbl ev history p :: History h a -> [Wallet h a] @@ -332,7 +306,10 @@ walletEquivalent lbl e e' = void . -------------------------------------------------------------------------------} instance (Hash h a, Buildable a) => Buildable (InvariantViolation h a) where - build InvariantViolation{..} = bprint + build (InvariantViolation + invariantViolationName + invariantViolationEvidence + invariantViolationEvents) = bprint ( "InvariantViolation " % "{ name: " % build % ", evidence: " % build @@ -342,7 +319,10 @@ instance (Hash h a, Buildable a) => Buildable (InvariantViolation h a) where invariantViolationName invariantViolationEvidence invariantViolationEvents - build (InvariantNotChecked{..}) = bprint + build (InvariantNotChecked + invariantNotCheckedName + invariantNotCheckedReason + invariantNotCheckedEvents) = bprint ( "InvariantNotChecked " % "{ name: " % build % ", reason: " % build diff --git a/wallet-new/test/unit/Wallet/Inductive/Validation.hs b/wallet-new/test/unit/Wallet/Inductive/Validation.hs index 87dc748272d..9f7049ba29a 100644 --- a/wallet-new/test/unit/Wallet/Inductive/Validation.hs +++ b/wallet-new/test/unit/Wallet/Inductive/Validation.hs @@ -45,55 +45,46 @@ data ValidatedInductive h a = ValidatedInductive { data InductiveValidationError h a = -- | Bootstrap transaction is invalid - InductiveInvalidBoot { - -- | The bootstrap transaction - inductiveInvalidBoot :: Transaction h a - - -- | The error message - , inductiveInvalidError :: Text - } + -- InductiveInvalidBoot + -- inductiveInvalidBoot = The bootstrap transaction + -- inductiveInvalidError = The error message + InductiveInvalidBoot !(Transaction h a) !Text -- | Invalid transaction in the given block - | InductiveInvalidApplyBlock { - -- | The events leading up to the error - inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) - - -- | The transactions in the block we successfully validated - , inductiveInvalidBlockPrefix :: OldestFirst [] (Transaction h a) - - -- | The transaction that was invalid - , inductiveInvalidTransaction :: Transaction h a - - -- | The error message - , inductiveInvalidError :: Text - } + -- InductiveInvalidApplyBlock + -- inductiveInvalidEvents = The events leading up to the error + -- inductiveInvalidBlockPrefix = The transactions in the block we + -- successfully validated + -- inductiveInvalidTransaction = The transaction that was invalid + -- inductiveInvalidError = The error message + | InductiveInvalidApplyBlock + !(OldestFirst [] (WalletEvent h a)) + !(OldestFirst [] (Transaction h a)) + !(Transaction h a) + !Text -- | A 'NewPending' call was invalid because the input was already spent - | InductiveInvalidNewPendingAlreadySpent { - -- | The events leading up to the error - inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) - - -- | The transaction that was invalid - , inductiveInvalidTransaction :: Transaction h a - - -- | The specific input that was not valid - , inductiveInvalidInput :: Input h a - } + -- InductiveInvalidNewPendingAlreadySpent + -- inductiveInvalidEvents = The events leading up to the error + -- inductiveInvalidTransaction = The transaction that was invalid + -- inductiveInvalidInput = The specific input that was not valid + | InductiveInvalidNewPendingAlreadySpent + !(OldestFirst [] (WalletEvent h a)) + !(Transaction h a) + !(Input h a) -- | A 'NewPending' call was invalid because the input was not @ours@ - | InductiveInvalidNewPendingNotOurs { - -- | The events leading up to the error - inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) - - -- | The transaction that was invalid - , inductiveInvalidTransaction :: Transaction h a + -- InductiveInvalidNewPendingNotOurs + -- inductiveInvalidEvents = The events leading up to the error + -- inductiveInvalidTransaction = The transaction that was invalid + -- inductiveInvalidInput = The specific input that was not valid + -- inductiveInvalidAddress = The address this input belonged to + | InductiveInvalidNewPendingNotOurs + !(OldestFirst [] (WalletEvent h a)) + !(Transaction h a) + !(Input h a) + !a - -- | The specific input that was not valid - , inductiveInvalidInput :: Input h a - - -- | The address this input belonged to - , inductiveInvalidAddress :: a - } {------------------------------------------------------------------------------- Validation proper @@ -150,19 +141,20 @@ inductiveIsValid Inductive{..} = do forM_ (zip inputs resolved) $ \(input, mAddr) -> case mAddr of Nothing -> - throwError InductiveInvalidNewPendingAlreadySpent { - inductiveInvalidEvents = toOldestFirst viEvents - , inductiveInvalidTransaction = t - , inductiveInvalidInput = input - } + throwError + $ InductiveInvalidNewPendingAlreadySpent + (toOldestFirst viEvents) + t + input Just addr -> unless (addr `Set.member` inductiveOurs) $ - throwError InductiveInvalidNewPendingNotOurs { - inductiveInvalidEvents = toOldestFirst viEvents - , inductiveInvalidTransaction = t - , inductiveInvalidInput = input - , inductiveInvalidAddress = addr - } + throwError + $ InductiveInvalidNewPendingNotOurs + (toOldestFirst viEvents) + t + input + addr + goEvents es vi goBlock :: OldestFirst [] (WalletEvent h a) -- Events leading to this point (for err msgs) @@ -201,7 +193,9 @@ inductiveIsValid Inductive{..} = do -------------------------------------------------------------------------------} instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) where - build InductiveInvalidBoot{..} = bprint + build (InductiveInvalidBoot + inductiveInvalidBoot + inductiveInvalidError) = bprint ( "InductiveInvalidBoot" % "{ boot: " % build % ", error: " % build @@ -209,7 +203,11 @@ instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) whe ) inductiveInvalidBoot inductiveInvalidError - build InductiveInvalidApplyBlock{..} = bprint + build (InductiveInvalidApplyBlock + inductiveInvalidEvents + inductiveInvalidBlockPrefix + inductiveInvalidTransaction + inductiveInvalidError) = bprint ( "InductiveInvalidApplyBlock" % "{ events: " % build % ", blockPrefix: " % build @@ -220,7 +218,10 @@ instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) whe inductiveInvalidBlockPrefix inductiveInvalidTransaction inductiveInvalidError - build InductiveInvalidNewPendingAlreadySpent{..} = bprint + build (InductiveInvalidNewPendingAlreadySpent + inductiveInvalidEvents + inductiveInvalidTransaction + inductiveInvalidInput) = bprint ( "InductiveInvalidNewPendingAlreadySpent" % "{ events: " % build % ", transaction: " % build @@ -230,7 +231,11 @@ instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) whe inductiveInvalidEvents inductiveInvalidTransaction inductiveInvalidInput - build InductiveInvalidNewPendingNotOurs{..} = bprint + build (InductiveInvalidNewPendingNotOurs + inductiveInvalidEvents + inductiveInvalidTransaction + inductiveInvalidInput + inductiveInvalidAddress) = bprint ( "InductiveInvalidNewPendingNotOurs" % "{ events: " % build % ", transaction: " % build