Skip to content

Commit 0b20fd8

Browse files
ninioArtilleroisovector
ninioArtillero
authored and
isovector
committed
Implement/Derive (de)serialization instances needed for test file (#11)
# Description Closes tweag/cardano-conformance-testing-of-consensus#52 This PR creates a separate module to accommodate the (orphan) instances needed to serialize/deserialize a `GenesisTest` as JSON; we take this approach to avoid spreading changes throughout the codebase during this phase of development. As specified in our design, `conformance-test-runner` consumes a test file that specifies (at least) a `PointSchedule` to run. It turns out our peer simulator would need access to the whole of a `GenesisTest` data, which will contain the `PointSchedule` in particular. In #3, the relevant instances were introduced for the `PointSchedule`alone. All this changes are moved into the aforementioned module.
1 parent 41466f7 commit 0b20fd8

File tree

6 files changed

+159
-43
lines changed

6 files changed

+159
-43
lines changed

‎ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import Ouroboros.Network.PeerSelection.LedgerPeers (RelayAccessPoint (..), UseLe
2323
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..))
2424
import Server (run)
2525
import System.Environment (getArgs)
26+
import Test.Consensus.OrphanInstances ()
2627
import Test.Consensus.PointSchedule (PointSchedule (..))
2728
import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (Peers), getPeerIds)
2829

‎ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -245,6 +245,7 @@ library unstable-consensus-conformance-testlib
245245
Test.Consensus.IOSimQSM.Test.StateMachine.Sequential
246246
Test.Consensus.Network.AnchoredFragment.Extras
247247
Test.Consensus.Node
248+
Test.Consensus.OrphanInstances
248249
Test.Consensus.PeerSimulator.BlockFetch
249250
Test.Consensus.PeerSimulator.CSJInvariants
250251
Test.Consensus.PeerSimulator.ChainSync

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs‎

