Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

[CDEC-403] Remove partial field accessors from HandlerSpec, InductiveValidationError, InvariantViolation and ValidationResult data types. #3263

Merged
merged 4 commits into from
Jul 19, 2018
Merged

[CDEC-403] Remove partial field accessors from HandlerSpec, InductiveValidationError, InvariantViolation and ValidationResult data types. #3263

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
bc74648
[CDEC-403] Remove partial record accessors from `HandlerSpec`
Jimbo4350 Jul 16, 2018
7365eb2
[CDEC-403] Remove partial field accessors from `InductiveValidationEr…
Jimbo4350 Jul 16, 2018
9fa122b
[CDEC-403] Remove partial field accessors from `InvariantViolation`
Jimbo4350 Jul 16, 2018
0d5b014
[CDEC-403] Remove partial field accessors from `ValidationResult`
Jimbo4350 Jul 17, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions infra/src/Pos/Infra/Communication/Types/Protocol.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We don't seem to have golden/bitripping tests for HandlerSpec. At least not in the infra package.

We need that before we go changing things.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Will do, I'll create a ticket.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Tests created in #3268 and merged. Rebased [CDEC-403] onto develop with golden and bitripping tests still passing.

Expand Down
36 changes: 21 additions & 15 deletions wallet-new/test/unit/Test/Spec/Translation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
--
Expand All @@ -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
--
Expand Down Expand Up @@ -357,23 +357,29 @@ 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
% "}"
)
validationErrorDsl
validationErrorCardano
build ExpectedInvalid'{..} = bprint
build (ExpectedInvalid'
validationErrorDsl
validationErrorInt) = bprint
( "ExpectedInvalid'"
% ", errorDsl: " % build
% ", errorInt: " % build
% "}"
)
validationErrorDsl
validationErrorInt
build Disagreement{..} = bprint
build (Disagreement
validationLedger
validationDisagreement) = bprint
( "Disagreement "
% "{ ledger: " % build
% ", disagreement: " % build
Expand Down
64 changes: 22 additions & 42 deletions wallet-new/test/unit/Wallet/Inductive/Invariants.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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]
Expand All @@ -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
Expand Down Expand Up @@ -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]
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
119 changes: 62 additions & 57 deletions wallet-new/test/unit/Wallet/Inductive/Validation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -201,15 +193,21 @@ inductiveIsValid Inductive{..} = do
-------------------------------------------------------------------------------}

instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) where
build InductiveInvalidBoot{..} = bprint
build (InductiveInvalidBoot
inductiveInvalidBoot
inductiveInvalidError) = bprint
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

👍 for removing uses of RecordWildcards. Maybe at some point we can go through and drop it from default-extensions / drop all uses.

( "InductiveInvalidBoot"
% "{ boot: " % build
% ", error: " % build
% "}"
)
inductiveInvalidBoot
inductiveInvalidError
build InductiveInvalidApplyBlock{..} = bprint
build (InductiveInvalidApplyBlock
inductiveInvalidEvents
inductiveInvalidBlockPrefix
inductiveInvalidTransaction
inductiveInvalidError) = bprint
( "InductiveInvalidApplyBlock"
% "{ events: " % build
% ", blockPrefix: " % build
Expand All @@ -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
Expand All @@ -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
Expand Down