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

Commit d8ebf20

Browse files
intricateintricate
committed
[CO-354] Add RequiresNetworkMagic field to CoreConfiguration
1 parent 24fc9b7 commit d8ebf20

File tree

10 files changed

+170
-82
lines changed

10 files changed

+170
-82
lines changed

‎core/src/Pos/Aeson/Core/Configuration.hs

+19-2
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,26 @@ module Pos.Aeson.Core.Configuration
66
(
77
) where
88

9-
import Data.Aeson.TH (deriveJSON)
9+
import Universum
10+
11+
import Data.Aeson (FromJSON, parseJSON, withObject, (.:), (.:?))
12+
import Data.Aeson.TH (deriveToJSON)
1013
import Serokell.Aeson.Options (defaultOptions)
1114

1215
import Pos.Core.Configuration.Core (CoreConfiguration (..))
16+
import Pos.Crypto (RequiresNetworkMagic (..))
17+
18+
deriveToJSON defaultOptions ''CoreConfiguration
1319

14-
deriveJSON defaultOptions ''CoreConfiguration
20+
instance FromJSON CoreConfiguration where
21+
parseJSON = withObject "core" $ \obj -> do
22+
ccg <- obj .: "genesis"
23+
ccdsv <- obj .: "dbSerializeVersion"
24+
ccrnm <- determineRNM <$> obj .:? "requiresNetworkMagic"
25+
pure $ CoreConfiguration ccg ccdsv ccrnm
26+
where
27+
-- If "requiresNetworkMagic" is not specified, default to NMMustBeJust
28+
determineRNM :: Maybe RequiresNetworkMagic -> RequiresNetworkMagic
29+
determineRNM mrnm = case mrnm of
30+
Nothing -> NMMustBeJust
31+
Just x -> x

‎core/src/Pos/Core/Configuration.hs

+24-6
Original file line numberDiff line numberDiff line change
@@ -105,18 +105,21 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act
105105
theGenesisData <- case Canonical.fromJSON gdataJSON of
106106
Left err -> throwM $ GenesisDataSchemaError err
107107
Right it -> return it
108+
-- Override the RequiresNetworkMagic in GenesisData with the value
109+
-- specified in CoreConfiguration.
110+
let overriddenGenesisData = updateGD theGenesisData
108111

109-
let (_, theGenesisHash) = canonicalGenesisJson theGenesisData
110-
pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts theGenesisData)
111-
pm = gpcProtocolMagic (gdProtocolConsts theGenesisData)
112+
let (_, theGenesisHash) = canonicalGenesisJson overriddenGenesisData
113+
pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts overriddenGenesisData)
114+
pm = gpcProtocolMagic (gdProtocolConsts overriddenGenesisData)
112115
when (theGenesisHash /= expectedHash) $
113116
throwM $ GenesisHashMismatch
114117
(show theGenesisHash) (show expectedHash)
115118

116119
withCoreConfiguration conf $
117120
withProtocolConstants pc $
118-
withGenesisBlockVersionData (gdBlockVersionData theGenesisData) $
119-
withGenesisData theGenesisData $
121+
withGenesisBlockVersionData (gdBlockVersionData overriddenGenesisData) $
122+
withGenesisData overriddenGenesisData $
120123
withGenesisHash theGenesisHash $
121124
withGeneratedSecrets Nothing $
122125
act pm
@@ -139,10 +142,25 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act
139142
Just newSeed -> spec
140143
{ gsInitializer = overrideSeed newSeed (gsInitializer spec)
141144
}
145+
-- Override the RequiresNetworkMagic in GenesisSpec with the value
146+
-- specified in CoreConfiguration.
147+
overriddenSpec = updateGS theSpec
142148

143-
let theConf = conf {ccGenesis = GCSpec theSpec}
149+
let theConf = conf {ccGenesis = GCSpec overriddenSpec}
144150

