diff --git a/chain/bench/block-bench.hs b/chain/bench/block-bench.hs index 69b6648b7a1..08820af7334 100644 --- a/chain/bench/block-bench.hs +++ b/chain/bench/block-bench.hs @@ -20,7 +20,8 @@ import Pos.Chain.Delegation (DlgPayload) import Pos.Chain.Ssc (SscPayload) import Pos.Chain.Txp (TxPayload (..)) import Pos.Chain.Update (UpdatePayload) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) import Test.Pos.Chain.Block.Arbitrary.Generate (generateMainBlock) @@ -28,7 +29,7 @@ import Test.Pos.Chain.Block.Arbitrary.Generate (generateMainBlock) -- 'MainBlock'. pm :: ProtocolMagic -pm = ProtocolMagic 0 +pm = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic -- | A test subject: a MainBlock, and its various components, each paired with -- its serialization. diff --git a/chain/src/Pos/Chain/Block/Configuration.hs b/chain/src/Pos/Chain/Block/Configuration.hs index a8182878db2..a774e99206a 100644 --- a/chain/src/Pos/Chain/Block/Configuration.hs +++ b/chain/src/Pos/Chain/Block/Configuration.hs @@ -74,7 +74,7 @@ data BlockConfiguration = BlockConfiguration -- | Chain quality will be also calculated for this amount of seconds. , ccFixedTimeCQ :: !Second - } deriving (Show, Generic) + } deriving (Eq, Generic, Show) instance ToJSON BlockConfiguration where toJSON = genericToJSON defaultOptions diff --git a/chain/src/Pos/Chain/Block/Header.hs b/chain/src/Pos/Chain/Block/Header.hs index 3e7d3c0ab5e..52b73f8d13e 100644 --- a/chain/src/Pos/Chain/Block/Header.hs +++ b/chain/src/Pos/Chain/Block/Header.hs @@ -5,7 +5,7 @@ module Pos.Chain.Block.Header ( BlockHeader (..) - , blockHeaderProtocolMagic + , blockHeaderProtocolMagicId , blockHeaderHash , choosingBlockHeader , _BlockHeaderGenesis @@ -22,7 +22,7 @@ module Pos.Chain.Block.Header , GenericBlockHeader , mkGenericBlockHeaderUnsafe - , gbhProtocolMagic + , gbhProtocolMagicId , gbhPrevBlock , gbhBodyProof , gbhConsensus @@ -102,10 +102,10 @@ import Pos.Core.Common (ChainDifficulty, HasDifficulty (..)) import Pos.Core.Slotting (EpochIndex (..), EpochOrSlot (..), HasEpochIndex (..), HasEpochOrSlot (..), SlotId (..), slotIdF) -import Pos.Crypto (Hash, ProtocolMagic (..), PublicKey, SecretKey, - SignTag (..), Signature, checkSig, hashHexF, - isSelfSignedPsk, proxySign, proxyVerify, psigPsk, sign, - toPublic, unsafeHash) +import Pos.Crypto (Hash, ProtocolMagic (..), ProtocolMagicId (..), + PublicKey, SecretKey, SignTag (..), Signature, checkSig, + hashHexF, isSelfSignedPsk, proxySign, proxyVerify, + psigPsk, sign, toPublic, unsafeHash) import Pos.Util.Some (Some, applySome) import Pos.Util.Util (cborError, cerealError) @@ -159,9 +159,9 @@ instance Bi BlockHeader where _ -> cborError $ "decode@BlockHeader: unknown tag " <> pretty t -- | The 'ProtocolMagic' in a 'BlockHeader'. -blockHeaderProtocolMagic :: BlockHeader -> ProtocolMagic -blockHeaderProtocolMagic (BlockHeaderGenesis gbh) = _gbhProtocolMagic gbh -blockHeaderProtocolMagic (BlockHeaderMain mbh) = _gbhProtocolMagic mbh +blockHeaderProtocolMagicId :: BlockHeader -> ProtocolMagicId +blockHeaderProtocolMagicId (BlockHeaderGenesis gbh) = _gbhProtocolMagicId gbh +blockHeaderProtocolMagicId (BlockHeaderMain mbh) = _gbhProtocolMagicId mbh -- | Verify a BlockHeader in isolation. There is nothing to be done for -- genesis headers. @@ -227,15 +227,15 @@ blockHeaderHash = unsafeHash -- general there may be some invariants which must hold for the -- contents of header. data GenericBlockHeader bodyProof consensus extra = GenericBlockHeader - { _gbhProtocolMagic :: !ProtocolMagic + { _gbhProtocolMagicId :: !ProtocolMagicId -- | Pointer to the header of the previous block. - , _gbhPrevBlock :: !HeaderHash + , _gbhPrevBlock :: !HeaderHash , -- | Proof of body. - _gbhBodyProof :: !bodyProof + _gbhBodyProof :: !bodyProof , -- | Consensus data to verify consensus algorithm. - _gbhConsensus :: !consensus + _gbhConsensus :: !consensus , -- | Any extra data. - _gbhExtra :: !extra + _gbhExtra :: !extra } deriving (Eq, Show, Generic, NFData) instance @@ -243,14 +243,14 @@ instance => Bi (GenericBlockHeader bodyProof consensus extra) where encode bh = encodeListLen 5 - <> encode (getProtocolMagic (_gbhProtocolMagic bh)) + <> encode (unProtocolMagicId (_gbhProtocolMagicId bh)) <> encode (_gbhPrevBlock bh) <> encode (_gbhBodyProof bh) <> encode (_gbhConsensus bh) <> encode (_gbhExtra bh) decode = do enforceSize "GenericBlockHeader b" 5 - _gbhProtocolMagic <- ProtocolMagic <$> decode + _gbhProtocolMagicId <- ProtocolMagicId <$> decode _gbhPrevBlock <- decode _gbhBodyProof <- decode _gbhConsensus <- decode @@ -263,7 +263,7 @@ instance where getCopy = contain $ - do _gbhProtocolMagic <- safeGet + do _gbhProtocolMagicId <- safeGet _gbhPrevBlock <- safeGet _gbhBodyProof <- safeGet _gbhConsensus <- safeGet @@ -271,7 +271,7 @@ instance return $! GenericBlockHeader {..} putCopy GenericBlockHeader {..} = contain $ - do safePut _gbhProtocolMagic + do safePut _gbhProtocolMagicId safePut _gbhPrevBlock safePut _gbhBodyProof safePut _gbhConsensus @@ -285,7 +285,9 @@ mkGenericBlockHeaderUnsafe -> consensus -> extra -> GenericBlockHeader bodyProof consensus extra -mkGenericBlockHeaderUnsafe = GenericBlockHeader +mkGenericBlockHeaderUnsafe pm = GenericBlockHeader pmi + where + pmi = getProtocolMagicId pm -------------------------------------------------------------------------------- @@ -328,12 +330,13 @@ mkGenesisHeader -> GenesisBlockHeader mkGenesisHeader pm prevHeader epoch body = GenericBlockHeader - pm + pmi (either getGenesisHash headerHash prevHeader) (mkGenesisProof body) consensus (GenesisExtraHeaderData $ mkAttributes ()) where + pmi = getProtocolMagicId pm difficulty = either (const 0) (view difficultyL) prevHeader consensus = GenesisConsensusData {_gcdEpoch = epoch, _gcdDifficulty = difficulty} @@ -399,8 +402,9 @@ mkMainHeaderExplicit -> MainExtraHeaderData -> MainBlockHeader mkMainHeaderExplicit pm prevHash difficulty slotId sk pske body extra = - GenericBlockHeader pm prevHash proof consensus extra + GenericBlockHeader pmi prevHash proof consensus extra where + pmi = getProtocolMagicId pm proof = mkMainProof body makeSignature toSign (psk,_) = BlockPSignatureHeavy $ proxySign pm SignMainBlockHeavy sk psk toSign diff --git a/chain/src/Pos/Chain/Block/Logic/Integrity.hs b/chain/src/Pos/Chain/Block/Logic/Integrity.hs index e74a087729f..71ccdb3e530 100644 --- a/chain/src/Pos/Chain/Block/Logic/Integrity.hs +++ b/chain/src/Pos/Chain/Block/Logic/Integrity.hs @@ -31,7 +31,7 @@ import Pos.Chain.Block.Block (Block, gbExtra, genBlockLeaders, import Pos.Chain.Block.Genesis (gebAttributes, gehAttributes) import Pos.Chain.Block.HasPrevBlock (prevBlockL) import Pos.Chain.Block.Header (BlockHeader (..), HasHeaderHash (..), - HeaderHash, blockHeaderProtocolMagic, gbhExtra, + HeaderHash, blockHeaderProtocolMagicId, gbhExtra, mainHeaderLeaderKey, verifyBlockHeader) import Pos.Chain.Block.IsHeader (headerSlotL) import Pos.Chain.Block.Main (mebAttributes, mehAttributes) @@ -43,7 +43,8 @@ import Pos.Core (ChainDifficulty, EpochOrSlot, HasDifficulty (..), import Pos.Core.Attributes (areAttributesKnown) import Pos.Core.Chrono (NewestFirst (..), OldestFirst) import Pos.Core.Slotting (EpochIndex) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + getProtocolMagic) ---------------------------------------------------------------------------- -- Header @@ -100,7 +101,7 @@ verifyHeader pm VerifyHeaderParams {..} h = where checks = mconcat - [ checkProtocolMagic + [ checkProtocolMagicId , maybe mempty relatedToPrevHeader vhpPrevHeader , maybe mempty relatedToCurrentSlot vhpCurrentSlot , maybe mempty relatedToLeaders vhpLeaders @@ -135,11 +136,11 @@ verifyHeader pm VerifyHeaderParams {..} h = ("two adjacent blocks are from different epochs ("%build%" != "%build%")") oldEpoch newEpoch ) - checkProtocolMagic = - [ ( pm == blockHeaderProtocolMagic h + checkProtocolMagicId = + [ ( getProtocolMagicId pm == blockHeaderProtocolMagicId h , sformat ("protocol magic number mismatch: got "%int%" but expected "%int) - (getProtocolMagic (blockHeaderProtocolMagic h)) + (unProtocolMagicId (blockHeaderProtocolMagicId h)) (getProtocolMagic pm) ) ] diff --git a/chain/src/Pos/Chain/Genesis/Config.hs b/chain/src/Pos/Chain/Genesis/Config.hs index 219a558d419..66cf11f210c 100644 --- a/chain/src/Pos/Chain/Genesis/Config.hs +++ b/chain/src/Pos/Chain/Genesis/Config.hs @@ -70,7 +70,7 @@ import Pos.Core.ProtocolConstants (ProtocolConstants (..), pcBlkSecurityParam, pcChainQualityThreshold, pcEpochSlots, pcSlotSecurityParam, vssMaxTTL, vssMinTTL) import Pos.Core.Slotting (SlotCount, Timestamp) -import Pos.Crypto (ProtocolMagic) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic) import Pos.Crypto.Hashing (Hash, hashRaw, unsafeHash) import Pos.Util.Json.Canonical (SchemaError) import Pos.Util.Util (leftToPanic) @@ -101,7 +101,7 @@ instance ToJSON StaticConfig where instance FromJSON StaticConfig where parseJSON (Object o) | HM.member "src" o = GCSrc <$> ((o .: "src") >>= (.: "file")) - <*> ((o .: "src") >>= (.: "hash")) + <*> ((o .: "src") >>= (.: "hash")) | HM.member "spec" o = do -- GCSpec Object specO <- o .: "spec" @@ -148,9 +148,9 @@ instance FromJSON StaticConfig where avvmBalanceFactor useHeavyDlg seed) - | otherwise = fail "Incorrect JSON encoding for GenesisConfiguration" + | otherwise = fail "Incorrect JSON encoding for StaticConfig" - parseJSON invalid = typeMismatch "GenesisConfiguration" invalid + parseJSON invalid = typeMismatch "StaticConfig" invalid -------------------------------------------------------------------------------- -- Config @@ -256,9 +256,10 @@ mkConfigFromStaticConfig -> Maybe Integer -- ^ Optional seed which overrides one from testnet initializer if -- provided. + -> RequiresNetworkMagic -> StaticConfig -> m Config -mkConfigFromStaticConfig confDir mSystemStart mSeed = \case +mkConfigFromStaticConfig confDir mSystemStart mSeed rnm = \case -- If a 'GenesisData' source file is given, we check its hash against the -- given expected hash, parse it, and use the GenesisData to fill in all of -- the obligations. @@ -276,10 +277,16 @@ mkConfigFromStaticConfig confDir mSystemStart mSeed = \case theGenesisData <- case Canonical.fromJSON gdataJSON of Left err -> throwM $ GenesisDataSchemaError err Right it -> return it - - let (_, theGenesisHash) = canonicalGenesisJson theGenesisData - pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts theGenesisData) - pm = gpcProtocolMagic (gdProtocolConsts theGenesisData) + -- Override the RequiresNetworkMagic in GenesisData with the value + -- specified in Configuration. + let overriddenGenesisData = updateGD theGenesisData + + let (_, theGenesisHash) = canonicalGenesisJson overriddenGenesisData + pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts overriddenGenesisData) + -- We must override the `getRequiresNetworkMagic` field of the `ProtocolMagic`, + -- in order to preserve backwards compatibility of configuration. + pm = (gpcProtocolMagic (gdProtocolConsts overriddenGenesisData)) + { getRequiresNetworkMagic = rnm } when (theGenesisHash /= expectedHash) $ throwM $ GenesisHashMismatch (show theGenesisHash) (show expectedHash) @@ -288,7 +295,7 @@ mkConfigFromStaticConfig confDir mSystemStart mSeed = \case { configProtocolMagic = pm , configProtocolConstants = pc , configGeneratedSecrets = Nothing - , configGenesisData = theGenesisData + , configGenesisData = overriddenGenesisData , configGenesisHash = GenesisHash $ coerce theGenesisHash } @@ -310,8 +317,23 @@ mkConfigFromStaticConfig confDir mSystemStart mSeed = \case Just newSeed -> spec { gsInitializer = overrideSeed newSeed (gsInitializer spec) } + -- Override the RequiresNetworkMagic in GenesisSpec with the value + -- specified in Configuration. + overriddenSpec = updateGS theSpec - pure $ mkConfig theSystemStart theSpec + pure $ mkConfig theSystemStart overriddenSpec + where + updateGD :: GenesisData -> GenesisData + updateGD gd = gd { gdProtocolConsts = updateGPC (gdProtocolConsts gd) } + -- + updateGS :: GenesisSpec -> GenesisSpec + updateGS gs = gs { gsProtocolConstants = updateGPC (gsProtocolConstants gs) } + -- + updateGPC :: GenesisProtocolConstants -> GenesisProtocolConstants + updateGPC gpc = gpc { gpcProtocolMagic = updatePM (gpcProtocolMagic gpc) } + -- + updatePM :: ProtocolMagic -> ProtocolMagic + updatePM pm = pm { getRequiresNetworkMagic = rnm } mkConfig :: Timestamp -> GenesisSpec -> Config mkConfig theSystemStart spec = Config diff --git a/chain/src/Pos/Chain/Genesis/Data.hs b/chain/src/Pos/Chain/Genesis/Data.hs index 575be8d6d97..c5a15453366 100644 --- a/chain/src/Pos/Chain/Genesis/Data.hs +++ b/chain/src/Pos/Chain/Genesis/Data.hs @@ -6,7 +6,7 @@ module Pos.Chain.Genesis.Data import Universum -import Control.Monad.Except (MonadError (..)) +import Control.Monad.Except (MonadError) import Text.JSON.Canonical (FromJSON (..), ToJSON (..), fromJSField, mkObject) diff --git a/chain/src/Pos/Chain/Genesis/ProtocolConstants.hs b/chain/src/Pos/Chain/Genesis/ProtocolConstants.hs index 896d30c3120..4f58f78e325 100644 --- a/chain/src/Pos/Chain/Genesis/ProtocolConstants.hs +++ b/chain/src/Pos/Chain/Genesis/ProtocolConstants.hs @@ -16,7 +16,7 @@ import Text.JSON.Canonical (FromJSON (..), Int54, JSValue (..), import Pos.Core.ProtocolConstants (ProtocolConstants (..), VssMaxTTL (..), VssMinTTL (..)) -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic) import Pos.Util.Json.Canonical (SchemaError) -- | 'GensisProtocolConstants' are not really part of genesis global state, @@ -38,7 +38,7 @@ instance Monad m => ToJSON m GenesisProtocolConstants where mkObject -- 'k' definitely won't exceed the limit [ ("k", pure . JSNum . fromIntegral $ gpcK) - , ("protocolMagic", toJSON (getProtocolMagic gpcProtocolMagic)) + , ("protocolMagic", toJSON gpcProtocolMagic) , ("vssMaxTTL", toJSON gpcVssMaxTTL) , ("vssMinTTL", toJSON gpcVssMinTTL) ] @@ -46,7 +46,7 @@ instance Monad m => ToJSON m GenesisProtocolConstants where instance MonadError SchemaError m => FromJSON m GenesisProtocolConstants where fromJSON obj = do gpcK <- fromIntegral @Int54 <$> fromJSField obj "k" - gpcProtocolMagic <- ProtocolMagic <$> fromJSField obj "protocolMagic" + gpcProtocolMagic <- fromJSField obj "protocolMagic" gpcVssMaxTTL <- fromJSField obj "vssMaxTTL" gpcVssMinTTL <- fromJSField obj "vssMinTTL" return GenesisProtocolConstants {..} diff --git a/chain/src/Pos/Chain/Ssc/Configuration.hs b/chain/src/Pos/Chain/Ssc/Configuration.hs index d6300d6b4a8..1232e191863 100644 --- a/chain/src/Pos/Chain/Ssc/Configuration.hs +++ b/chain/src/Pos/Chain/Ssc/Configuration.hs @@ -37,7 +37,7 @@ data SscConfiguration = SscConfiguration -- | Don't print “SSC couldn't compute seed” for the first epoch. , ccNoReportNoSecretsForEpoch1 :: !Bool } - deriving (Show, Generic) + deriving (Eq, Generic, Show) instance FromJSON SscConfiguration where parseJSON = genericParseJSON defaultOptions diff --git a/chain/src/Pos/Chain/Update/Configuration.hs b/chain/src/Pos/Chain/Update/Configuration.hs index 1bb52da6bab..57afe07545a 100644 --- a/chain/src/Pos/Chain/Update/Configuration.hs +++ b/chain/src/Pos/Chain/Update/Configuration.hs @@ -55,7 +55,7 @@ data UpdateConfiguration = UpdateConfiguration -- | System tag. , ccSystemTag :: !SystemTag } - deriving (Show, Generic) + deriving (Eq, Generic, Show) instance ToJSON UpdateConfiguration where toJSON = genericToJSON defaultOptions diff --git a/chain/test/Test/Pos/Chain/Block/Bi.hs b/chain/test/Test/Pos/Chain/Block/Bi.hs index b09cfe5e9d8..833b23c04c1 100644 --- a/chain/test/Test/Pos/Chain/Block/Bi.hs +++ b/chain/test/Test/Pos/Chain/Block/Bi.hs @@ -22,8 +22,9 @@ import Pos.Chain.Delegation (DlgPayload (..)) import Pos.Chain.Genesis (GenesisHash (..)) import Pos.Core (EpochIndex (..)) import Pos.Core.Attributes (mkAttributes) -import Pos.Crypto (Hash, ProtocolMagic (..), SignTag (..), - abstractHash, createPsk, hash, proxySign, sign, toPublic) +import Pos.Crypto (Hash, ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..), SignTag (..), abstractHash, + createPsk, hash, proxySign, sign, toPublic) import Test.Pos.Binary.Helpers.GoldenRoundTrip (goldenTestBi, roundTripsBiBuildable, roundTripsBiShow) @@ -273,16 +274,24 @@ exampleBlockHeaderGenesis = (BlockHeaderGenesis exampleGenesisBlockHeader) exampleBlockHeaderMain :: MainBlockHeader exampleBlockHeaderMain = - mkMainHeaderExplicit (ProtocolMagic 0) exampleHeaderHash + mkMainHeaderExplicit pm exampleHeaderHash exampleChainDifficulty exampleSlotId exampleSecretKey Nothing exampleMainBody exampleMainExtraHeaderData + where + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } exampleBlockSignature :: BlockSignature -exampleBlockSignature = BlockSignature (sign (ProtocolMagic 7) - SignMainBlock - exampleSecretKey - exampleMainToSign) +exampleBlockSignature = BlockSignature (sign pm + SignMainBlock + exampleSecretKey + exampleMainToSign) + where + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 7 + , getRequiresNetworkMagic = RequiresNoMagic + } exampleBlockPSignatureLight :: BlockSignature exampleBlockPSignatureLight = BlockPSignatureLight sig @@ -290,7 +299,9 @@ exampleBlockPSignatureLight = BlockPSignatureLight sig sig = proxySign pm SignProxySK delegateSk psk exampleMainToSign [delegateSk, issuerSk] = exampleSecretKeys 5 2 psk = createPsk pm issuerSk (toPublic delegateSk) exampleLightDlgIndices - pm = ProtocolMagic 2 + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 2 + , getRequiresNetworkMagic = RequiresNoMagic + } exampleBlockPSignatureHeavy :: BlockSignature exampleBlockPSignatureHeavy = BlockPSignatureHeavy sig @@ -298,7 +309,9 @@ exampleBlockPSignatureHeavy = BlockPSignatureHeavy sig sig = proxySign pm SignProxySK delegateSk psk exampleMainToSign [delegateSk, issuerSk] = exampleSecretKeys 5 2 psk = createPsk pm issuerSk (toPublic delegateSk) (staticHeavyDlgIndexes !! 0) - pm = ProtocolMagic 2 + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 2 + , getRequiresNetworkMagic = RequiresNoMagic + } exampleMainConsensusData :: MainConsensusData exampleMainConsensusData = MainConsensusData exampleSlotId @@ -314,17 +327,20 @@ exampleMainExtraHeaderData = (abstractHash (MainExtraBodyData (mkAttributes ()))) exampleGenesisBlockHeader :: GenesisBlockHeader -exampleGenesisBlockHeader = mkGenesisHeader (ProtocolMagic 0) +exampleGenesisBlockHeader = mkGenesisHeader pm (Left (GenesisHash prevHash)) (EpochIndex 11) exampleGenesisBody where prevHash = coerce (hash ("genesisHash" :: Text)) :: Hash a + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } -- We use `Nothing` as the ProxySKBlockInfo to avoid clashing key errors -- (since we use example keys which aren't related to each other) exampleMainBlockHeader :: MainBlockHeader -exampleMainBlockHeader = mkMainHeaderExplicit (ProtocolMagic 7) +exampleMainBlockHeader = mkMainHeaderExplicit pm exampleHeaderHash exampleChainDifficulty exampleSlotId @@ -332,6 +348,10 @@ exampleMainBlockHeader = mkMainHeaderExplicit (ProtocolMagic 7) Nothing exampleMainBody exampleMainExtraHeaderData + where + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 7 + , getRequiresNetworkMagic = RequiresNoMagic + } exampleMainProof :: MainProof exampleMainProof = MainProof exampleTxProof exampleSscProof diff --git a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs index a88b3fb3b8b..89e10c57d1f 100644 --- a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs +++ b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs @@ -21,7 +21,7 @@ import Pos.Chain.Block (BlockHeader (..), BlockSignature (..), GenesisBody (..), GenesisConsensusData (..), GenesisExtraHeaderData (..), MainBody (..), MainConsensusData (..), MainExtraHeaderData (..), - MainToSign (..), gbhProtocolMagic, headerHash, + MainToSign (..), gbhProtocolMagicId, headerHash, mkGenericBlockHeaderUnsafe, mkGenesisHeader, mkGenesisProof, mkMainHeader, mkMainProof) import qualified Pos.Chain.Block as Block @@ -30,9 +30,9 @@ import Pos.Chain.Genesis (GenesisHash (..)) import Pos.Core (EpochIndex (..), SlotId (..), difficultyL) import Pos.Core.Attributes (mkAttributes) import Pos.Core.Chrono (NewestFirst (..)) -import Pos.Crypto (ProtocolMagic (..), ProxySecretKey (pskIssuerPk), - SecretKey, SignTag (..), createPsk, proxySign, sign, - toPublic) +import Pos.Crypto (ProtocolMagicId (..), ProxySecretKey (pskIssuerPk), + SecretKey, SignTag (..), createPsk, getProtocolMagic, + proxySign, sign, toPublic) import Test.Pos.Chain.Block.Arbitrary as BT import Test.Pos.Chain.Genesis.Dummy (dummyGenesisHash) @@ -161,10 +161,10 @@ validateGoodMainHeader (BT.getHAndP -> (params, header)) = -- reason. validateBadProtocolMagicMainHeader :: BT.HeaderAndParams -> Bool validateBadProtocolMagicMainHeader (BT.getHAndP -> (params, header)) = - let protocolMagic' = ProtocolMagic (getProtocolMagic dummyProtocolMagic + 1) + let protocolMagicId' = ProtocolMagicId (getProtocolMagic dummyProtocolMagic + 1) header' = case header of - BlockHeaderGenesis h -> BlockHeaderGenesis (h & gbhProtocolMagic .~ protocolMagic') - BlockHeaderMain h -> BlockHeaderMain (h & gbhProtocolMagic .~ protocolMagic') + BlockHeaderGenesis h -> BlockHeaderGenesis (h & gbhProtocolMagicId .~ protocolMagicId') + BlockHeaderMain h -> BlockHeaderMain (h & gbhProtocolMagicId .~ protocolMagicId') in not $ isVerSuccess $ Block.verifyHeader dummyProtocolMagic params header' validateGoodHeaderChain :: BT.BlockHeaderList -> Bool diff --git a/chain/test/Test/Pos/Chain/Delegation/Example.hs b/chain/test/Test/Pos/Chain/Delegation/Example.hs index ce07145bbd0..928cede7b6d 100644 --- a/chain/test/Test/Pos/Chain/Delegation/Example.hs +++ b/chain/test/Test/Pos/Chain/Delegation/Example.hs @@ -14,7 +14,8 @@ import Data.List (zipWith4, (!!)) import Pos.Chain.Delegation (DlgUndo (..), HeavyDlgIndex (..), LightDlgIndices (..), ProxySKBlockInfo, ProxySKHeavy) import Pos.Core (EpochIndex (..)) -import Pos.Crypto (ProtocolMagic (..), safeCreatePsk) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..), safeCreatePsk) import Test.Pos.Core.ExampleHelpers (examplePublicKey, examplePublicKeys, exampleStakeholderId, @@ -25,7 +26,12 @@ staticHeavyDlgIndexes :: [HeavyDlgIndex] staticHeavyDlgIndexes = map (HeavyDlgIndex . EpochIndex) [5,1,3,27,99,247] staticProtocolMagics :: [ProtocolMagic] -staticProtocolMagics = map ProtocolMagic [0..5] +staticProtocolMagics = map mkPm [0..5] + where + mkPm :: Int32 -> ProtocolMagic + mkPm x = ProtocolMagic { getProtocolMagicId = ProtocolMagicId x + , getRequiresNetworkMagic = RequiresNoMagic + } staticProxySKHeavys :: [ProxySKHeavy] staticProxySKHeavys = zipWith4 safeCreatePsk diff --git a/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs b/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs index b947060955f..2929ffd8f7f 100644 --- a/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs @@ -7,13 +7,14 @@ -- | Arbitrary instances for core. module Test.Pos.Chain.Genesis.Arbitrary - ( + ( genGenesisData + , genGenesisProtocolConstants ) where import Universum import Data.Time.Units (Second, convertUnit) -import Test.QuickCheck (Arbitrary (..), choose, sized, suchThat) +import Test.QuickCheck (Arbitrary (..), Gen, choose, sized, suchThat) import Pos.Chain.Delegation (HeavyDlgIndex (..)) import Pos.Chain.Genesis @@ -22,7 +23,7 @@ import Pos.Chain.Update (BlockVersionData (..)) import Pos.Core (Timestamp (..), TxFeePolicy (..), maxCoinVal) import Pos.Core.ProtocolConstants (ProtocolConstants (..), VssMaxTTL (..), VssMinTTL (..)) -import Pos.Crypto (createPsk, toPublic) +import Pos.Crypto (ProtocolMagic, createPsk, toPublic) import Pos.Util.Util (leftToPanic) import Test.Pos.Chain.Ssc.Arbitrary () @@ -82,19 +83,28 @@ instance Arbitrary ProtocolConstants where ProtocolConstants <$> choose (1, 20000) <*> pure vssMin <*> pure vssMax instance Arbitrary GenesisProtocolConstants where - arbitrary = flip genesisProtocolConstantsFromProtocolConstants dummyProtocolMagic <$> arbitrary + arbitrary = genGenesisProtocolConstants arbitrary + +genGenesisProtocolConstants + :: Gen ProtocolMagic + -> Gen GenesisProtocolConstants +genGenesisProtocolConstants genPM = + genesisProtocolConstantsFromProtocolConstants <$> arbitrary <*> genPM instance Arbitrary GenesisData where - arbitrary = GenesisData + arbitrary = genGenesisData arbitrary + +genGenesisData :: Gen GenesisProtocolConstants -> Gen GenesisData +genGenesisData genGPC = + GenesisData <$> arbitrary <*> arbitrary <*> arbitraryStartTime <*> arbitraryVssCerts <*> arbitrary <*> arbitraryBVD - <*> arbitrary <*> arbitrary <*> arbitrary - where - -- System start time should be multiple of a second. - arbitraryStartTime = Timestamp . convertUnit @Second <$> arbitrary - -- Unknown tx fee policy in genesis is not ok. - arbitraryBVD = arbitrary `suchThat` hasKnownFeePolicy - hasKnownFeePolicy BlockVersionData {bvdTxFeePolicy = TxFeePolicyTxSizeLinear {}} = - True - hasKnownFeePolicy _ = False - arbitraryVssCerts = mkVssCertificatesMapLossy <$> arbitrary + <*> genGPC <*> arbitrary <*> arbitrary + where + -- System start time should be multiple of a second. + arbitraryStartTime = Timestamp . convertUnit @Second <$> arbitrary + -- Unknown tx fee policy in genesis is not ok. + arbitraryBVD = arbitrary `suchThat` hasKnownFeePolicy + hasKnownFeePolicy BlockVersionData {bvdTxFeePolicy = TxFeePolicyTxSizeLinear {}} = True + hasKnownFeePolicy _ = False + arbitraryVssCerts = mkVssCertificatesMapLossy <$> arbitrary diff --git a/chain/test/Test/Pos/Chain/Genesis/Dummy.hs b/chain/test/Test/Pos/Chain/Genesis/Dummy.hs index b4d5d75acd6..370eff744f9 100644 --- a/chain/test/Test/Pos/Chain/Genesis/Dummy.hs +++ b/chain/test/Test/Pos/Chain/Genesis/Dummy.hs @@ -49,7 +49,7 @@ dummyConfig :: Config dummyConfig = dummyConfigStartTime 0 dummyConfigStartTime :: Timestamp -> Config -dummyConfigStartTime = flip mkConfig dummyGenesisSpec +dummyConfigStartTime ts = mkConfig ts dummyGenesisSpec dummyProtocolConstants :: ProtocolConstants dummyProtocolConstants = ProtocolConstants diff --git a/chain/test/Test/Pos/Chain/Genesis/Example.hs b/chain/test/Test/Pos/Chain/Genesis/Example.hs index 714e181eb96..687c119c218 100644 --- a/chain/test/Test/Pos/Chain/Genesis/Example.hs +++ b/chain/test/Test/Pos/Chain/Genesis/Example.hs @@ -44,8 +44,9 @@ import Pos.Chain.Genesis (FakeAvvmOptions (..), import Pos.Core (Coin (..), CoinPortion (..), EpochIndex (..), Timestamp (..), VssMaxTTL (..), VssMinTTL (..), addressHash) -import Pos.Crypto (ProtocolMagic (..), ProxyCert (..), - ProxySecretKey (..), RedeemPublicKey, abstractHash, +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + ProxyCert (..), ProxySecretKey (..), RedeemPublicKey, + RequiresNetworkMagic (..), abstractHash, redeemDeterministicKeyGen) import Pos.Crypto.Signing (PublicKey (..), RedeemPublicKey (..)) @@ -271,21 +272,28 @@ exampleGenesisDelegation = UnsafeGenesisDelegation (HM.fromList exampleGenesisProtocolConstants0 :: GenesisProtocolConstants exampleGenesisProtocolConstants0 = GenesisProtocolConstants { gpcK = 37 - , gpcProtocolMagic = ProtocolMagic {getProtocolMagic = 1783847074} + , gpcProtocolMagic = ProtocolMagic (ProtocolMagicId 1783847074) + RequiresMagic , gpcVssMaxTTL = VssMaxTTL {getVssMaxTTL = 1477558317} , gpcVssMinTTL = VssMinTTL {getVssMinTTL = 744040476}} exampleGenesisProtocolConstants1 :: GenesisProtocolConstants exampleGenesisProtocolConstants1 = GenesisProtocolConstants { gpcK = 64 - , gpcProtocolMagic = ProtocolMagic {getProtocolMagic = 135977977} + , gpcProtocolMagic = ProtocolMagic + { getProtocolMagicId = ProtocolMagicId 135977977 + , getRequiresNetworkMagic = RequiresMagic + } , gpcVssMaxTTL = VssMaxTTL {getVssMaxTTL = 126106167} , gpcVssMinTTL = VssMinTTL {getVssMinTTL = 310228653}} exampleGenesisProtocolConstants2 :: GenesisProtocolConstants exampleGenesisProtocolConstants2 = GenesisProtocolConstants { gpcK = 2 - , gpcProtocolMagic = ProtocolMagic {getProtocolMagic = 1780893186} + , gpcProtocolMagic = ProtocolMagic + { getProtocolMagicId = ProtocolMagicId 1780893186 + , getRequiresNetworkMagic = RequiresMagic + } , gpcVssMaxTTL = VssMaxTTL {getVssMaxTTL = 402296078} , gpcVssMinTTL = VssMinTTL {getVssMinTTL = 1341799941}} diff --git a/chain/test/Test/Pos/Chain/Genesis/Json.hs b/chain/test/Test/Pos/Chain/Genesis/Json.hs index 7e99edc682c..4219f1ff0b3 100644 --- a/chain/test/Test/Pos/Chain/Genesis/Json.hs +++ b/chain/test/Test/Pos/Chain/Genesis/Json.hs @@ -20,7 +20,7 @@ import Test.Pos.Chain.Genesis.Gen (genGenesisAvvmBalances, genGenesisData, genGenesisDelegation, genGenesisInitializer, genGenesisProtocolConstants, genStaticConfig) -import Test.Pos.Core.ExampleHelpers (feedPM) +import Test.Pos.Core.ExampleHelpers (feedPM, feedPMWithRequiresMagic) import Test.Pos.Util.Golden (discoverGolden, eachOf, goldenTestCanonicalJSONDec, goldenTestJSON, goldenTestJSONDec) @@ -33,7 +33,7 @@ import Test.Pos.Util.Tripping (discoverRoundTrip, roundTripsAesonShow, -- Decode-only golden tests for ensuring that, when decoding the legacy -- `StaticConfig` JSON format, the `RequiresNetworkMagic` field defaults to --- `NMMustBeJust`. +-- `RequiresMagic`. golden_StaticConfig_GCSpec0Dec :: Property golden_StaticConfig_GCSpec0Dec = @@ -69,7 +69,7 @@ roundTripStaticConfig = -- Decode-only golden tests for ensuring that, when decoding the legacy -- `GenesisData` canonical JSON format, the `RequiresNetworkMagic` field --- defaults to `NMMustBeJust`. +-- defaults to `RequiresMagic`. golden_GenesisData0Dec :: Property golden_GenesisData0Dec = @@ -91,7 +91,7 @@ golden_GenesisDataDec2 = roundTripGenesisData :: Property roundTripGenesisData = - eachOf 100 (feedPM genGenesisData) roundTripsCanonicalJSONShow + eachOf 100 (feedPMWithRequiresMagic genGenesisData) roundTripsCanonicalJSONShow -------------------------------------------------------------------------------- -- GenesisAvvmBalances @@ -115,7 +115,7 @@ roundTripGenesisDelegation = -- Decode-only golden tests for ensuring that, when decoding the legacy -- `GenesisProtocolConstants` JSON format, the `RequiresNetworkMagic` field --- defaults to `NMMustBeJust`. +-- defaults to `RequiresMagic`. golden_GenesisProtocolConstants0Dec :: Property golden_GenesisProtocolConstants0Dec = diff --git a/chain/test/Test/Pos/Chain/Ssc/Example.hs b/chain/test/Test/Pos/Chain/Ssc/Example.hs index 429dc8f1a5b..8a594442df2 100644 --- a/chain/test/Test/Pos/Chain/Ssc/Example.hs +++ b/chain/test/Test/Pos/Chain/Ssc/Example.hs @@ -31,8 +31,9 @@ import Pos.Chain.Ssc (Commitment, CommitmentSignature, CommitmentsMap, mkVssCertificate, mkVssCertificatesMap, randCommitmentAndOpening) import Pos.Core (EpochIndex (..), addressHash) -import Pos.Crypto (EncShare (..), ProtocolMagic (..), Secret (..), - SecretProof (..), SignTag (..), VssKeyPair, +import Pos.Crypto (EncShare (..), ProtocolMagic (..), + ProtocolMagicId (..), RequiresNetworkMagic (..), + Secret (..), SecretProof (..), SignTag (..), VssKeyPair, VssPublicKey (..), decryptShare, deterministic, deterministicVssKeyGen, hash, sign, toVssPublicKey) @@ -56,7 +57,9 @@ exampleCommitmentOpening = exampleCommitmentSignature :: CommitmentSignature exampleCommitmentSignature = sign - (ProtocolMagic 0) + (ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + }) SignForTestingOnly exampleSecretKey (exampleEpochIndex, exampleCommitment) @@ -140,7 +143,9 @@ exampleVssPublicKey = toVssPublicKey mkVssKeyPair exampleVssCertificate :: VssCertificate exampleVssCertificate = mkVssCertificate - (ProtocolMagic 0) + (ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + }) exampleSecretKey (asBinary (toVssPublicKey $ deterministicVssKeyGen ("golden" :: ByteString))) (EpochIndex 11) @@ -150,7 +155,9 @@ exampleVssCertificates offset num = map vssCert [0..num-1] where secretKeyList = (exampleSecretKeys offset num) vssCert index = mkVssCertificate - (ProtocolMagic 0) + (ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + }) (secretKeyList !! index) (asBinary (toVssPublicKey $ deterministicVssKeyGen (getBytes index 128))) (EpochIndex 122) diff --git a/chain/test/Test/Pos/Chain/Txp/Bi.hs b/chain/test/Test/Pos/Chain/Txp/Bi.hs index cd868977add..b38c0c866b9 100644 --- a/chain/test/Test/Pos/Chain/Txp/Bi.hs +++ b/chain/test/Test/Pos/Chain/Txp/Bi.hs @@ -20,7 +20,8 @@ import Pos.Chain.Txp (Tx (..), TxAux (..), TxIn (..), TxSigData (..)) import Pos.Core.Attributes (Attributes (..), mkAttributes) import Pos.Core.Common (AddrAttributes (..), Script (..)) -import Pos.Crypto (ProtocolMagic (..), SignTag (..), Signature, sign) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..), SignTag (..), Signature, sign) import Test.Pos.Binary.Helpers (SizeTestConfig (..), scfg, sizeTest) import Test.Pos.Binary.Helpers.GoldenRoundTrip (goldenTestBi, @@ -201,8 +202,11 @@ roundTripTxProof = eachOf 50 (feedPM genTxProof) roundTripsBiBuildable golden_TxSig :: Property golden_TxSig = goldenTestBi txSigGold "test/golden/TxSig" where - txSigGold = sign (ProtocolMagic 0) SignForTestingOnly + txSigGold = sign pm SignForTestingOnly exampleSecretKey exampleTxSigData + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } roundTripTxSig :: Property roundTripTxSig = eachOf 50 (feedPM genTxSig) roundTripsBiBuildable @@ -231,7 +235,9 @@ sizeEstimates :: H.Group sizeEstimates = let check :: (Show a, Bi a) => Gen a -> Property check g = sizeTest $ scfg { gen = g } - pm = ProtocolMagic 0 + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } knownTxIn (TxInUnknown _ _) = False knownTxIn _ = True diff --git a/chain/test/Test/Pos/Chain/Txp/Example.hs b/chain/test/Test/Pos/Chain/Txp/Example.hs index b42cf5d4593..5d591220130 100644 --- a/chain/test/Test/Pos/Chain/Txp/Example.hs +++ b/chain/test/Test/Pos/Chain/Txp/Example.hs @@ -31,13 +31,13 @@ import Pos.Core.Attributes (mkAttributes) import Pos.Core.Common (Coin (..), IsBootstrapEraAddr (..), makePubKeyAddress) import Pos.Core.Merkle (mkMerkleTree, mtRoot) -import Pos.Crypto (AbstractHash (..), Hash, ProtocolMagic (..), - PublicKey (..), RedeemSignature, SignTag (..), hash, +import Pos.Crypto (AbstractHash (..), Hash, PublicKey (..), + RedeemSignature, SignTag (..), hash, redeemDeterministicKeyGen, redeemSign, sign) import Test.Pos.Core.ExampleHelpers (examplePublicKey, exampleSecretKey) -import Test.Pos.Crypto.Bi (getBytes) +import Test.Pos.Crypto.Bi (exampleProtocolMagic, getBytes) exampleTxAux :: TxAux exampleTxAux = TxAux tx exampleTxWitness @@ -74,7 +74,7 @@ exampleTxProof = TxProof 32 mroot hashWit hashWit = hash $ [(V.fromList [(PkWitness examplePublicKey exampleTxSig)])] exampleTxSig :: TxSig -exampleTxSig = sign (ProtocolMagic 0) SignForTestingOnly exampleSecretKey exampleTxSigData +exampleTxSig = sign exampleProtocolMagic SignForTestingOnly exampleSecretKey exampleTxSigData exampleTxSigData :: TxSigData exampleTxSigData = TxSigData exampleHashTx @@ -86,7 +86,7 @@ exampleTxWitness :: TxWitness exampleTxWitness = V.fromList [(PkWitness examplePublicKey exampleTxSig)] exampleRedeemSignature :: RedeemSignature TxSigData -exampleRedeemSignature = redeemSign (ProtocolMagic 0) SignForTestingOnly rsk exampleTxSigData +exampleRedeemSignature = redeemSign exampleProtocolMagic SignForTestingOnly rsk exampleTxSigData where rsk = fromJust (snd <$> redeemDeterministicKeyGen (getBytes 0 32)) diff --git a/chain/test/Test/Pos/Chain/Update/Example.hs b/chain/test/Test/Pos/Chain/Update/Example.hs index 1f2c71b2be9..29c2a494a88 100644 --- a/chain/test/Test/Pos/Chain/Update/Example.hs +++ b/chain/test/Test/Pos/Chain/Update/Example.hs @@ -38,7 +38,8 @@ import Pos.Chain.Update (ApplicationName (..), BlockVersion (..), import Pos.Core (Coeff (..), CoinPortion (..), EpochIndex (..), FlatSlotId, ScriptVersion, TxFeePolicy (..), TxSizeLinear (..)) -import Pos.Crypto (ProtocolMagic (..), hash) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..), hash) import Test.Pos.Core.ExampleHelpers (exampleAttributes, examplePublicKey, exampleSafeSigner, exampleSlottingData, @@ -226,7 +227,9 @@ exampleUpdateProposalToSign :: UpdateProposalToSign ( mkUpdateProposalWSign pm bv bvm sv hm ua ss , UpdateProposalToSign bv bvm sv hm ua ) where - pm = ProtocolMagic 0 + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } bv = exampleBlockVersion bvm = exampleBlockVersionModifier sv = exampleSoftwareVersion @@ -237,7 +240,9 @@ exampleUpdateProposalToSign :: UpdateProposalToSign exampleUpdateVote :: UpdateVote exampleUpdateVote = mkUpdateVoteSafe pm ss ui ar where - pm = ProtocolMagic 0 + pm = ProtocolMagic { getProtocolMagicId = ProtocolMagicId 0 + , getRequiresNetworkMagic = RequiresNoMagic + } ss = exampleSafeSigner 0 ui = exampleUpId ar = True diff --git a/core/test/Test/Pos/Core/ExampleHelpers.hs b/core/test/Test/Pos/Core/ExampleHelpers.hs index f63868f9a89..c5f46d36c0a 100644 --- a/core/test/Test/Pos/Core/ExampleHelpers.hs +++ b/core/test/Test/Pos/Core/ExampleHelpers.hs @@ -36,6 +36,7 @@ module Test.Pos.Core.ExampleHelpers -- Helpers , feedPM + , feedPMWithRequiresMagic , feedPC , feedPMC , feedEpochSlots @@ -66,14 +67,15 @@ import Pos.Core.Slotting (EpochIndex (..), EpochSlottingData (..), LocalSlotIndex (..), SlotCount, SlotId (..), SlottingData, createSlottingDataUnsafe) import Pos.Crypto (HDAddressPayload (..), ProtocolMagic (..), - RedeemPublicKey, SafeSigner (..), SecretKey (..), - VssPublicKey (..), abstractHash, deterministicVssKeyGen, + RedeemPublicKey, RequiresNetworkMagic (..), + SafeSigner (..), SecretKey (..), VssPublicKey (..), + abstractHash, deterministicVssKeyGen, redeemDeterministicKeyGen, toVssPublicKey) import Pos.Crypto.Signing (PublicKey (..)) import Test.Pos.Core.Gen (genProtocolConstants) import Test.Pos.Crypto.Bi (getBytes) -import Test.Pos.Crypto.Gen (genProtocolMagic) +import Test.Pos.Crypto.Gen (genProtocolMagic, genProtocolMagicId) {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} @@ -84,6 +86,11 @@ import Test.Pos.Crypto.Gen (genProtocolMagic) feedPM :: (ProtocolMagic -> H.Gen a) -> H.Gen a feedPM genA = genA =<< genProtocolMagic +feedPMWithRequiresMagic :: (ProtocolMagic -> H.Gen a) -> H.Gen a +feedPMWithRequiresMagic genA = do + pm <- flip ProtocolMagic RequiresMagic <$> genProtocolMagicId + genA pm + feedPC :: (ProtocolConstants -> H.Gen a) -> H.Gen a feedPC genA = genA =<< genProtocolConstants diff --git a/core/test/Test/Pos/Core/SafeCopy.hs b/core/test/Test/Pos/Core/SafeCopy.hs index bfe43385e79..874772acc81 100644 --- a/core/test/Test/Pos/Core/SafeCopy.hs +++ b/core/test/Test/Pos/Core/SafeCopy.hs @@ -17,7 +17,7 @@ import Test.Pos.Util.Golden (discoverGolden, goldenTestSafeCopyDec) -- Decode-only golden tests for ensuring that, when decoding the legacy -- `Address` `SafeCopy` format, the `RequiresNetworkMagic` field defaults to --- `NMMustBeNothing`. +-- `RequiresNoMagic`. golden_Address0 :: Property golden_Address0 = @@ -55,7 +55,7 @@ golden_Address4 = -- Decode-only golden tests for ensuring that, when decoding the legacy -- `Address'` `SafeCopy` format, the `RequiresNetworkMagic` field defaults to --- `NMMustBeNothing`. +-- `RequiresNoMagic`. golden_Address'0 :: Property golden_Address'0 = diff --git a/crypto/Pos/Crypto/Configuration.hs b/crypto/Pos/Crypto/Configuration.hs index 4e31b160866..666bb21a88c 100644 --- a/crypto/Pos/Crypto/Configuration.hs +++ b/crypto/Pos/Crypto/Configuration.hs @@ -1,20 +1,170 @@ +{-# LANGUAGE OverloadedStrings #-} + module Pos.Crypto.Configuration ( ProtocolMagic (..) + , ProtocolMagicId (..) + , RequiresNetworkMagic (..) + , getProtocolMagic ) where import Universum -import Data.Aeson (FromJSON (..), ToJSON (..)) +import Control.Monad.Except (MonadError) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as A +import Data.Aeson.Types (typeMismatch) +import Data.List (lookup) import Data.SafeCopy (base, deriveSafeCopySimple) +import Text.JSON.Canonical (FromJSON (..), JSValue (..), ToJSON (..), + expected) + +import Pos.Util.Json.Canonical (SchemaError) +import Pos.Util.Util (toAesonError) + + +-------------------------------------------------------------------------------- +-- RequiresNetworkMagic +-------------------------------------------------------------------------------- + +-- | Bool-isomorphic flag indicating whether we're on testnet +-- or mainnet/staging. +data RequiresNetworkMagic + = RequiresNoMagic + | RequiresMagic + deriving (Show, Eq, Generic) + +instance NFData RequiresNetworkMagic +deriveSafeCopySimple 0 'base ''RequiresNetworkMagic + +-- Aeson JSON instances +-- N.B @RequiresNetworkMagic@'s ToJSON & FromJSON instances do not round-trip. +-- They should only be used from a parent instance which handles the +-- `requiresNetworkMagic` key. +instance A.ToJSON RequiresNetworkMagic where + toJSON RequiresNoMagic = A.String "RequiresNoMagic" + toJSON RequiresMagic = A.String "RequiresMagic" + +instance A.FromJSON RequiresNetworkMagic where + parseJSON = A.withText "requiresNetworkMagic" $ toAesonError . \case + "RequiresNoMagic" -> Right RequiresNoMagic + "RequiresMagic" -> Right RequiresMagic + "NMMustBeNothing" -> Right RequiresNoMagic + "NMMustBeJust" -> Right RequiresMagic + other -> Left ("invalid value " <> show other <> + ", acceptable values are RequiresNoMagic | RequiresMagic") + +-- Canonical JSON instances +instance Monad m => ToJSON m RequiresNetworkMagic where + toJSON RequiresNoMagic = pure (JSString "RequiresNoMagic") + toJSON RequiresMagic = pure (JSString "RequiresMagic") + +instance MonadError SchemaError m => FromJSON m RequiresNetworkMagic where + fromJSON = \case + (JSString "RequiresNoMagic") -> pure RequiresNoMagic + (JSString "RequiresMagic") -> pure RequiresMagic + other -> + expected "RequiresNoMagic | RequiresMagic" (Just (show other)) + + +-------------------------------------------------------------------------------- +-- ProtocolMagic +-------------------------------------------------------------------------------- + +newtype ProtocolMagicId = ProtocolMagicId + { unProtocolMagicId :: Int32 + } deriving (Show, Eq, NFData) + +deriveSafeCopySimple 0 'base ''ProtocolMagicId -- | Magic number which should differ for different clusters. It's -- defined here, because it's used for signing. It also used for other -- things (e. g. it's part of a serialized block). -newtype ProtocolMagic = ProtocolMagic - { getProtocolMagic :: Int32 - } deriving (Show, Eq, NFData) +-- +-- mhueschen: As part of CO-353 I am adding `getRequiresNetworkMagic` in +-- order to pipe configuration to functions which must generate & verify +-- Addresses (which now must be aware of `NetworkMagic`). +data ProtocolMagic = ProtocolMagic + { getProtocolMagicId :: !ProtocolMagicId + , getRequiresNetworkMagic :: !RequiresNetworkMagic + } deriving (Eq, Show, Generic) -deriving instance ToJSON ProtocolMagic -deriving instance FromJSON ProtocolMagic +-- mhueschen: For backwards-compatibility reasons, I redefine this function +-- in terms of the two record accessors. +getProtocolMagic :: ProtocolMagic -> Int32 +getProtocolMagic = unProtocolMagicId . getProtocolMagicId +instance NFData ProtocolMagic deriveSafeCopySimple 0 'base ''ProtocolMagic + +instance A.ToJSON ProtocolMagic where + toJSON (ProtocolMagic (ProtocolMagicId ident) rnm) = + A.object ["pm" .= ident, "requiresNetworkMagic" .= rnm] + +-- Here we default to `RequiresMagic` (what testnets use) if only +-- a ProtocolMagic identifier is provided. +instance A.FromJSON ProtocolMagic where + parseJSON v@(A.Number _) = ProtocolMagic + <$> (ProtocolMagicId <$> A.parseJSON v) + <*> pure RequiresMagic + parseJSON (A.Object o) = ProtocolMagic + <$> (ProtocolMagicId <$> o .: "pm") + <*> o .: "requiresNetworkMagic" + parseJSON invalid = typeMismatch "ProtocolMagic" invalid + +-- Canonical JSON instances +instance Monad m => ToJSON m ProtocolMagic where + -- | We only output the `ProtocolMagicId` such that we don't alter the + -- resulting hash digest of the genesis block. + -- + -- In the function, `withCoreConfigurations`, we compare the hash of the + -- canonical JSON representation of a hardcoded genesis block with an + -- accompanying hardcoded hash of that same genesis block at its inception + -- (both of which can be found in lib/configuration.yaml). This allows us + -- to verify the integrity of the genesis block and ensure that it hasn't + -- been altered. + -- + -- As a result of this addition of the `RequiresNetworkMagic` field to + -- `ProtocolMagic`, we cannot include the newly introduced + -- `RequiresNetworkMagic` field of `ProtocolMagic` as it would produce + -- invalid hashes for previously existing genesis blocks. + -- + -- See the implementation of `withCoreConfigurations` for more detail on + -- how this works. + toJSON (ProtocolMagic (ProtocolMagicId ident) _rnm) = toJSON ident + +-- Here we default to `RequiresMagic` (what testnets use) if only +-- a ProtocolMagic identifier is provided. +instance MonadError SchemaError m => FromJSON m ProtocolMagic where + fromJSON = \case + (JSNum n) -> pure (ProtocolMagic (ProtocolMagicId (fromIntegral n)) + RequiresMagic) + (JSObject dict) -> ProtocolMagic + <$> (ProtocolMagicId <$> expectLookup "pm: " "pm" dict) + <*> expectLookup "requiresNetworkMagic: " + "requiresNetworkMagic" + dict + other -> + expected "RequiresNoMagic | RequiresMagic" (Just (show other)) + +expectLookup :: (MonadError SchemaError m, FromJSON m a) + => String -> String -> [(String, JSValue)] -> m a +expectLookup msg key dict = case lookup key dict of + Nothing -> expected msg Nothing + Just x -> fromJSON x + +{- +We need to handle the old format (YAML example): + +``` +protocolMagic: 12345678 +``` + +and the new format + +``` +protocolMagic: + pm: 12345678 + requiresNetworkMagic: RequiresNoMagic +``` +-} diff --git a/crypto/Pos/Crypto/Signing/Tag.hs b/crypto/Pos/Crypto/Signing/Tag.hs index f86de1db3bf..4e4f2482d05 100644 --- a/crypto/Pos/Crypto/Signing/Tag.hs +++ b/crypto/Pos/Crypto/Signing/Tag.hs @@ -6,7 +6,7 @@ module Pos.Crypto.Signing.Tag import Universum import qualified Pos.Binary.Class as Bi -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic, getProtocolMagic) import Pos.Crypto.Signing.Types.Tag -- | Get magic bytes corresponding to a 'SignTag'. Guaranteed to be different diff --git a/crypto/test/Test/Pos/Crypto/Arbitrary.hs b/crypto/test/Test/Pos/Crypto/Arbitrary.hs index 6cbccb33a9c..2f0cf183517 100644 --- a/crypto/test/Test/Pos/Crypto/Arbitrary.hs +++ b/crypto/test/Test/Pos/Crypto/Arbitrary.hs @@ -10,6 +10,7 @@ module Test.Pos.Crypto.Arbitrary , genSignature , genSignatureEncoded , genRedeemSignature + , genProtocolMagicUniformWithRNM ) where import Universum hiding (keys) @@ -17,12 +18,14 @@ import Universum hiding (keys) import Control.Monad (zipWithM) import qualified Data.ByteArray as ByteArray import Data.List.NonEmpty (fromList) -import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof, vector) +import Test.QuickCheck (Arbitrary (..), Gen, choose, elements, oneof, + vector) import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) import Pos.Binary.Class (AsBinary (..), AsBinaryClass (..), Bi, Raw) -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic (..), + ProtocolMagicId (..), RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (AHash (..), AbstractHash (..), HashAlgorithm, WithHash (..), unsafeCheatingHashCoerce, withHash) @@ -47,7 +50,21 @@ import Test.Pos.Util.Orphans () import Test.Pos.Util.QuickCheck.Arbitrary (Nonrepeating (..), arbitraryUnsafe, runGen, sublistN) -deriving instance Arbitrary ProtocolMagic +instance Arbitrary ProtocolMagic where + arbitrary = ProtocolMagic <$> arbitrary + <*> arbitrary + +instance Arbitrary ProtocolMagicId where + arbitrary = ProtocolMagicId <$> arbitrary + +instance Arbitrary RequiresNetworkMagic where + arbitrary = elements [RequiresNoMagic, RequiresMagic] + +genProtocolMagicUniformWithRNM :: RequiresNetworkMagic -> Gen ProtocolMagic +genProtocolMagicUniformWithRNM rnm = + (\ident -> ProtocolMagic (ProtocolMagicId ident) rnm) + <$> + choose (minBound, maxBound) {- A note on 'Arbitrary' instances ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/crypto/test/Test/Pos/Crypto/Bi.hs b/crypto/test/Test/Pos/Crypto/Bi.hs index e430f3c7be8..35b5aa79d23 100644 --- a/crypto/test/Test/Pos/Crypto/Bi.hs +++ b/crypto/test/Test/Pos/Crypto/Bi.hs @@ -4,6 +4,7 @@ module Test.Pos.Crypto.Bi ( constantByteString + , exampleProtocolMagic , getBytes , tests ) where @@ -23,8 +24,9 @@ import qualified Hedgehog as H import Pos.Binary.Class (Bi) import Pos.Crypto (AbstractHash, EncShare, PassPhrase, - ProtocolMagic (..), ProxyCert, ProxySecretKey, - PublicKey (..), RedeemSignature, SafeSigner (FakeSigner), + ProtocolMagic (..), ProtocolMagicId (..), ProxyCert, + ProxySecretKey, PublicKey (..), RedeemSignature, + RequiresNetworkMagic (..), SafeSigner (FakeSigner), Secret, SecretKey (..), SecretProof, SignTag (SignForTestingOnly), Signature, VssKeyPair, WithHash, decryptShare, deriveHDPassphrase, deterministic, @@ -82,7 +84,7 @@ golden_Signature :: Property golden_Signature = goldenTestBi sig "test/golden/Signature" where Right skey = SecretKey <$> xprv (getBytes 10 128) - sig = sign (ProtocolMagic 0) SignForTestingOnly skey () + sig = sign exampleProtocolMagic SignForTestingOnly skey () genUnitSignature :: Gen (Signature ()) genUnitSignature = do pm <- genProtocolMagic @@ -102,7 +104,7 @@ golden_Signed :: Property golden_Signed = goldenTestBi signed "test/golden/Signed" where Right skey = SecretKey <$> xprv (getBytes 10 128) - signed = mkSigned (ProtocolMagic 0) SignForTestingOnly skey () + signed = mkSigned exampleProtocolMagic SignForTestingOnly skey () roundTripSignedBi :: Property roundTripSignedBi = eachOf 1000 genUnitSigned roundTripsBiShow @@ -161,7 +163,7 @@ golden_RedeemSignature :: Property golden_RedeemSignature = goldenTestBi rsig "test/golden/RedeemSignature" where Just rsk = snd <$> redeemDeterministicKeyGen (getBytes 0 32) - rsig = redeemSign (ProtocolMagic 0) SignForTestingOnly rsk () + rsig = redeemSign exampleProtocolMagic SignForTestingOnly rsk () genUnitRedeemSignature :: Gen (RedeemSignature ()) genUnitRedeemSignature = do pm <- genProtocolMagic @@ -195,7 +197,7 @@ golden_ProxyCert = goldenTestBi pcert "test/golden/ProxyCert" where Right pkey = PublicKey <$> xpub (getBytes 0 64) Right skey = SecretKey <$> xprv (getBytes 10 128) - pcert = safeCreateProxyCert (ProtocolMagic 0) (FakeSigner skey) pkey () + pcert = safeCreateProxyCert exampleProtocolMagic (FakeSigner skey) pkey () genUnitProxyCert :: Gen (ProxyCert ()) genUnitProxyCert = do pm <- genProtocolMagic @@ -216,7 +218,7 @@ golden_ProxySecretKey = goldenTestBi psk "test/golden/ProxySecretKey" where Right pkey = PublicKey <$> xpub (getBytes 0 64) Right skey = SecretKey <$> xprv (getBytes 10 128) - psk = safeCreatePsk (ProtocolMagic 0) (FakeSigner skey) pkey () + psk = safeCreatePsk exampleProtocolMagic (FakeSigner skey) pkey () genUnitProxySecretKey :: Gen (ProxySecretKey ()) genUnitProxySecretKey = do pm <- genProtocolMagic @@ -238,8 +240,8 @@ golden_ProxySignature :: Property golden_ProxySignature = goldenTestBi psig "test/golden/ProxySignature" where Right skey = SecretKey <$> xprv (getBytes 10 128) - psk = safeCreatePsk (ProtocolMagic 0) (FakeSigner skey) (toPublic skey) () - psig = proxySign (ProtocolMagic 0) SignForTestingOnly skey psk () + psk = safeCreatePsk exampleProtocolMagic (FakeSigner skey) (toPublic skey) () + psig = proxySign exampleProtocolMagic SignForTestingOnly skey psk () roundTripProxySignatureBi :: Property roundTripProxySignatureBi = eachOf 100 @@ -396,6 +398,9 @@ constantByteString \zFfuRDKvdrL6sDkuPNPYqxMWlqnXjSbU0eLtceZuKgXLHR8cdvsEvywt4JaZUQhnbq3Vl\ \7nZqcXdoi4XGTCgSGcGp8N0SDVhvkVh0QF1RVpWPnOMyYISJvuaHfo1zXMdq9tEdtJfID" +exampleProtocolMagic :: ProtocolMagic +exampleProtocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic + -------------------------------------------------------------------------------- sizeEstimates :: H.Group @@ -416,7 +421,7 @@ sizeEstimates = let check :: forall a. (Show a, Bi a) => Gen a -> Property check @(AbstractHash SHA1 PublicKey) $ genAbstractHash genPublicKey) , ("RedeemPublicKey", check genRedeemPublicKey) , ("RedeemSecretKey", check genRedeemSecretKey) - , ("RedeemSignature PublicKey", check (genRedeemSignature (ProtocolMagic 0) genPublicKey)) + , ("RedeemSignature PublicKey", check (genRedeemSignature exampleProtocolMagic genPublicKey)) ] -------------------------------------------------------------------------------- diff --git a/crypto/test/Test/Pos/Crypto/Dummy.hs b/crypto/test/Test/Pos/Crypto/Dummy.hs index 787fd8f1d27..0ef7084f539 100644 --- a/crypto/test/Test/Pos/Crypto/Dummy.hs +++ b/crypto/test/Test/Pos/Crypto/Dummy.hs @@ -2,9 +2,18 @@ module Test.Pos.Crypto.Dummy ( dummyProtocolMagic + , dummyProtocolMagicId + , dummyRequiresNetworkMagic ) where -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) dummyProtocolMagic :: ProtocolMagic -dummyProtocolMagic = ProtocolMagic 55550001 +dummyProtocolMagic = ProtocolMagic dummyProtocolMagicId RequiresNoMagic + +dummyProtocolMagicId :: ProtocolMagicId +dummyProtocolMagicId = ProtocolMagicId 55550001 + +dummyRequiresNetworkMagic :: RequiresNetworkMagic +dummyRequiresNetworkMagic = RequiresNoMagic diff --git a/crypto/test/Test/Pos/Crypto/Example.hs b/crypto/test/Test/Pos/Crypto/Example.hs index 276c10caf5a..0bc78a3b50e 100644 --- a/crypto/test/Test/Pos/Crypto/Example.hs +++ b/crypto/test/Test/Pos/Crypto/Example.hs @@ -2,19 +2,29 @@ module Test.Pos.Crypto.Example ( exampleProtocolMagic0 , exampleProtocolMagic1 , exampleProtocolMagic2 + , exampleProtocolMagic3 + , exampleProtocolMagic4 ) where -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) -------------------------------------------------------------------------------- -- Example golden datatypes -------------------------------------------------------------------------------- exampleProtocolMagic0 :: ProtocolMagic -exampleProtocolMagic0 = ProtocolMagic 31337 +exampleProtocolMagic0 = ProtocolMagic (ProtocolMagicId 31337) RequiresMagic exampleProtocolMagic1 :: ProtocolMagic -exampleProtocolMagic1 = ProtocolMagic 2147000001 +exampleProtocolMagic1 = ProtocolMagic (ProtocolMagicId 2147000001) RequiresMagic exampleProtocolMagic2 :: ProtocolMagic -exampleProtocolMagic2 = ProtocolMagic (- 58952) +exampleProtocolMagic2 = ProtocolMagic (ProtocolMagicId (- 58952)) RequiresMagic + +exampleProtocolMagic3 :: ProtocolMagic +exampleProtocolMagic3 = ProtocolMagic (ProtocolMagicId (31337)) RequiresMagic + +exampleProtocolMagic4 :: ProtocolMagic +exampleProtocolMagic4 = ProtocolMagic (ProtocolMagicId (- 500)) RequiresNoMagic + diff --git a/crypto/test/Test/Pos/Crypto/Gen.hs b/crypto/test/Test/Pos/Crypto/Gen.hs index d25f651ea92..472362b43d4 100644 --- a/crypto/test/Test/Pos/Crypto/Gen.hs +++ b/crypto/test/Test/Pos/Crypto/Gen.hs @@ -2,6 +2,7 @@ module Test.Pos.Crypto.Gen ( -- Protocol Magic Generator genProtocolMagic + , genProtocolMagicId -- Sign Tag Generator , genSignTag @@ -64,7 +65,8 @@ import qualified Hedgehog.Range as Range import Pos.Binary.Class (Bi) import Pos.Crypto (PassPhrase) -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic (..), + ProtocolMagicId (..), RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (AbstractHash (..), HashAlgorithm, WithHash, abstractHash, withHash) import Pos.Crypto.HD (HDAddressPayload (..), HDPassphrase (..)) @@ -86,7 +88,14 @@ import Pos.Crypto.Signing.Redeem (RedeemPublicKey, RedeemSecretKey, ---------------------------------------------------------------------------- genProtocolMagic :: Gen ProtocolMagic -genProtocolMagic = ProtocolMagic <$> (Gen.int32 Range.constantBounded) +genProtocolMagic = ProtocolMagic <$> genProtocolMagicId + <*> genRequiresNetworkMagic + +genProtocolMagicId :: Gen ProtocolMagicId +genProtocolMagicId = ProtocolMagicId <$> Gen.int32 Range.constantBounded + +genRequiresNetworkMagic :: Gen RequiresNetworkMagic +genRequiresNetworkMagic = Gen.element [RequiresNoMagic, RequiresMagic] ---------------------------------------------------------------------------- -- Sign Tag Generator diff --git a/crypto/test/Test/Pos/Crypto/Json.hs b/crypto/test/Test/Pos/Crypto/Json.hs index 3762f28f35b..fd172a2b239 100644 --- a/crypto/test/Test/Pos/Crypto/Json.hs +++ b/crypto/test/Test/Pos/Crypto/Json.hs @@ -6,7 +6,8 @@ import Hedgehog (Property) import qualified Hedgehog as H import Test.Pos.Crypto.Example (exampleProtocolMagic0, - exampleProtocolMagic1, exampleProtocolMagic2) + exampleProtocolMagic1, exampleProtocolMagic2, + exampleProtocolMagic3, exampleProtocolMagic4) import Test.Pos.Util.Golden (discoverGolden, goldenTestJSONDec) -------------------------------------------------------------------------------- @@ -15,7 +16,7 @@ import Test.Pos.Util.Golden (discoverGolden, goldenTestJSONDec) -- Decode-only golden tests for ensuring that, when decoding the legacy -- `ProtocolMagic` JSON format, the `RequiresNetworkMagic` field defaults to --- `NMMustBeJust`. +-- `RequiresMagic`. golden_ProtocolMagic0AesonDec :: Property golden_ProtocolMagic0AesonDec = @@ -35,5 +36,20 @@ golden_ProtocolMagic2AesonDec = exampleProtocolMagic2 "test/golden/json/ProtocolMagic2_Legacy_HasNetworkMagic" +-- Legacy JSON encoding where requiresNetworkMagic was +-- encoded as "NMMustBeNothing" or "NMMustBeJust" + +golden_ProtocolMagic3AesonDec_NMMustBeJust :: Property +golden_ProtocolMagic3AesonDec_NMMustBeJust = + goldenTestJSONDec + exampleProtocolMagic3 + "test/golden/json/ProtocolMagic_Legacy_NMMustBeJust" + +golden_ProtocolMagic4AesonDec_NMMustBeNothing :: Property +golden_ProtocolMagic4AesonDec_NMMustBeNothing = + goldenTestJSONDec + exampleProtocolMagic4 + "test/golden/json/ProtocolMagic_Legacy_NMMustBeNothing" + tests :: IO Bool tests = H.checkSequential $$discoverGolden diff --git a/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeJust b/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeJust new file mode 100644 index 00000000000..12c352378ff --- /dev/null +++ b/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeJust @@ -0,0 +1 @@ +{"pm":31337,"requiresNetworkMagic":"NMMustBeJust"} \ No newline at end of file diff --git a/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeNothing b/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeNothing new file mode 100644 index 00000000000..7afb7c11db7 --- /dev/null +++ b/crypto/test/golden/json/ProtocolMagic_Legacy_NMMustBeNothing @@ -0,0 +1 @@ +{"pm":-500,"requiresNetworkMagic":"NMMustBeNothing"} \ No newline at end of file diff --git a/infra/src/Pos/Infra/Reporting/Http.hs b/infra/src/Pos/Infra/Reporting/Http.hs index 4322cfca3b5..67c0febbfc0 100644 --- a/infra/src/Pos/Infra/Reporting/Http.hs +++ b/infra/src/Pos/Infra/Reporting/Http.hs @@ -26,8 +26,7 @@ import System.FilePath (takeFileName) import System.Info (arch, os) import Paths_cardano_sl_infra (version) -import Pos.Core.Reporting () -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), getProtocolMagic) import Pos.Infra.Reporting.Exceptions (ReportingError (..)) import Pos.Util.CompileInfo (CompileTimeInfo) import Pos.Util.Trace (Severity (..), Trace, traceWith) diff --git a/lib/bench/Bench/Configuration.hs b/lib/bench/Bench/Configuration.hs index 230af053e87..8c83f360dba 100644 --- a/lib/bench/Bench/Configuration.hs +++ b/lib/bench/Bench/Configuration.hs @@ -5,7 +5,8 @@ module Bench.Configuration import Pos.Core (ProtocolConstants (..), VssMaxTTL (..), VssMinTTL (..)) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) benchProtocolConstants :: ProtocolConstants benchProtocolConstants = ProtocolConstants @@ -15,4 +16,4 @@ benchProtocolConstants = ProtocolConstants } benchProtocolMagic :: ProtocolMagic -benchProtocolMagic = ProtocolMagic 55550001 +benchProtocolMagic = ProtocolMagic (ProtocolMagicId 55550001) RequiresNoMagic diff --git a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs index 0b14cc348bd..d4b1a1f076f 100644 --- a/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs +++ b/lib/bench/Bench/Pos/Diffusion/BlockDownload.hs @@ -36,7 +36,8 @@ import qualified Pos.Chain.Block as Block (getBlockHeader) import Pos.Chain.Update (BlockVersion (..)) import Pos.Core.Chrono (NewestFirst (..), OldestFirst (..)) import Pos.Core.ProtocolConstants (ProtocolConstants (..)) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (Hash, unsafeMkAbstractHash) import Pos.DB.Class (Serialized (..), SerializedBlock) import Pos.Diffusion.Full (FullDiffusionConfiguration (..), @@ -64,7 +65,7 @@ import Test.Pos.Chain.Block.Arbitrary.Generate (generateMainBlock) -- no subscription connection, we would see this problem. protocolMagic :: ProtocolMagic -protocolMagic = ProtocolMagic 0 +protocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic protocolConstants :: ProtocolConstants protocolConstants = ProtocolConstants diff --git a/lib/cardano-sl.cabal b/lib/cardano-sl.cabal index b7ce06fc885..e58a0f08de4 100644 --- a/lib/cardano-sl.cabal +++ b/lib/cardano-sl.cabal @@ -283,6 +283,7 @@ test-suite cardano-test Test.Pos.Diffusion.BlockSpec Test.Pos.Genesis.CanonicalSpec Test.Pos.Launcher.ConfigurationSpec + Test.Pos.Launcher.Json Test.Pos.MerkleSpec Test.Pos.Infra.Slotting.TypesSpec Test.Pos.Types.Identity.SafeCopySpec @@ -322,6 +323,7 @@ test-suite cardano-test , filelock , formatting , generic-arbitrary + , hedgehog , hspec , lens , network-transport diff --git a/lib/configuration.yaml b/lib/configuration.yaml index dfbda3e3d7d..e3ba9937b2b 100644 --- a/lib/configuration.yaml +++ b/lib/configuration.yaml @@ -57,7 +57,7 @@ dev: &dev ftsSeed: "c2tvdm9yb2RhIEdndXJkYSBib3JvZGEgcHJvdm9kYSA=" heavyDelegation: {} avvmDistr: {} - requiresNetworkMagic: NMMustBeNothing + requiresNetworkMagic: RequiresNoMagic dbSerializeVersion: 0 ntp: &dev_ntp @@ -14833,7 +14833,7 @@ mainnet_full: &mainnet_full src: file: mainnet-genesis.json hash: 5f20df933584822601f9e3f8c024eb5eb252fe8cefb24d1317dc3d432e940ebb - requiresNetworkMagic: NMMustBeNothing + requiresNetworkMagic: RequiresNoMagic mainnet_wallet_win64: &mainnet_wallet_win64 <<: *mainnet_full @@ -14905,7 +14905,7 @@ testnet_launch: &testnet_launch maxHeaderSize: 2000 maxProposalSize: 70000 # 70KB maxTxSize: 65536 # 64KiB - requiresNetworkMagic: NMMustBeJust + requiresNetworkMagic: RequiresMagic testnet_full: &testnet_full <<: *testnet_launch @@ -14967,7 +14967,7 @@ mainnet_dryrun_full: &mainnet_dryrun_full src: file: mainnet-genesis-dryrun-with-stakeholders.json hash: c6a004d3d178f600cd8caa10abbebe1549bef878f0665aea2903472d5abf7323 - requiresNetworkMagic: NMMustBeNothing + requiresNetworkMagic: RequiresNoMagic mainnet_dryrun_wallet_win64: &mainnet_dryrun_wallet_win64 <<: *mainnet_dryrun_full @@ -15094,7 +15094,7 @@ devnet: &devnet avvmBalanceFactor: 1 useHeavyDlg: True seed: 0 - requiresNetworkMagic: NMMustBeNothing + requiresNetworkMagic: RequiresNoMagic update: &devnet_update applicationName: cardano-sl @@ -15226,4 +15226,4 @@ internal_staging_wallet_linux64: lastKnownBlockVersion: bvMajor: 0 bvMinor: 0 - bvAlt: 0 + bvAlt: 0 \ No newline at end of file diff --git a/lib/src/Pos/Configuration.hs b/lib/src/Pos/Configuration.hs index cf53dc965e8..70acb1dc052 100644 --- a/lib/src/Pos/Configuration.hs +++ b/lib/src/Pos/Configuration.hs @@ -58,7 +58,7 @@ data NodeConfiguration = NodeConfiguration , ccExplorerExtendedApi :: !Bool -- ^ Enable explorer extended API for fetching more -- info about addresses (like utxos) and bulk endpoints - } deriving (Show, Generic) + } deriving (Eq, Generic, Show) instance ToJSON NodeConfiguration where toJSON = genericToJSON defaultOptions diff --git a/lib/src/Pos/Diffusion/Full.hs b/lib/src/Pos/Diffusion/Full.hs index 6837687740f..67e4f0629c3 100644 --- a/lib/src/Pos/Diffusion/Full.hs +++ b/lib/src/Pos/Diffusion/Full.hs @@ -50,7 +50,7 @@ import Pos.Communication (EnqueueMsg, HandlerSpecs, InSpecs (..), import Pos.Core (ProtocolConstants (..), StakeholderId) import Pos.Core.Chrono (OldestFirst) import Pos.Core.Metrics.Constants (withCardanoNamespace) -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic (..), getProtocolMagic) import qualified Pos.Diffusion.Full.Block as Diffusion.Block import qualified Pos.Diffusion.Full.Delegation as Diffusion.Delegation import qualified Pos.Diffusion.Full.Ssc as Diffusion.Ssc diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index 45b8a9ebccc..7b4acfc506d 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -28,7 +28,7 @@ module Pos.Launcher.Configuration import Universum import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, - genericToJSON, withObject, (.:), (.:?)) + genericToJSON, withObject, (.!=), (.:), (.:?)) import qualified Data.ByteString.Lazy as BSL import Data.Default (Default (..)) import qualified Data.HashMap.Strict as HM @@ -50,6 +50,7 @@ import Pos.Chain.Genesis as Genesis (Config (..), GenesisData (..), import Pos.Core (Address, decodeTextAddress) import Pos.Core.Conc (currentTime) import Pos.Core.Slotting (Timestamp (..)) +import Pos.Crypto (RequiresNetworkMagic (..)) import Pos.Util.AssertMode (inAssertMode) import Pos.Util.Config (parseYamlConfig) import Pos.Util.Wlog (WithLogger, logInfo) @@ -63,16 +64,17 @@ import Pos.Configuration -- | Product of all configurations required to run a node. data Configuration = Configuration - { ccGenesis :: !StaticConfig - , ccNtp :: !NtpConfiguration - , ccUpdate :: !UpdateConfiguration - , ccSsc :: !SscConfiguration - , ccDlg :: !DlgConfiguration - , ccTxp :: !TxpConfiguration - , ccBlock :: !BlockConfiguration - , ccNode :: !NodeConfiguration - , ccWallet :: !WalletConfiguration - } deriving (Show, Generic) + { ccGenesis :: !StaticConfig + , ccNtp :: !NtpConfiguration + , ccUpdate :: !UpdateConfiguration + , ccSsc :: !SscConfiguration + , ccDlg :: !DlgConfiguration + , ccTxp :: !TxpConfiguration + , ccBlock :: !BlockConfiguration + , ccNode :: !NodeConfiguration + , ccWallet :: !WalletConfiguration + , ccReqNetMagic :: !RequiresNetworkMagic + } deriving (Eq, Generic , Show) instance FromJSON Configuration where parseJSON = withObject "Configuration" $ \o -> do @@ -90,6 +92,21 @@ instance FromJSON Configuration where ccBlock <- o .: "block" ccNode <- o .: "node" ccWallet <- o .: "wallet" + ccReqNetMagic <- if + -- If the "requiresNetworkMagic" key is specified, use the + -- mapped value. + | HM.member "requiresNetworkMagic" o -> o .: "requiresNetworkMagic" + + -- (for backward-compat with the old CoreConfiguration format) + -- else if the "core" key is specified and the + -- "requiresNetworkMagic" key is specified within its mapped + -- object, use that value. Otherwise, default to RequiresMagic + | HM.member "core" o -> do + coreO <- o .: "core" + coreO .:? "requiresNetworkMagic" .!= RequiresMagic + + -- else default to RequiresMagic + | otherwise -> pure RequiresMagic pure $ Configuration {..} instance ToJSON Configuration where @@ -97,7 +114,7 @@ instance ToJSON Configuration where data WalletConfiguration = WalletConfiguration { ccThrottle :: !(Maybe ThrottleSettings) - } deriving (Show, Generic) + } deriving (Eq, Generic, Show) defaultWalletConfiguration :: WalletConfiguration defaultWalletConfiguration = WalletConfiguration @@ -114,7 +131,7 @@ data ThrottleSettings = ThrottleSettings { tsRate :: !Word64 , tsPeriod :: !Word64 , tsBurst :: !Word64 - } deriving (Show, Generic) + } deriving (Eq, Generic, Show) defaultThrottleSettings :: ThrottleSettings defaultThrottleSettings = ThrottleSettings @@ -191,6 +208,7 @@ withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do configDir (cfoSystemStart cfo) (cfoSeed cfo) + (ccReqNetMagic cfg) (ccGenesis cfg) withUpdateConfiguration (ccUpdate cfg) $ withSscConfiguration (ccSsc cfg) $ @@ -206,6 +224,7 @@ withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do (ccNtp cfg) (ccWallet cfg) txpConfig + (ccReqNetMagic cfg) act genesisConfig (ccWallet cfg) txpConfig (ccNtp cfg) addAssetLock :: Set Address -> TxpConfiguration -> TxpConfiguration @@ -233,10 +252,11 @@ printInfoOnStart :: -> NtpConfiguration -> WalletConfiguration -> TxpConfiguration + -> RequiresNetworkMagic -> m () -printInfoOnStart dumpGenesisPath dumpConfig genesisData genesisConfig ntpConfig walletConfig txpConfig = do +printInfoOnStart dumpGenesisPath dumpConfig genesisData genesisConfig ntpConfig walletConfig txpConfig rnm = do whenJust dumpGenesisPath $ dumpGenesisData genesisData True - when dumpConfig $ dumpConfiguration genesisConfig ntpConfig walletConfig txpConfig + when dumpConfig $ dumpConfiguration genesisConfig ntpConfig walletConfig txpConfig rnm printFlags t <- currentTime mapM_ logInfo $ @@ -266,8 +286,9 @@ dumpConfiguration -> NtpConfiguration -> WalletConfiguration -> TxpConfiguration + -> RequiresNetworkMagic -> m () -dumpConfiguration genesisConfig ntpConfig walletConfig txpConfig = do +dumpConfiguration genesisConfig ntpConfig walletConfig txpConfig rnm = do let conf = Configuration { ccGenesis = genesisConfig @@ -279,6 +300,7 @@ dumpConfiguration genesisConfig ntpConfig walletConfig txpConfig = do , ccBlock = blockConfiguration , ccNode = nodeConfiguration , ccWallet = walletConfig + , ccReqNetMagic = rnm } putText . decodeUtf8 . Yaml.encode $ conf exitSuccess diff --git a/lib/src/Pos/Logic/Pure.hs b/lib/src/Pos/Logic/Pure.hs index bf0e9d779ce..1609887f593 100644 --- a/lib/src/Pos/Logic/Pure.hs +++ b/lib/src/Pos/Logic/Pure.hs @@ -33,7 +33,8 @@ import Pos.Core.Common (BlockCount (..), ChainDifficulty (..)) import Pos.Core.Merkle (MerkleRoot (..)) import Pos.Core.Slotting (EpochIndex (..), LocalSlotIndex (..), SlotId (..)) -import Pos.Crypto.Configuration (ProtocolMagic (..)) +import Pos.Crypto.Configuration (ProtocolMagic (..), + ProtocolMagicId (..), RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (Hash, unsafeMkAbstractHash) import Pos.Crypto.Signing (PublicKey (..), SecretKey (..), Signature (..), deterministicKeyGen, signRaw) @@ -241,8 +242,11 @@ chainDifficulty = ChainDifficulty blockSignature :: BlockSignature blockSignature = BlockSignature (coerce (signRaw protocolMagic Nothing secretKey mempty)) +protocolMagicId :: ProtocolMagicId +protocolMagicId = ProtocolMagicId 0 + protocolMagic :: ProtocolMagic -protocolMagic = ProtocolMagic 0 +protocolMagic = ProtocolMagic protocolMagicId RequiresNoMagic extraHeaderData :: MainExtraHeaderData extraHeaderData = MainExtraHeaderData diff --git a/lib/src/Test/Pos/Helpers.hs b/lib/src/Test/Pos/Helpers.hs index fb96afe9617..0a9bd103381 100644 --- a/lib/src/Test/Pos/Helpers.hs +++ b/lib/src/Test/Pos/Helpers.hs @@ -1,15 +1,21 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RankNTypes #-} +-- Need this to avoid a warning on the `typeName` helper function. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + module Test.Pos.Helpers ( canonicalJsonTest + , canonicalJsonTestWithGen ) where import Universum import Data.Functor.Identity (Identity (..)) +import Data.Typeable (typeRep) import Test.Hspec (Spec) -import Test.QuickCheck (Property, (.&&.), (===)) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Gen, Property, forAll, (.&&.), (===)) import qualified Text.JSON.Canonical as CanonicalJSON import Pos.Util.Json.Canonical (SchemaError) @@ -32,27 +38,52 @@ canonicalJsonTest :: canonicalJsonTest = identityTest @a $ \x -> canonicalJsonRenderAndDecode x .&&. canonicalJsonPrettyAndDecode x + +-- | Basically the same as `canonicalJsonTest` but tests a given `Gen a`. +canonicalJsonTestWithGen + :: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a) + => Gen a + -> Spec +canonicalJsonTestWithGen genA = + prop (typeName @a) $ forAll genA $ \x -> + canonicalJsonRenderAndDecode x .&&. canonicalJsonPrettyAndDecode x where - canonicalJsonRenderAndDecode x = - let encodedX = - CanonicalJSON.renderCanonicalJSON $ - runIdentity $ CanonicalJSON.toJSON x - in canonicalJsonDecodeAndCompare x encodedX - canonicalJsonPrettyAndDecode x = - let encodedX = - encodeUtf8 $ - CanonicalJSON.prettyCanonicalJSON $ - runIdentity $ CanonicalJSON.toJSON x - in canonicalJsonDecodeAndCompare x encodedX - canonicalJsonDecodeAndCompare :: - a - -> LByteString - -> Property - canonicalJsonDecodeAndCompare x encodedX = - let decodedValue = - either (error . toText) identity $ - CanonicalJSON.parseCanonicalJSON encodedX - decodedX = - either (error . pretty @SchemaError) identity $ - CanonicalJSON.fromJSON decodedValue - in decodedX === x + -- GHC 8.2.2 says the `Typeable x` constraint is not necessary, but won't compile + -- this without it. + typeName :: forall x. Typeable x => String + typeName = show $ typeRep (Proxy @a) + +canonicalJsonRenderAndDecode + :: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a) + => a + -> Property +canonicalJsonRenderAndDecode x = + let encodedX = + CanonicalJSON.renderCanonicalJSON $ + runIdentity $ CanonicalJSON.toJSON x + in canonicalJsonDecodeAndCompare x encodedX + +canonicalJsonPrettyAndDecode + :: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a) + => a + -> Property +canonicalJsonPrettyAndDecode x = + let encodedX = + encodeUtf8 $ + CanonicalJSON.prettyCanonicalJSON $ + runIdentity $ CanonicalJSON.toJSON x + in canonicalJsonDecodeAndCompare x encodedX + +canonicalJsonDecodeAndCompare + :: forall a. (IdTestingRequiredClassesAlmost a, ToAndFromCanonicalJson a) + => a + -> LByteString + -> Property +canonicalJsonDecodeAndCompare x encodedX = + let decodedValue = + either (error . toText) identity $ + CanonicalJSON.parseCanonicalJSON encodedX + decodedX = + either (error . pretty @SchemaError) identity $ + CanonicalJSON.fromJSON decodedValue + in decodedX === x diff --git a/lib/test/Test.hs b/lib/test/Test.hs index 6684452ff03..669ae90b67d 100644 --- a/lib/test/Test.hs +++ b/lib/test/Test.hs @@ -5,8 +5,11 @@ import Test.Hspec (hspec) import Spec (spec) import Test.Pos.Configuration (defaultTestConf) +import qualified Test.Pos.Launcher.Json +import Test.Pos.Util.Tripping (runTests) main :: IO () main = do putText $ "default configuration: " <> show defaultTestConf hspec spec + runTests [ Test.Pos.Launcher.Json.tests ] diff --git a/lib/test/Test/Pos/Diffusion/BlockSpec.hs b/lib/test/Test/Pos/Diffusion/BlockSpec.hs index 3ff31a14007..9ddb65b561c 100644 --- a/lib/test/Test/Pos/Diffusion/BlockSpec.hs +++ b/lib/test/Test/Pos/Diffusion/BlockSpec.hs @@ -32,7 +32,8 @@ import qualified Pos.Chain.Block as Block (getBlockHeader) import Pos.Chain.Update (BlockVersion (..)) import Pos.Core.Chrono (NewestFirst (..), OldestFirst (..)) import Pos.Core.ProtocolConstants (ProtocolConstants (..)) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (Hash, unsafeMkAbstractHash) import Pos.DB.Class (Serialized (..), SerializedBlock) import Pos.Diffusion.Full (FullDiffusionConfiguration (..), @@ -54,7 +55,7 @@ import Test.Pos.Chain.Block.Arbitrary.Generate (generateMainBlock) {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} protocolMagic :: ProtocolMagic -protocolMagic = ProtocolMagic 0 +protocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic protocolConstants :: ProtocolConstants protocolConstants = ProtocolConstants diff --git a/lib/test/Test/Pos/Genesis/CanonicalSpec.hs b/lib/test/Test/Pos/Genesis/CanonicalSpec.hs index 16f0852ee84..bb243d41ce1 100644 --- a/lib/test/Test/Pos/Genesis/CanonicalSpec.hs +++ b/lib/test/Test/Pos/Genesis/CanonicalSpec.hs @@ -9,18 +9,31 @@ import Universum import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess) -import Pos.Chain.Genesis (GenesisAvvmBalances, GenesisData, - GenesisDelegation, GenesisProtocolConstants, +import Pos.Chain.Genesis (GenesisAvvmBalances, GenesisDelegation, GenesisWStakeholders) +import Pos.Crypto (RequiresNetworkMagic (..)) -import Test.Pos.Chain.Genesis.Arbitrary () -import Test.Pos.Helpers (canonicalJsonTest) +import Test.Pos.Chain.Genesis.Arbitrary (genGenesisData, + genGenesisProtocolConstants) +import Test.Pos.Crypto.Arbitrary (genProtocolMagicUniformWithRNM) +import Test.Pos.Helpers (canonicalJsonTest, canonicalJsonTestWithGen) spec :: Spec spec = describe "Genesis" $ modifyMaxSuccess (const 10) $ do describe "Canonical encoding" $ do - canonicalJsonTest @GenesisProtocolConstants - canonicalJsonTest @GenesisAvvmBalances - canonicalJsonTest @GenesisWStakeholders - canonicalJsonTest @GenesisDelegation - canonicalJsonTest @GenesisData + -- Restricted canonical JSON identity tests for those types which + -- include `ProtocolMagic`. + -- + -- This must be done since the canonical `ToJSON` instance of + -- `ProtocolMagic` does not output the `RequiresNetworkMagic` field + -- and the canonical `FromJSON` instance defaults its value to + -- `RequiresMagic`. + describe "Generator restricted to only use RequiresMagic" $ do + let genPM = genProtocolMagicUniformWithRNM RequiresMagic + canonicalJsonTestWithGen $ genGenesisProtocolConstants genPM + canonicalJsonTestWithGen $ genGenesisData (genGenesisProtocolConstants genPM) + -- Unrestricted canonical JSON identity tests + describe "Unrestricted tests" $ do + canonicalJsonTest @GenesisAvvmBalances + canonicalJsonTest @GenesisWStakeholders + canonicalJsonTest @GenesisDelegation diff --git a/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs b/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs index d385033bb10..ef84a00babe 100644 --- a/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs +++ b/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs @@ -5,22 +5,48 @@ module Test.Pos.Launcher.ConfigurationSpec import Universum import Data.Time.Clock.POSIX (getPOSIXTime) -import Test.Hspec (Spec, describe, it, shouldSatisfy) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Ntp.Client (NtpConfiguration) +import qualified Pos.Chain.Genesis as Genesis (Config (..)) +import Pos.Chain.Txp (TxpConfiguration) import Pos.Core.Slotting (Timestamp (..)) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Launcher.Configuration (ConfigurationOptions (..), - defaultConfigurationOptions, withConfigurations) + WalletConfiguration, defaultConfigurationOptions, + withConfigurations) import Pos.Util.Config (ConfigurationException) import Pos.Util.Wlog (setupTestLogging) +configFilePath :: FilePath +configFilePath = "configuration.yaml" + +checkYamlSection :: Text -> Spec +checkYamlSection key = describe ("key: " ++ show key) $ do + it "should be RequiresNoMagic" $ do + liftIO $ setupTestLogging + startTime <- Timestamp . round . (* 1000000) <$> liftIO getPOSIXTime + let cfo = ConfigurationOptions configFilePath key (Just startTime) Nothing + rnm <- liftIO (withConfigurations Nothing Nothing False cfo getRNM) + rnm `shouldBe` RequiresNoMagic + +getRNM + :: Genesis.Config + -> WalletConfiguration + -> TxpConfiguration + -> NtpConfiguration + -> IO RequiresNetworkMagic +getRNM cfg _ _ _ = + pure $ getRequiresNetworkMagic $ Genesis.configProtocolMagic cfg + spec :: Spec spec = describe "Pos.Launcher.Configuration" $ do describe "withConfigurations" $ do - it "should parse `lib/configuration.yaml` file" $ do - liftIO setupTestLogging + it ("should parse `" <> configFilePath <> "` file") $ do + liftIO $ setupTestLogging startTime <- Timestamp . round . (* 1000000) <$> liftIO getPOSIXTime let cfo = defaultConfigurationOptions - { cfoFilePath = "./configuration.yaml" + { cfoFilePath = configFilePath , cfoSystemStart = Just startTime } let catchFn :: ConfigurationException -> IO (Maybe ConfigurationException) @@ -29,3 +55,17 @@ spec = describe "Pos.Launcher.Configuration" $ do (withConfigurations Nothing Nothing False cfo (\_ _ _ _ -> return Nothing)) catchFn res `shouldSatisfy` isNothing + + -- Ensuring that all of the config objects mapped to each of the specified + -- keys contain RequiresNoMagic. + mapM_ checkYamlSection + [ "mainnet_full" -- mainnet core/relay nodes and exchange wallets + , "mainnet_dryrun_full" -- staging core/relay nodes and exchange wallets + , "mainnet_wallet_win64" -- mainnet wallets (daedalus) + , "mainnet_wallet_macos64" + , "mainnet_wallet_linux64" + , "mainnet_dryrun_wallet_win64" -- staging wallets (daedalus) + , "mainnet_dryrun_wallet_macos64" + , "mainnet_dryrun_wallet_linux64" + ] + diff --git a/lib/test/Test/Pos/Launcher/Json.hs b/lib/test/Test/Pos/Launcher/Json.hs new file mode 100644 index 00000000000..da805e8a6d4 --- /dev/null +++ b/lib/test/Test/Pos/Launcher/Json.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Pos.Launcher.Json + ( tests + ) where + +import Universum + +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as S +import Hedgehog (Property) +import qualified Hedgehog as H + +import Ntp.Client (NtpConfiguration (..)) +import Pos.Chain.Block (BlockConfiguration (..)) +import Pos.Chain.Delegation (DlgConfiguration (..)) +import Pos.Chain.Genesis (FakeAvvmOptions (..), + GenesisAvvmBalances (..), GenesisDelegation (..), + GenesisInitializer (..), GenesisProtocolConstants (..), + GenesisSpec (..), StaticConfig (..), + TestnetBalanceOptions (..)) +import Pos.Chain.Ssc (SscConfiguration (..)) +import Pos.Chain.Txp (TxpConfiguration (..)) +import Pos.Chain.Update +import Pos.Configuration (NodeConfiguration (..)) +import Pos.Core.Common (Coeff (..), CoinPortion (..), SharedSeed (..), + TxFeePolicy (..), TxSizeLinear (..)) +import Pos.Core.ProtocolConstants (VssMaxTTL (..), VssMinTTL (..)) +import Pos.Core.Slotting (EpochIndex (..)) +import Pos.Crypto.Configuration (ProtocolMagic (..), + ProtocolMagicId (..), RequiresNetworkMagic (..)) +import Pos.Launcher.Configuration (Configuration (..), + WalletConfiguration (..)) + +import Test.Pos.Util.Golden (discoverGolden, goldenTestJSONDec) +-------------------------------------------------------------------------------- +-- Configuration +-------------------------------------------------------------------------------- + +-- Decode-only golden tests for ensuring that, when decoding the legacy +-- `Configuration` JSON format, the `RequiresNetworkMagic` field defaults to +-- the correct `RequiresNetworkMagic`. + +golden_Configuration_Legacy_NoNetworkMagicField :: Property +golden_Configuration_Legacy_NoNetworkMagicField = + goldenTestJSONDec + testGoldenConf_NoNetworkMagicField + "test/golden/json/Configuration_Legacy_NoNetworkMagicField" + +testGoldenConf_NoNetworkMagicField :: Configuration +testGoldenConf_NoNetworkMagicField = Configuration + { ccGenesis = GCSpec + ( UnsafeGenesisSpec + { gsAvvmDistr = GenesisAvvmBalances (HM.fromList []) + , gsFtsSeed = SharedSeed "skovoroda Ggurda boroda provoda " + , gsHeavyDelegation = UnsafeGenesisDelegation (HM.fromList []) + , gsBlockVersionData = BlockVersionData + { bvdScriptVersion = 0 + , bvdSlotDuration = 7000 + , bvdMaxBlockSize = 2000000 + , bvdMaxHeaderSize = 2000000 + , bvdMaxTxSize = 4096 + , bvdMaxProposalSize = 700 + , bvdMpcThd = CoinPortion 100000000000000 + , bvdHeavyDelThd = CoinPortion 100000000000000 + , bvdUpdateVoteThd = CoinPortion 100000000000000 + , bvdUpdateProposalThd = CoinPortion 100000000000000 + , bvdUpdateImplicit = 10 + , bvdSoftforkRule = SoftforkRule + { srInitThd = CoinPortion 100000000000000 + , srMinThd = CoinPortion 100000000000000 + , srThdDecrement = CoinPortion 100000000000000 + } + , bvdTxFeePolicy = + TxFeePolicyTxSizeLinear + (TxSizeLinear + (Coeff 155381.000000000) (Coeff 43.946000000)) + , bvdUnlockStakeEpoch = EpochIndex 1844 + } + , gsProtocolConstants = GenesisProtocolConstants + { gpcK = 2 + , gpcProtocolMagic = ProtocolMagic + (ProtocolMagicId 55550001) RequiresMagic + , gpcVssMaxTTL = VssMaxTTL 6 + , gpcVssMinTTL = VssMinTTL 2 + } + , gsInitializer = GenesisInitializer + { giTestBalance = TestnetBalanceOptions + { tboPoors = 12 + , tboRichmen = 4 + , tboTotalBalance = 600000000000000000 + , tboRichmenShare = 0.99 + , tboUseHDAddresses = True + } + , giFakeAvvmBalance = FakeAvvmOptions + { faoCount = 10 + , faoOneBalance = 100000 + } + , giAvvmBalanceFactor = CoinPortion 100000000000000 + , giUseHeavyDlg = True + , giSeed = 0 + } + } + ) + , ccNtp = NtpConfiguration + { ntpcServers = + [ "0.pool.ntp.org" + , "2.pool.ntp.org" + , "3.pool.ntp.org" + ] + , ntpcResponseTimeout = 30000000 + , ntpcPollDelay = 1800000000 + } + , ccUpdate = UpdateConfiguration + { ccApplicationName = ApplicationName "cardano-sl" + , ccLastKnownBlockVersion = BlockVersion 0 0 0 + , ccApplicationVersion = 0 + , ccSystemTag = SystemTag "linux64" + } + , ccSsc = SscConfiguration + { ccMpcSendInterval = 10 + , ccMdNoCommitmentsEpochThreshold = 3 + , ccNoReportNoSecretsForEpoch1 = False + } + , ccDlg = DlgConfiguration + { ccDlgCacheParam = 500 + , ccMessageCacheTimeout = 30 + } + , ccTxp = TxpConfiguration + { ccMemPoolLimitTx = 200 + , tcAssetLockedSrcAddrs = S.fromList [] + } + , ccBlock = BlockConfiguration + { ccNetworkDiameter = 3 + , ccRecoveryHeadersMessage = 20 + , ccStreamWindow = 2048 + , ccNonCriticalCQBootstrap = 0.95 + , ccCriticalCQBootstrap = 0.8888 + , ccNonCriticalCQ = 0.8 + , ccCriticalCQ = 0.654321 + , ccCriticalForkThreshold = 2 + , ccFixedTimeCQ = 10 + } + , ccNode = NodeConfiguration + { ccNetworkConnectionTimeout = 15000 + , ccConversationEstablishTimeout = 30000 + , ccBlockRetrievalQueueSize = 100 + , ccPendingTxResubmissionPeriod = 7 + , ccWalletProductionApi = False + , ccWalletTxCreationDisabled = False + , ccExplorerExtendedApi = False + } + , ccWallet = WalletConfiguration { ccThrottle = Nothing } + , ccReqNetMagic = RequiresNoMagic + } + +tests :: IO Bool +tests = H.checkSequential $$discoverGolden diff --git a/lib/test/golden/json/Configuration_Legacy_NoNetworkMagicField b/lib/test/golden/json/Configuration_Legacy_NoNetworkMagicField new file mode 100644 index 00000000000..daff5b20e71 --- /dev/null +++ b/lib/test/golden/json/Configuration_Legacy_NoNetworkMagicField @@ -0,0 +1 @@ +{"core":{"genesis":{"spec":{"initializer":{"testBalance":{"poors":12,"richmen":4,"richmenShare":0.99,"useHDAddresses":true,"totalBalance":600000000000000000},"fakeAvvmBalance":{"count":10,"oneBalance":100000},"avvmBalanceFactor":0.1,"useHeavyDlg":true,"seed":0},"blockVersionData":{"scriptVersion":0,"slotDuration":7000,"maxBlockSize":2000000,"maxHeaderSize":2000000,"maxTxSize":4096,"maxProposalSize":700,"mpcThd":0.1,"heavyDelThd":0.1,"updateVoteThd":0.1,"updateProposalThd":0.1,"updateImplicit":10,"softforkRule":{"initThd":0.1,"minThd":0.1,"thdDecrement":0.1},"txFeePolicy":{"txSizeLinear":{"a":155381,"b":43.946}},"unlockStakeEpoch":1844},"protocolConstants":{"k":2,"protocolMagic":55550001,"vssMinTTL":2,"vssMaxTTL":6},"ftsSeed":"c2tvdm9yb2RhIEdndXJkYSBib3JvZGEgcHJvdm9kYSA=","heavyDelegation":{},"avvmDistr":{}}},"requiresNetworkMagic":"RequiresNoMagic","dbSerializeVersion":0},"ntp":{"responseTimeout":30000000,"pollDelay":1800000000,"servers":["0.pool.ntp.org","2.pool.ntp.org","3.pool.ntp.org"]},"update":{"applicationName":"cardano-sl","applicationVersion":0,"lastKnownBlockVersion":{"bvMajor":0,"bvMinor":0,"bvAlt":0}, "systemTag":"linux64"},"ssc":{"mpcSendInterval":10,"mdNoCommitmentsEpochThreshold":3,"noReportNoSecretsForEpoch1":false},"txp":{"memPoolLimitTx":200,"assetLockedSrcAddrs":[]},"dlg":{"dlgCacheParam":500,"messageCacheTimeout":30},"block":{"networkDiameter":3,"recoveryHeadersMessage":20,"streamWindow":2048,"nonCriticalCQBootstrap":0.95,"criticalCQBootstrap":0.8888,"nonCriticalCQ":0.8,"criticalCQ":0.654321,"criticalForkThreshold":2,"fixedTimeCQ":10},"node":{"networkConnectionTimeout":15000,"conversationEstablishTimeout":30000,"blockRetrievalQueueSize":100,"pendingTxResubmissionPeriod":7,"walletProductionApi":false,"walletTxCreationDisabled":false,"explorerExtendedApi":false},"wallet":{"throttle":null}} \ No newline at end of file diff --git a/networking/src/Ntp/Client.hs b/networking/src/Ntp/Client.hs index 66d3e015681..7d68f798973 100644 --- a/networking/src/Ntp/Client.hs +++ b/networking/src/Ntp/Client.hs @@ -71,6 +71,20 @@ data NtpClientSettings = NtpClientSettings -- some servers failed to respond in time, but never an empty list } +-- Written for JSON golden decode only tests. Only +-- the fields ntpServers, ntpResponseTimeout and ntpPollDelay +-- end up in the JSON encoding of `Configuration`. Also, +-- equality testing of a function does not make sense. + +instance Eq NtpClientSettings where + (==) (NtpClientSettings svs rT pDel _) + (NtpClientSettings svs' rT' pDel' _) = all (== True) [ svs == svs' + , rT == rT' + , pDel == pDel' + ] + + + data NtpClient = NtpClient { ncSockets :: TVar Sockets -- ^ Ntp client sockets: ipv4 / ipv6 / both. @@ -83,7 +97,7 @@ data NtpClient = NtpClient -- once all responses arrived. , ncSettings :: NtpClientSettings -- ^ Ntp client configuration. - } + } deriving Eq data NtpConfiguration = NtpConfiguration { @@ -94,7 +108,7 @@ data NtpConfiguration = NtpConfiguration , ntpcPollDelay :: !Integer -- ^ how long to wait between sending requests to the ntp servers (in -- microseconds) - } deriving (Show, Generic) + } deriving (Eq, Generic, Show) instance FromJSON NtpConfiguration where parseJSON = genericParseJSON defaultOptions diff --git a/pkgs/default.nix b/pkgs/default.nix index cfeb3f74da0..b50d4b0f2fb 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -14716,6 +14716,7 @@ license = stdenv.lib.licenses.bsd3; , filepath , formatting , generic-arbitrary +, hedgehog , hspec , http-client , http-client-tls @@ -14890,6 +14891,7 @@ extra filelock formatting generic-arbitrary +hedgehog hspec lens network-transport diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs index 1e63cd4bc58..f93f9bd4863 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs @@ -445,20 +445,20 @@ instance SC.SafeCopy (InDb Core.BlockHeader) where -- class for the actual fields, so they are actually totally different types. instance SC.SafeCopy (InDb Core.MainBlockHeader) where getCopy = SC.contain $ do - InDb protocolMagic <- SC.safeGet + InDb protocolMagicId <- SC.safeGet InDb prevBlock <- SC.safeGet InDb bodyProof <- SC.safeGet InDb consensus <- SC.safeGet InDb extra <- SC.safeGet pure . InDb $ Core.mkGenericBlockHeaderUnsafe - protocolMagic + (Core.ProtocolMagic protocolMagicId Core.RequiresNoMagic) prevBlock bodyProof consensus extra putCopy (InDb header) = SC.contain $ do - safePutDb $ header ^. Core.gbhProtocolMagic + safePutDb $ header ^. Core.gbhProtocolMagicId safePutDb $ header ^. Core.gbhPrevBlock safePutDb $ header ^. Core.gbhBodyProof safePutDb $ header ^. Core.gbhConsensus @@ -750,14 +750,14 @@ instance SC.SafeCopy (InDb Core.GenesisBlockHeader) where InDb extra <- SC.safeGet pure . InDb $ Core.mkGenericBlockHeaderUnsafe - protocolMagic + (Core.ProtocolMagic protocolMagic Core.RequiresNoMagic) prevBlock bodyProof consensus extra putCopy (InDb header) = SC.contain $ do - safePutDb $ header ^. Core.gbhProtocolMagic + safePutDb $ header ^. Core.gbhProtocolMagicId safePutDb $ header ^. Core.gbhPrevBlock safePutDb $ header ^. Core.gbhBodyProof safePutDb $ header ^. Core.gbhConsensus @@ -765,11 +765,36 @@ instance SC.SafeCopy (InDb Core.GenesisBlockHeader) where instance SC.SafeCopy (InDb Core.ProtocolMagic) where getCopy = SC.contain $ do - InDb . Core.ProtocolMagic <$> SC.safeGet + i <- SC.safeGet + rnm <- SC.safeGet + pure $ Core.ProtocolMagic + <$> i + <*> rnm + + putCopy (InDb (Core.ProtocolMagic i rnm)) = SC.contain $ do + safePutDb i + safePutDb rnm + +instance SC.SafeCopy (InDb Core.ProtocolMagicId) where + getCopy = SC.contain $ do + InDb . Core.ProtocolMagicId <$> SC.safeGet - putCopy (InDb (Core.ProtocolMagic i)) = SC.contain $ do + putCopy (InDb (Core.ProtocolMagicId i)) = SC.contain $ do SC.safePut i +instance SC.SafeCopy (InDb Core.RequiresNetworkMagic) where + getCopy = SC.contain $ + SC.safeGet >>= \case + 0 -> pure (InDb Core.RequiresNoMagic) + 1 -> pure (InDb Core.RequiresMagic) + (n :: Word8) -> fail + $ "Expected one of 0,1 for RequiresNetworkMagic tag,\ + \ got: " + <> show n + putCopy (InDb rnm) = SC.contain $ case rnm of + Core.RequiresNoMagic -> SC.safePut (0 :: Word8) + Core.RequiresMagic -> SC.safePut (1 :: Word8) + instance SC.SafeCopy (InDb Core.GenesisProof) where getCopy = SC.contain $ do hashLeaders <- SC.safeGet diff --git a/wallet-new/test/MarshallingSpec.hs b/wallet-new/test/MarshallingSpec.hs index 204868fca08..7f079da8371 100644 --- a/wallet-new/test/MarshallingSpec.hs +++ b/wallet-new/test/MarshallingSpec.hs @@ -156,6 +156,8 @@ spec = parallel $ describe "Marshalling & Unmarshalling" $ do safeCopyRoundTrip @(InDb Core.BlockCount) safeCopyRoundTrip @(InDb Core.GenesisBlockHeader) safeCopyRoundTrip @(InDb Core.ProtocolMagic) + safeCopyRoundTrip @(InDb Core.ProtocolMagicId) + safeCopyRoundTrip @(InDb Core.RequiresNetworkMagic) safeCopyRoundTrip @(InDb Core.GenesisProof) safeCopyRoundTrip @(InDb Core.GenesisConsensusData) safeCopyRoundTrip @(InDb Core.GenesisExtraHeaderData) diff --git a/wallet-new/test/unit/Test/Spec/Submission.hs b/wallet-new/test/unit/Test/Spec/Submission.hs index d5e6d9f44f5..96925cff857 100644 --- a/wallet-new/test/unit/Test/Spec/Submission.hs +++ b/wallet-new/test/unit/Test/Spec/Submission.hs @@ -27,7 +27,8 @@ import qualified Formatting as F import Formatting.Buildable (build) import qualified Pos.Chain.Txp as Txp import Pos.Core.Attributes (Attributes (..), UnparsedFields (..)) -import Pos.Crypto (ProtocolMagic (..)) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (hash) import Pos.Crypto.Signing.Safe (safeDeterministicKeyGen) import Serokell.Util.Text (listJsonIndent) @@ -89,7 +90,7 @@ genSchedule maxRetries pending (Slot lowerBound) = do genWalletSubmissionState :: HdAccountId -> MaxRetries -> Gen WalletSubmissionState genWalletSubmissionState accId maxRetries = do - pending <- M.singleton accId <$> genPending (ProtocolMagic 0) + pending <- M.singleton accId <$> genPending protocolMagic let slot = Slot 0 -- Make the layer always start from 0, to make running the specs predictable. scheduler <- genSchedule maxRetries pending slot return $ WalletSubmissionState pending scheduler slot @@ -178,7 +179,7 @@ dependentTransactions = do outputForB <- (Txp.TxOut <$> arbitrary <*> arbitrary) outputForC <- (Txp.TxOut <$> arbitrary <*> arbitrary) outputForD <- (Txp.TxOut <$> arbitrary <*> arbitrary) - [a,b,c,d] <- vectorOf 4 (Txp.genTxAux (ProtocolMagic 0)) + [a,b,c,d] <- vectorOf 4 (Txp.genTxAux protocolMagic) let a' = a { Txp.taTx = (Txp.taTx a) { Txp._txInputs = inputForA :| mempty , Txp._txOutputs = outputForA :| mempty @@ -219,7 +220,7 @@ genPureWalletSubmission accId = genPurePair :: Gen (ShowThroughBuild (WalletSubmission, M.Map HdAccountId Pending)) genPurePair = do STB layer <- genPureWalletSubmission myAccountId - pending <- genPending (ProtocolMagic 0) + pending <- genPending protocolMagic let pending' = Pending.delete (toTxIdSet $ layer ^. localPendingSet myAccountId) pending pure $ STB (layer, M.singleton myAccountId pending') @@ -434,3 +435,7 @@ spec = do , mustNotIncludeEvents "none of [a,b,c,d] was scheduled" (ScheduleEvents scheduledInSlot2 confirmed2) [a,b,c,d] , includeEvents "[c,d] scheduled slot 3" (ScheduleEvents scheduledInSlot3 confirmed3) [c,d] ] + + +protocolMagic :: ProtocolMagic +protocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic