Merge pull request #3540 from input-output-hk/intricate/CDEC-552

[release/1.3.1] [CDEC-552] Migrate Bi and JSON round-trip and golden tests for core data types

Author: rvl

core/cardano-sl-core.cabal

@@ -264,19 +264,26 @@ test-suite test
   other-modules:
                        Spec
                        Test.Pos.Core.AddressSpec
+                       Test.Pos.Core.Bi
                        Test.Pos.Core.CborSpec
                        Test.Pos.Core.Chrono
                        Test.Pos.Core.ChronoSpec
                        Test.Pos.Core.CoinSpec
+                       Test.Pos.Core.ExampleHelpers
+                       Test.Pos.Core.Gen
+                       Test.Pos.Core.Json
                        Test.Pos.Core.LimitsSpec
                        Test.Pos.Core.SeedSpec
                        Test.Pos.Core.SlottingSpec
 
                        Test.Pos.Core.Arbitrary
                        Test.Pos.Core.Arbitrary.Unsafe
 
-  build-depends:       base
+  build-depends:       aeson
+                     , base
+                     , base16-bytestring
                      , bytestring
+                     , cardano-crypto
                      , cardano-sl-binary
                      , cardano-sl-binary-test
                      , cardano-sl-core
@@ -285,9 +292,14 @@ test-suite test
                      , cardano-sl-util
                      , cardano-sl-util-test
                      , containers
+                     , cryptonite
+                     , deepseq
+                     , ed25519
                      , formatting
                      , generic-arbitrary
+                     , hedgehog
                      , hspec
+                     , pvss
                      , QuickCheck
                      , quickcheck-instances
                      , random
@@ -296,6 +308,7 @@ test-suite test
                      , time-units
                      , universum >= 0.1.11
                      , unordered-containers
+                     , vector
 
   ghc-options:         -threaded
                        -rtsopts

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

@@ -9,8 +9,6 @@ module Pos.Aeson.Core.Configuration
 import           Data.Aeson.TH (deriveJSON)
 import           Serokell.Aeson.Options (defaultOptions)
 
-import           Pos.Aeson.Genesis ()
-import           Pos.Core.Configuration.Core (CoreConfiguration (..), GenesisConfiguration (..))
+import           Pos.Core.Configuration.Core (CoreConfiguration (..))
 
-deriveJSON defaultOptions ''GenesisConfiguration
 deriveJSON defaultOptions ''CoreConfiguration

core/src/Pos/Core/Configuration.hs

@@ -29,11 +29,12 @@ import           Pos.Core.Configuration.Protocol as E
 import           Pos.Core.Genesis (GenesisData (..), GenesisDelegation, GenesisInitializer (..),
                                    GenesisProtocolConstants (..), GenesisSpec (..),
                                    genesisProtocolConstantsToProtocolConstants, mkGenesisDelegation)
-import           Pos.Core.Genesis.Canonical (SchemaError)
+import           Pos.Core.Genesis.Canonical ()
 import           Pos.Core.Genesis.Generate (GeneratedGenesisData (..), generateGenesisData)
 import           Pos.Core.Slotting (Timestamp)
 import           Pos.Crypto.Configuration as E
 import           Pos.Crypto.Hashing (Hash, hashRaw, unsafeHash)
+import           Pos.Util.Json.Canonical (SchemaError (..))
 import           Pos.Util.Util (leftToPanic)
 
 -- | Coarse catch-all configuration constraint for use by depending modules.

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

@@ -19,11 +19,19 @@ module Pos.Core.Configuration.Core
        , defaultCoreConfiguration
        ) where
 
-import           Universum
+import           Prelude
+import           Universum hiding (fail, (<>))
 
+import           Data.Aeson (FromJSON, ToJSON, Value (..), genericToEncoding, pairs, parseJSON,
+                             toEncoding, (.:))
+import           Data.Aeson.Encoding (pairStr)
+import           Data.Aeson.Types (typeMismatch)
+import qualified Data.HashMap.Strict as HM
+import           Data.Monoid ((<>))
 import           Data.Reflection (Given (..), give)
+import           Serokell.Aeson.Options (defaultOptions)
 