145151
withGenesisSpec theSystemStart theConf act
152+
where
153+
updateGD :: GenesisData -> GenesisData
154+
updateGD gd = gd { gdProtocolConsts = updateGPC (gdProtocolConsts gd) }
155+
--
156+
updateGS :: GenesisSpec -> GenesisSpec
157+
updateGS gs = gs { gsProtocolConstants = updateGPC (gsProtocolConstants gs) }
158+
--
159+
updateGPC :: GenesisProtocolConstants -> GenesisProtocolConstants
160+
updateGPC gpc = gpc { gpcProtocolMagic = updatePM (gpcProtocolMagic gpc) }
161+
--
162+
updatePM :: ProtocolMagic -> ProtocolMagic
163+
updatePM pm = pm { getRequiresNetworkMagic = ccRequiresNetworkMagic }
146164

147165
withGenesisSpec
148166
:: Timestamp

‎core/src/Pos/Core/Configuration/Core.hs

+9-4
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisAvvmBalances (..
4242
import Pos.Core.ProtocolConstants (VssMaxTTL (..), VssMinTTL (..))
4343
import Pos.Core.Slotting (EpochIndex (..))
4444
import Pos.Core.Update (BlockVersionData (..), SoftforkRule (..))
45-
import Pos.Crypto (ProtocolMagic (..))
45+
import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..))
4646
import Pos.Crypto.Hashing (Hash)
4747

4848
data GenesisConfiguration
@@ -123,17 +123,22 @@ instance FromJSON GenesisConfiguration where
123123
data CoreConfiguration = CoreConfiguration
124124
{
125125
-- | Specifies the genesis
126-
ccGenesis :: !GenesisConfiguration
126+
ccGenesis :: !GenesisConfiguration
127127

128128
-- | Versioning for values in node's DB
129-
, ccDbSerializeVersion :: !Word8
129+
, ccDbSerializeVersion :: !Word8
130+
131+
-- | Specifies whether address discrimination takes place on this chain
132+
, ccRequiresNetworkMagic :: !RequiresNetworkMagic
130133

131134
}
132135
deriving (Show, Generic)
133136

134137

135138
defaultCoreConfiguration :: ProtocolMagic -> CoreConfiguration
136-
defaultCoreConfiguration pm = CoreConfiguration (GCSpec (defaultGenesisSpec pm)) 0
139+
defaultCoreConfiguration pm = CoreConfiguration (GCSpec (defaultGenesisSpec pm))
140+
0
141+
NMMustBeJust
137142

138143
defaultGenesisSpec :: ProtocolMagic -> GenesisSpec
139144
defaultGenesisSpec pm = UnsafeGenesisSpec

‎core/src/Pos/Core/Genesis/Canonical.hs

+18-6
Original file line numberDiff line numberDiff line change
@@ -196,12 +196,24 @@ instance Monad m => ToJSON m GenesisProtocolConstants where
196196
]
197197

198198
instance Monad m => ToJSON m ProtocolMagic where
199-
toJSON (ProtocolMagic (ProtocolMagicId ident) rnm) = do
200-
(\jsIdent jsRNM -> JSObject
201-
[ ("pm", jsIdent)
202-
, ("requiresNetworkMagic", jsRNM) ])
203-
<$> toJSON ident
204-
<*> toJSON rnm
199+
-- | We only output the `ProtocolMagicId` such that we don't alter the
200+
-- resulting hash digest of the genesis block.
201+
--
202+
-- In the function, `withCoreConfigurations`, we compare the hash of the
203+
-- canonical JSON representation of a hardcoded genesis block with an
204+
-- accompanying hardcoded hash of that same genesis block at its inception
205+
-- (both of which can be found in lib/configuration.yaml). This allows us
206+
-- to verify the integrity of the genesis block and ensure that it hasn't
207+
-- been altered.
208+
--
209+
-- As a result of this addition of the `RequiresNetworkMagic` field to
210+
-- `ProtocolMagic`, we cannot include the newly introduced
211+
-- `RequiresNetworkMagic` field of `ProtocolMagic` as it would produce
212+
-- invalid hashes for previously existing genesis blocks.
213+
--
214+
-- See the implementation of `withCoreConfigurations` for more detail on
215+
-- how this works.
216+
toJSON (ProtocolMagic (ProtocolMagicId ident) _rnm) = toJSON ident
205217