Lines changed: 155 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE DerivingVia #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE StandaloneDeriving #-}
6+
{-# LANGUAGE UndecidableInstances #-}
7+
{-# OPTIONS_GHC -Wno-orphans #-}
8+
9+
-- | This module contains (orphan) instances to serialize a 'GenesisTest' for
10+
-- the @consensus-test-runner@ input test file.
11+
--
12+
-- Types with 'Generic' instances can derive 'ToJSON' and 'FromJSON'
13+
-- automatically; in turn, to standalone derive a 'Generic' instance, all of
14+
-- its constructors must in scope. Because of this, opaque data type instances
15+
-- need to be written manually.
16+
--
17+
-- Note that most of the constraints in this instance declarations are caused
18+
-- by the abstraction of the block type parameter.
19+
module Test.Consensus.OrphanInstances () where
20+
21+
import Cardano.Slotting.Time (SlotLength)
22+
import Control.Monad.Class.MonadTime.SI (Time)
23+
import Data.Aeson
24+
( FromJSON (parseJSON)
25+
, KeyValue ((.=))
26+
, ToJSON (toEncoding, toJSON)
27+
, defaultOptions
28+
, genericToEncoding
29+
, object
30+
, withObject
31+
, (.:)
32+
)
33+
import GHC.Generics (Generic)
34+
import Ouroboros.Consensus.Block.Abstract (GenesisWindow (..))
35+
import Ouroboros.Consensus.Config (SecurityParam (..))
36+
import Ouroboros.Network.AnchoredFragment (Anchor)
37+
import Ouroboros.Network.AnchoredSeq
38+
( Anchorable (..)
39+
, AnchoredSeq (..)
40+
, fromOldestFirst
41+
, toOldestFirst
42+
)
43+
import Ouroboros.Network.Block (HasHeader, HeaderHash)
44+
import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
45+
import Test.Consensus.PointSchedule
46+
( BlockFetchTimeout (..)
47+
, CSJParams (..)
48+
, ChainSyncTimeout (..)
49+
, ForecastRange (..)
50+
, GenesisTest (..)
51+
, LoPBucketParams (..)
52+
, PointSchedule (..)
53+
)
54+
import Test.Consensus.PointSchedule.Peers (PeerId, Peers (..))
55+
import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
56+
import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (..))
57+
58+
-- * Target instances
59+
60+
deriving instance Generic (GenesisTest blk schedule)
61+
instance
62+
(ToJSON (HeaderHash blk), HasHeader blk, ToJSON schedule, ToJSON blk) =>
63+
ToJSON (GenesisTest blk schedule)
64+
where
65+
toEncoding = genericToEncoding defaultOptions
66+
instance
67+
(FromJSON (HeaderHash blk), HasHeader blk, FromJSON schedule, FromJSON blk) =>
68+
FromJSON (GenesisTest blk schedule)
69+
70+
-- ** 'GenesisTest' field instances
71+
72+
instance ToJSON SecurityParam
73+
instance FromJSON SecurityParam
74+
75+
deriving instance Generic GenesisWindow
76+
instance ToJSON GenesisWindow
77+
instance FromJSON GenesisWindow
78+
79+
deriving instance Generic ForecastRange
80+
instance ToJSON ForecastRange
81+
instance FromJSON ForecastRange
82+
83+
deriving instance Generic Delta
84+
instance ToJSON Delta
85+
instance FromJSON Delta
86+
87+
deriving instance Generic (BlockTree blk)
88+
instance (ToJSON (HeaderHash blk), HasHeader blk, ToJSON blk) => ToJSON (BlockTree blk)
89+
instance (FromJSON (HeaderHash blk), HasHeader blk, FromJSON blk) => FromJSON (BlockTree blk)
90+
91+
deriving instance Generic ChainSyncTimeout
92+
instance ToJSON ChainSyncTimeout
93+
instance FromJSON ChainSyncTimeout
94+
95+
deriving instance Generic BlockFetchTimeout
96+
instance ToJSON BlockFetchTimeout
97+
instance FromJSON BlockFetchTimeout
98+
99+
deriving instance Generic LoPBucketParams
100+
instance ToJSON LoPBucketParams
101+
instance FromJSON LoPBucketParams
102+
103+
deriving instance Generic CSJParams
104+
instance ToJSON CSJParams
105+
instance FromJSON CSJParams
106+
107+
instance ToJSON SlotLength
108+
instance FromJSON SlotLength
109+
110+
deriving instance Generic (PointSchedule blk)
111+
instance ToJSON blk => ToJSON (PointSchedule blk)
112+
instance FromJSON blk => FromJSON (PointSchedule blk)
113+
114+
-- *** 'BlockTree' field related instances
115+
116+
-- | The underlying 'AnchoredFragment' type of a 'BlockTreeBranch' is
117+
-- responsible for the 'HeaderHash' and 'HasHeader' constraints; the former is
118+
-- a type family, which is justifies the need for @UndecidableInstances@ unless
119+
-- a concrete block type is picked.
120+
deriving instance Generic (BlockTreeBranch blk)
121+
122+
instance (ToJSON (HeaderHash blk), HasHeader blk, ToJSON blk) => ToJSON (BlockTreeBranch blk)
123+
instance (FromJSON (HeaderHash blk), HasHeader blk, FromJSON blk) => FromJSON (BlockTreeBranch blk)
124+
125+
instance (ToJSON a, ToJSON b) => ToJSON (AnchoredSeq v a b) where
126+
toJSON anchoredSeq =
127+
object
128+
[ "anchor" .= anchor anchoredSeq
129+
, "sequence" .= toOldestFirst anchoredSeq
130+
]
131+
132+
instance (Anchorable v a b, FromJSON a, FromJSON b) => FromJSON (AnchoredSeq v a b) where
133+
parseJSON = withObject "AnchoredSeq" $ \obj -> do
134+
a <- obj .: "anchor"
135+
s <- obj .: "sequence"
136+
pure $ fromOldestFirst a s
137+
138+
instance ToJSON (HeaderHash blk) => ToJSON (Anchor blk)
139+
instance FromJSON (HeaderHash blk) => FromJSON (Anchor blk)
140+
141+
-- *** 'PointSchedule' field related instances
142+
143+
instance ToJSON Time
144+
instance FromJSON Time
145+
146+
instance ToJSON PeerId
147+
instance FromJSON PeerId
148+
149+
deriving instance Generic (Peers a)
150+
instance ToJSON a => ToJSON (Peers a)
151+
instance FromJSON a => FromJSON (Peers a)
152+
153+
deriving instance Generic (SchedulePoint blk)
154+
instance ToJSON blk => ToJSON (SchedulePoint blk)
155+
instance FromJSON blk => FromJSON (SchedulePoint blk)

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs‎

Lines changed: 0 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DeriveGeneric #-}
32
{-# LANGUAGE DuplicateRecordFields #-}
43
{-# LANGUAGE FlexibleContexts #-}
54
{-# LANGUAGE FlexibleInstances #-}
@@ -8,10 +7,6 @@
87
{-# LANGUAGE OverloadedStrings #-}
98
{-# LANGUAGE RankNTypes #-}
109
{-# LANGUAGE ScopedTypeVariables #-}
11-
-- Orphan instances for 'Time' were introduced temporarily (no pun intended)
12-
-- to implement generic 'ToJSON' and 'FromJSON' instances for 'PointSchedule'.
13-
-- Once implemented by hand, they should be removed.
14-
{-# OPTIONS_GHC -Worphans #-}
1510

1611
-- | Data types and generators for point schedules.
1712
--
@@ -62,7 +57,6 @@ import Control.Monad.ST (ST)
6257
import Data.Bifunctor (first)
6358
import Data.Functor (($>))
6459
import Data.List (mapAccumL, partition, scanl')
65-
import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions)
6660
import qualified Data.Map.Strict as Map
6761
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
6862
import Data.Time (DiffTime)
@@ -75,7 +69,6 @@ import Ouroboros.Consensus.Protocol.Abstract
7569
(SecurityParam (SecurityParam), maxRollbacks)
7670
import Ouroboros.Consensus.Util.Condense (CondenseList (..),
7771
PaddingDirection (..), condenseListWithPadding)
78-
import GHC.Generics
7972
import qualified Ouroboros.Network.AnchoredFragment as AF
8073
import Ouroboros.Network.Block (SlotNo (..), blockSlot)
8174
import Ouroboros.Network.Point (withOrigin)
@@ -187,21 +180,6 @@ data PointSchedule blk = PointSchedule {
187180
-- the simulation will still run until this time is reached.
188181
psMinEndTime :: Time
189182
}
190-
deriving (Generic)
191-
192-
instance ToJSON blk => ToJSON (PointSchedule blk) where
193-
toEncoding = genericToEncoding defaultOptions
194-
195-
instance FromJSON blk => FromJSON (PointSchedule blk)
196-
197-
-- | TODO(xavier): Remove orphan instance after writing the 'PointSchedule'
198-
-- instance above by hand.
199-
instance ToJSON Time where
200-
toEncoding = genericToEncoding defaultOptions
201-
202-
-- | TODO(xavier): Remove orphan instance after writing the 'PointSchedule'
203-
-- instance above by hand.
204-
instance FromJSON Time
205183

206184
-- | List of all blocks appearing in the schedules.
207185
peerSchedulesBlocks :: Peers (PeerSchedule blk) -> [blk]

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs‎

Lines changed: 1 addition & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,6 @@ module Test.Consensus.PointSchedule.Peers (
4242

4343
import Data.Hashable (Hashable)
4444
import Data.Map.Strict (Map)
45-
import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions)
4645
import qualified Data.Map.Strict as Map
4746
import Data.String (IsString (fromString))
4847
import GHC.Generics (Generic)
@@ -77,11 +76,6 @@ instance CondenseList PeerId where
7776

7877
instance Hashable PeerId
7978

80-
instance ToJSON PeerId where
81-
toEncoding = genericToEncoding defaultOptions
82-
83-
instance FromJSON PeerId
84-
8579
-- | General-purpose functor associated with a peer.
8680
data Peer a =
8781
Peer {
@@ -115,12 +109,7 @@ data Peers a = Peers
115109
{ honestPeers :: Map Int a,
116110
adversarialPeers :: Map Int a
117111
}
118-
deriving (Eq, Show, Generic)
119-
120-
instance ToJSON a => ToJSON (Peers a) where
121-
toEncoding = genericToEncoding defaultOptions
122-
123-
instance FromJSON a => FromJSON (Peers a)
112+
deriving (Eq, Show)
124113

125114
-- | Variant of 'honestPeers' that returns a map with 'PeerId's as keys.
126115
honestPeers' :: Peers a -> Map PeerId a

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/SinglePeer.hs‎

Lines changed: 1 addition & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE DeriveGeneric #-}
21
-- | This module contains functions for generating random point schedules.
32
--
43
-- A point schedule is a set of tables, having one table per simulated peer.
@@ -103,9 +102,7 @@ import Control.Monad.Class.MonadTime.SI (Time)
103102
import Data.List (mapAccumL)
104103
import Data.Time.Clock (DiffTime)
105104
import Data.Vector (Vector)
106-
import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions)
107105
import qualified Data.Vector as Vector
108-
import GHC.Generics
109106
import qualified Ouroboros.Network.AnchoredFragment as AF
110107
import Ouroboros.Network.Block (BlockNo (unBlockNo), blockSlot)
111108
import qualified System.Random.Stateful as R (StatefulGen)
@@ -118,12 +115,7 @@ data SchedulePoint blk
118115
= ScheduleTipPoint (WithOrigin blk)
119116
| ScheduleHeaderPoint (WithOrigin blk)
120117
| ScheduleBlockPoint (WithOrigin blk)
121-
deriving (Eq, Show, Generic)
122-
123-
instance ToJSON blk => ToJSON (SchedulePoint blk) where
124-
toEncoding = genericToEncoding defaultOptions
125-
126-
instance FromJSON blk => FromJSON (SchedulePoint blk)
118+
deriving (Eq, Show)
127119

128120
scheduleTipPoint :: blk -> SchedulePoint blk
129121
scheduleTipPoint = ScheduleTipPoint . At

0 commit comments

Comments
 (0)