-import qualified Data.HashMap.Strict as HM
+import           Pos.Aeson.Genesis ()
 import           Pos.Binary.Class (Raw)
 import           Pos.Core.Common (Coeff (..), SharedSeed (..), TxFeePolicy (..), TxSizeLinear (..),
                                   unsafeCoinPortionFromDouble)
@@ -47,7 +55,70 @@ data GenesisConfiguration
             , gcsHash :: !(Hash Raw)
             -- ^ Hash of canonically encoded 'GenesisData'.
             }
-    deriving (Show)
+    deriving (Eq, Show, Generic)
+
+instance ToJSON GenesisConfiguration where
+    toEncoding (GCSrc gcsFile gcsHash) =
+        pairs . pairStr "src"
+            . pairs  $ pairStr "file"
+                (toEncoding gcsFile) <> pairStr "hash" (toEncoding gcsHash)
+
+    toEncoding (GCSpec value)          =
+        genericToEncoding defaultOptions (GCSpec value)
+
+instance FromJSON GenesisConfiguration where
+    parseJSON (Object o)
+        | HM.member "src" o  = GCSrc <$> ((o .: "src") >>= (.: "file"))
+                                      <*> ((o .: "src") >>= (.: "hash"))
+        | HM.member "spec" o = do
+              -- GCSpec Object
+              specO <- o .: "spec"
+
+              -- GenesisAvvmBalances
+              avvmDistrO <- specO .: "avvmDistr"
+              avvmDistr <- parseJSON (avvmDistrO)
+
+              -- SharedSeed
+              ftsSeed <- specO .: "ftsSeed"
+
+              -- GenesisDelegation
+              heavyDelegationO <- specO .: "heavyDelegation"
+              heavyDelegation <- parseJSON (heavyDelegationO)
+
+              -- BlockVersionData
+              blockVersionDataO <- specO .: "blockVersionData"
+              blockVersionData <- parseJSON blockVersionDataO
+
+              -- GenesisProtocolConstants
+              protocolConstantsO <- specO .: "protocolConstants"
+              protocolConstants <- parseJSON protocolConstantsO
+
+              -- GenesisInitializer
+              initializerO <- specO .: "initializer"
+              testBalanceO <- initializerO .: "testBalance"
+              testBalance <- parseJSON testBalanceO
+              fakeAvvmBalanceO <- (initializerO .: "fakeAvvmBalance")
+              fakeAvvmBalance <- parseJSON fakeAvvmBalanceO
+              avvmBalanceFactor <- initializerO .: "avvmBalanceFactor"
+              useHeavyDlg <- initializerO .: "useHeavyDlg"
+              seed <- initializerO .: "seed"
+
+              return . GCSpec $
+                  UnsafeGenesisSpec
+                      (GenesisAvvmBalances avvmDistr)
+                      ftsSeed
+                      heavyDelegation
+                      blockVersionData
+                      protocolConstants
+                      (GenesisInitializer
+                          testBalance
+                          fakeAvvmBalance
+                          avvmBalanceFactor
+                          useHeavyDlg
+                          seed)
+        | otherwise = fail "Incorrect JSON encoding for GenesisConfiguration"
+
+    parseJSON invalid = typeMismatch "GenesisConfiguration" invalid
 
 data CoreConfiguration = CoreConfiguration
     {

core/src/Pos/Core/Genesis.hs

@@ -1,6 +1,5 @@
 module Pos.Core.Genesis
-       ( module Pos.Core.Genesis.Canonical
-       , module Pos.Core.Genesis.Generate
+       ( module Pos.Core.Genesis.Generate
 
        , module Pos.Core.Genesis.AvvmBalances
        , module Pos.Core.Genesis.Data
@@ -13,7 +12,7 @@ module Pos.Core.Genesis
        , module Pos.Core.Genesis.WStakeholders
        ) where
 
-import           Pos.Core.Genesis.Canonical
+import           Pos.Core.Genesis.Canonical ()
 import           Pos.Core.Genesis.Generate
 
 import           Pos.Core.Genesis.AvvmBalances

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

@@ -3,17 +3,14 @@
 -- | Canonical encoding of 'GenesisData'.
 
 module Pos.Core.Genesis.Canonical
-       ( SchemaError(..)
+       (
        ) where
 
 import           Universum
 
 import           Control.Lens (_Left)
-import           Control.Monad.Except (MonadError (..))
 import           Data.Fixed (Fixed (..))
 import qualified Data.HashMap.Strict as HM
-import qualified Data.Text.Buildable as Buildable
-import qualified Data.Text.Lazy.Builder as Builder (fromText)
 import           Data.Time.Units (Millisecond, Second, convertUnit)
 import           Data.Typeable (typeRep)
 import           Formatting (formatToString)
@@ -52,32 +49,12 @@ import           Pos.Core.Genesis.ProtocolConstants (GenesisProtocolConstants (.
 import           Pos.Core.Genesis.VssCertificatesMap (GenesisVssCertificatesMap (..))
 import           Pos.Core.Genesis.WStakeholders (GenesisWStakeholders (..))
 
+import           Pos.Util.Json.Canonical ()
+
 ----------------------------------------------------------------------------
 -- Primitive standard/3rdparty types
 ----------------------------------------------------------------------------
 
-data SchemaError = SchemaError
-    { seExpected :: !Text
-    , seActual   :: !(Maybe Text)
-    } deriving (Show)
-
-instance Buildable SchemaError where
-    build SchemaError{..} = mconcat
-        [ "expected " <> Builder.fromText seExpected
-        , case seActual of
-            Nothing     -> mempty
-            Just actual -> " but got " <> Builder.fromText actual
-        ]
-
-instance (Monad m, Applicative m, MonadError SchemaError m) => ReportSchemaErrors m where
-    expected expec actual = throwError SchemaError
-        { seExpected = fromString expec
-        , seActual = fmap fromString actual
-        }
-
-instance Monad m => ToJSON m Int32 where
-    toJSON = pure . JSNum . fromIntegral
-
 instance Monad m => ToJSON m Word16 where
     toJSON = pure . JSNum . fromIntegral
 
@@ -304,10 +281,6 @@ wrapConstructor =
 -- External
 ---------------------------------------------------------------------------
 
-instance (ReportSchemaErrors m) => FromJSON m Int32 where
-    fromJSON (JSNum i) = pure . fromIntegral $ i
-    fromJSON val       = expectedButGotValue "Int32" val
-
 instance (ReportSchemaErrors m) => FromJSON m Word16 where
     fromJSON (JSNum i) = pure . fromIntegral $ i
     fromJSON val       = expectedButGotValue "Word16" val

core/src/Pos/Core/Genesis/Initializer.hs

@@ -29,7 +29,7 @@ data GenesisInitializer = GenesisInitializer
       -- 1. Keep it secret and use genesis data generated from it.
       -- 2. Just use it directly and keep it public if you want
       -- to deploy testing cluster.
-    } deriving (Show)
+    } deriving (Eq, Show)
 
 instance Buildable GenesisInitializer where
     build GenesisInitializer {..} = bprint
@@ -59,7 +59,7 @@ data TestnetBalanceOptions = TestnetBalanceOptions
     -- ^ Portion of stake owned by all richmen together.
     , tboUseHDAddresses :: !Bool
     -- ^ Whether generate plain addresses or with hd payload.
-    } deriving (Show)
+    } deriving (Eq, Show)
 
 instance Buildable TestnetBalanceOptions where
     build TestnetBalanceOptions {..} =
@@ -81,7 +81,7 @@ instance Buildable TestnetBalanceOptions where
 data FakeAvvmOptions = FakeAvvmOptions
     { faoCount      :: !Word
     , faoOneBalance :: !Word64
-    } deriving (Show, Generic)
+    } deriving (Eq, Show, Generic)
 
 instance Buildable FakeAvvmOptions where
     build = genericF

core/src/Pos/Core/Genesis/Spec.hs

@@ -33,7 +33,7 @@ data GenesisSpec = UnsafeGenesisSpec
     -- ^ Other constants which affect consensus.
     , gsInitializer       :: !GenesisInitializer
     -- ^ Other data which depend on genesis type.
-    } deriving (Show, Generic)
+    } deriving (Eq, Show, Generic)
 
 -- | Safe constructor for 'GenesisSpec'. Throws error if something
 -- goes wrong.