206218
instance Monad m => ToJSON m GenesisAvvmBalances where
207219
toJSON = toJSON . getGenesisAvvmBalances

‎core/test/Test/Pos/Core/Arbitrary.hs

+15-5
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,8 @@ module Test.Pos.Core.Arbitrary
2121
, genVssCertificate
2222
, genSlotId
2323
, genLocalSlotIndex
24+
, genGenesisData
25+
, genGenesisProtocolConstants
2426
) where
2527

2628
import Universum
@@ -558,15 +560,22 @@ instance Arbitrary ProtocolConstants where
558560
ProtocolConstants <$> choose (1, 20000) <*> pure vssMin <*> pure vssMax
559561

560562
instance Arbitrary G.GenesisProtocolConstants where
561-
arbitrary = do
562-
pm <- arbitrary
563-
flip G.genesisProtocolConstantsFromProtocolConstants pm <$> arbitrary
563+
arbitrary = genGenesisProtocolConstants arbitrary
564+
565+
genGenesisProtocolConstants
566+
:: Gen ProtocolMagic
567+
-> Gen G.GenesisProtocolConstants
568+
genGenesisProtocolConstants genPM =
569+
flip G.genesisProtocolConstantsFromProtocolConstants <$> genPM <*> arbitrary
564570

565571
instance (HasProtocolConstants) => Arbitrary G.GenesisData where
566-
arbitrary = G.GenesisData
572+
arbitrary = genGenesisData arbitrary
573+
574+
genGenesisData :: Gen G.GenesisProtocolConstants -> Gen G.GenesisData
575+
genGenesisData genGPC = G.GenesisData
567576
<$> arbitrary <*> arbitrary <*> arbitraryStartTime
568577
<*> arbitraryVssCerts <*> arbitrary <*> arbitraryBVD
569-
<*> arbitrary <*> arbitrary <*> arbitrary
578+
<*> genGPC <*> arbitrary <*> arbitrary
570579
where
571580
-- System start time should be multiple of a second.
572581
arbitraryStartTime = Timestamp . convertUnit @Second <$> arbitrary
@@ -576,6 +585,7 @@ instance (HasProtocolConstants) => Arbitrary G.GenesisData where
576585
True
577586
hasKnownFeePolicy _ = False
578587
arbitraryVssCerts = G.GenesisVssCertificatesMap . mkVssCertificatesMapLossy <$> arbitrary
588+
579589
----------------------------------------------------------------------------
580590
-- Arbitrary miscellaneous types
581591
----------------------------------------------------------------------------

‎core/test/Test/Pos/Core/Gen.hs

+4-2
Original file line numberDiff line numberDiff line change
@@ -219,8 +219,9 @@ import Serokell.Data.Memory.Units (Byte)
219219

220220
import Test.Pos.Crypto.Gen (genAbstractHash, genDecShare, genHDAddressPayload,
221221
genProtocolMagic, genProxySignature, genPublicKey,
222-
genRedeemPublicKey, genRedeemSignature, genSafeSigner,
223-
genSecretKey, genSignTag, genSignature, genVssPublicKey)
222+
genRedeemPublicKey, genRedeemSignature,
223+
genRequiresNetworkMagic, genSafeSigner, genSecretKey,
224+
genSignTag, genSignature, genVssPublicKey)
224225

225226

226227
----------------------------------------------------------------------------
@@ -494,6 +495,7 @@ genCoreConfiguration pm =
494495
CoreConfiguration
495496
<$> genGenesisConfiguration pm
496497
<*> genWord8
498+
<*> genRequiresNetworkMagic
497499

498500
----------------------------------------------------------------------------
499501
-- Pos.Core.Delegation Generators

‎crypto/test/Test/Pos/Crypto/Gen.hs

+1
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Test.Pos.Crypto.Gen
33
-- Protocol Magic Generator
44
genProtocolMagic
55
, genProtocolMagicId
6+
, genRequiresNetworkMagic
67

78
-- Sign Tag Generator
89
, genSignTag

‎lib/configuration.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -259,6 +259,7 @@ mainnet_base: &mainnet_base
259259
avvmDistr: {}
260260

261261
dbSerializeVersion: 0
262+
requiresNetworkMagic: NMMustBeNothing
262263

263264
ntp:
264265
responseTimeout: 30000000 # 30 sec

‎lib/src/Test/Pos/Helpers.hs

+54-24
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,21 @@
22
{-# LANGUAGE RankNTypes #-}
33

44
{-# OPTIONS_GHC -fno-warn-orphans #-}
5+
-- Need this to avoid a warning on the `typeName` helper function.
6+
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
57

68
module Test.Pos.Helpers
79
( canonicalJsonTest
10+
, canonicalJsonTest'
811
) where
912

1013
import Universum
1114

1215
import Data.Functor.Identity (Identity (..))
16+
import Data.Typeable (typeRep)
1317
import Test.Hspec (Spec)
14-
import Test.QuickCheck (Property, (.&&.), (===))
18+
import Test.Hspec.QuickCheck (prop)
19+
import Test.QuickCheck (Gen, Property, forAll, (.&&.), (===))
1520
import qualified Text.JSON.Canonical as CanonicalJSON
1621

1722
import Pos.Core.Genesis ()
@@ -34,27 +39,52 @@ canonicalJsonTest ::
3439
canonicalJsonTest =
3540
identityTest @a $ \x ->
3641
canonicalJsonRenderAndDecode x .&&. canonicalJsonPrettyAndDecode x
42+
43+
-- | Basically the same as `canonicalJsonTest` but tests a given `Gen a`.
44+
canonicalJsonTest'
45+
:: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a)
46+
=> Gen a
47+
-> Spec
48+
canonicalJsonTest' genA =
49+
prop (typeName @a) $ forAll genA $ \x ->
50+
canonicalJsonRenderAndDecode x .&&. canonicalJsonPrettyAndDecode x
3751
where
38-
canonicalJsonRenderAndDecode x =
39-
let encodedX =
40-
CanonicalJSON.renderCanonicalJSON $
41-
runIdentity $ CanonicalJSON.toJSON x
42-
in canonicalJsonDecodeAndCompare x encodedX
43-
canonicalJsonPrettyAndDecode x =
44-
let encodedX =
45-
encodeUtf8 $
46-
CanonicalJSON.prettyCanonicalJSON $
47-
runIdentity $ CanonicalJSON.toJSON x
48-
in canonicalJsonDecodeAndCompare x encodedX
49-
canonicalJsonDecodeAndCompare ::
50-
a
51-
-> LByteString
52-
-> Property
53-
canonicalJsonDecodeAndCompare x encodedX =
54-
let decodedValue =
55-
either (error . toText) identity $
56-
CanonicalJSON.parseCanonicalJSON encodedX
57-
decodedX =
58-
either (error . pretty @SchemaError) identity $
59-
CanonicalJSON.fromJSON decodedValue
60-
in decodedX === x
52+
-- GHC 8.2.2 says the `Typeable x` constraint is not necessary, but won't compile
53+
-- this without it.
54+
typeName :: forall x. Typeable x => String
55+
typeName = show $ typeRep (Proxy @a)
56+
57+
canonicalJsonRenderAndDecode
58+
:: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a)
59+
=> a
60+
-> Property
61+
canonicalJsonRenderAndDecode x =
62+
let encodedX =
63+
CanonicalJSON.renderCanonicalJSON $
64+
runIdentity $ CanonicalJSON.toJSON x
65+
in canonicalJsonDecodeAndCompare x encodedX
66+
67+
canonicalJsonPrettyAndDecode
68+
:: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a)
69+
=> a
70+
-> Property
71+
canonicalJsonPrettyAndDecode x =
72+
let encodedX =
73+
encodeUtf8 $
74+
CanonicalJSON.prettyCanonicalJSON $
75+
runIdentity $ CanonicalJSON.toJSON x
76+
in canonicalJsonDecodeAndCompare x encodedX
77+
78+
canonicalJsonDecodeAndCompare
79+
:: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a)
80+
=> a
81+
-> LByteString
82+
-> Property
83+
canonicalJsonDecodeAndCompare x encodedX =
84+
let decodedValue =
85+
either (error . toText) identity $
86+
CanonicalJSON.parseCanonicalJSON encodedX
87+
decodedX =
88+
either (error . pretty @SchemaError) identity $
89+
CanonicalJSON.fromJSON decodedValue
90+
in decodedX === x

‎lib/test/Test/Pos/Genesis/CanonicalSpec.hs

+25-33
Original file line numberDiff line numberDiff line change
@@ -6,43 +6,35 @@ module Test.Pos.Genesis.CanonicalSpec
66

77
import Universum
88

9-
import Test.Hspec (Spec, describe, runIO)
9+
import Test.Hspec (Spec, describe)
1010
import Test.Hspec.QuickCheck (modifyMaxSuccess)
11-
import Test.QuickCheck (generate)
1211

13-
import Pos.Core.Genesis (GenesisAvvmBalances, GenesisData, GenesisDelegation,
14-
GenesisProtocolConstants, GenesisWStakeholders)
15-
import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..))
12+
import Pos.Core.Genesis (GenesisAvvmBalances, GenesisDelegation, GenesisWStakeholders)
13+
import Pos.Crypto (RequiresNetworkMagic (..))
1614

17-
import Test.Pos.Configuration (withProvidedMagicConfig)
18-
import Test.Pos.Core.Arbitrary ()
15+
import Test.Pos.Configuration (withDefConfiguration)
16+
import Test.Pos.Core.Arbitrary (genGenesisData, genGenesisProtocolConstants)
1917
import Test.Pos.Crypto.Arbitrary (genProtocolMagicUniformWithRNM)
20-
import Test.Pos.Helpers (canonicalJsonTest)
21-
22-
23-
-- We run the tests this number of times, with different `ProtocolMagics`, to get increased
24-
-- coverage. We should really do this inside of the `prop`, but it is difficult to do that
25-
-- without significant rewriting of the testsuite.
26-
testMultiple :: Int
27-
testMultiple = 3
18+
import Test.Pos.Helpers (canonicalJsonTest, canonicalJsonTest')
2819

2920
spec :: Spec
30-
spec = do
31-
runWithMagic NMMustBeNothing
32-
runWithMagic NMMustBeJust
33-
34-
runWithMagic :: RequiresNetworkMagic -> Spec
35-
runWithMagic rnm = replicateM_ testMultiple $
36-
modifyMaxSuccess (`div` testMultiple) $ do
37-
pm <- runIO (generate (genProtocolMagicUniformWithRNM rnm))
38-
describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $
39-
specBody pm
40-
41-
specBody :: ProtocolMagic -> Spec
42-
specBody pm = withProvidedMagicConfig pm $ describe "Genesis" $ modifyMaxSuccess (const 10) $ do
21+
spec = withDefConfiguration $ \_ -> describe "Genesis" $ modifyMaxSuccess (const 10) $ do
4322
describe "Canonical encoding" $ do
44-
canonicalJsonTest @GenesisProtocolConstants
45-
canonicalJsonTest @GenesisAvvmBalances
46-
canonicalJsonTest @GenesisWStakeholders
47-
canonicalJsonTest @GenesisDelegation
48-
canonicalJsonTest @GenesisData
23+
24+
-- Restricted canonical JSON identity tests for those types which
25+
-- include `ProtocolMagic`.
26+
--
27+
-- This must be done since the canonical `ToJSON` instance of
28+
-- `ProtocolMagic` does not output the `RequiresNetworkMagic` field
29+
-- and the canonical `FromJSON` instance defaults its value to
30+
-- `NMMustBeJust`.
31+
describe "Generator restricted to only use NMMustBeJust" $ do
32+
let genPM = genProtocolMagicUniformWithRNM NMMustBeJust
33+
canonicalJsonTest' $ genGenesisProtocolConstants genPM
34+
canonicalJsonTest' $ genGenesisData (genGenesisProtocolConstants genPM)
35+
36+
-- Unrestricted canonical JSON identity tests
37+
describe "Unrestricted tests" $ do
38+
canonicalJsonTest @GenesisAvvmBalances
39+
canonicalJsonTest @GenesisWStakeholders
40+
canonicalJsonTest @GenesisDelegation

0 commit comments

Comments
 (0)