Merge pull request #266 from input-output-hk/anviking/218/jörmungandr…

…-config

Add 'Initial' message-decoder with config parameters

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -33,8 +33,9 @@ library
       -Werror
   build-depends:
       base
-    , cardano-wallet-core
     , binary
+    , bytestring
+    , cardano-wallet-core
     , text
     , text-class
   hs-source-dirs:

lib/jormungandr/src/Cardano/Wallet/Binary/Jormungandr.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -12,7 +13,13 @@ module Cardano.Wallet.Binary.Jormungandr
     ( getBlockHeader
     , getBlock
     , Message (..)
+    , Block (..)
     , BlockHeader (..)
+    , ConfigParam (..)
+    , Discrimination (..)
+    , LeaderId (..)
+    , LinearFee (..)
+    , Milli (..)
 
      -- * Re-export
     , runGet
@@ -23,37 +30,26 @@ import Prelude
 
 import Cardano.Wallet.Primitive.Types
     ( Hash (..), SlotId (..) )
+import Control.Monad
+    ( replicateM )
 import Data.Binary.Get
     ( Get
     , getByteString
     , getWord16be
     , getWord32be
+    , getWord64be
     , getWord8
     , isEmpty
     , isolate
     , runGet
     , skip
     )
+import Data.Bits
+    ( shift, (.&.) )
+import Data.ByteString
+    ( ByteString )
 import Data.Word
-    ( Word16, Word32 )
-
-
--- | Messages are what the block body consists of.
---
--- Every message is prefixed with a message header.
---
---  Following, as closely as possible:
--- https://github.com/input-output-hk/rust-cardano/blob/e0616f13bebd6b908320bddb1c1502dea0d3305a/chain-impl-mockchain/src/message/mod.rs#L22-L29
-data Message
-    = Initial [ConfigParam]
-    | OldUtxoDeclaration TODO
-    | Transaction TODO
-    | Certificate TODO
-    | UpdateProposal SignedUpdateProposal
-    | UpdateVote SignedVote
-    | UnimplementedMessage Int -- For development. Remove later.
-    deriving Show
-
+    ( Word16, Word32, Word64, Word8 )
 
 data BlockHeader = BlockHeader
     { version :: Word16
@@ -65,16 +61,15 @@ data BlockHeader = BlockHeader
     } deriving (Show, Eq)
 
 data Block = Block BlockHeader [Message]
-    deriving Show
+    deriving (Eq, Show)
 
 data SignedUpdateProposal = SignedUpdateProposal
-    deriving Show
+    deriving (Eq, Show)
 data TODO = TODO
-    deriving Show
+    deriving (Eq, Show)
 data SignedVote = SignedVote
-    deriving Show
-data ConfigParam = ConfigParam
-    deriving Show
+    deriving (Eq, Show)
+
 
 {-# ANN getBlockHeader ("HLint: ignore Use <$>" :: String) #-}
 getBlockHeader :: Get BlockHeader
@@ -106,21 +101,129 @@ getBlock = do
         $ whileM (not <$> isEmpty) getMessage
     return $ Block header msgs
 
+{-------------------------------------------------------------------------------
+                           Messages
+-------------------------------------------------------------------------------}
+
+-- | Messages are what the block body consists of.
+--
+-- Every message is prefixed with a message header.
+--
+--  Following, as closely as possible:
+-- https://github.com/input-output-hk/rust-cardano/blob/e0616f13bebd6b908320bddb1c1502dea0d3305a/chain-impl-mockchain/src/message/mod.rs#L22-L29
+data Message
+    = Initial [ConfigParam]
+    | OldUtxoDeclaration TODO
+    | Transaction TODO
+    | Certificate TODO
+    | UpdateProposal SignedUpdateProposal
+    | UpdateVote SignedVote
+    | UnimplementedMessage Int -- For development. Remove later.
+    deriving (Eq, Show)
+
 getMessage :: Get Message
 getMessage = do
     size <- fromIntegral <$> getWord16be
     contentType <- fromIntegral <$> getWord8
     let remaining = size - 1
     let unimpl = skip remaining >> return (UnimplementedMessage contentType)
     isolate remaining $ case contentType of
-        0 -> unimpl
+        0 -> Initial <$> getInitial
         1 -> unimpl
         2 -> unimpl
         3 -> unimpl
         4 -> unimpl
         5 -> unimpl
         other -> fail $ "Unexpected content type tag " ++ show other
 
+getInitial :: Get [ConfigParam]
+getInitial = do
+    len <- fromIntegral <$> getWord16be
+    replicateM len getConfigParam
+
+{-------------------------------------------------------------------------------
+                            Config Parameters
+-------------------------------------------------------------------------------}
+
+data ConfigParam
+    -- Seconds elapsed since 1-Jan-1970 (unix time)
+    = Block0Date Word64
+    | ConfigDiscrimination Discrimination
+    | ConsensusVersion Word16 -- ?
+    | SlotsPerEpoch Word32
+    | SlotDuration Word8
+    | EpochStabilityDepth Word32
+    | ConsensusGenesisPraosActiveSlotsCoeff Milli
+    | MaxNumberOfTransactionsPerBlock Word32
+    | BftSlotsRatio Milli
+    | AddBftLeader LeaderId
+    | RemoveBftLeader LeaderId
+    | AllowAccountCreation Bool
+    | ConfigLinearFee LinearFee
+    | ProposalExpiration Word32
+    deriving (Eq, Show)
+
+getConfigParam :: Get ConfigParam
+getConfigParam = do
+    -- The tag and the size/length of the config param is stored in a single
+    -- @Word16@.
+    --
+    -- 6 least-significant bits: length
+    -- 12 most-significant bits: tag
+    taglen <- getWord16be
+    let tag = taglen `shift` (-6)
+    let len = fromIntegral $ taglen .&. (63) -- 0b111111
+
+    isolate len $ case tag of
+        1 -> ConfigDiscrimination <$> getDiscrimination
+        2 -> Block0Date <$> getWord64be
+        3 -> ConsensusVersion <$> getWord16be -- ?
+        4 -> SlotsPerEpoch <$> getWord32be
+        5 -> SlotDuration <$> getWord8
+        6 -> EpochStabilityDepth <$> getWord32be
+        8 -> ConsensusGenesisPraosActiveSlotsCoeff <$> getMilli
+        9 -> MaxNumberOfTransactionsPerBlock <$> getWord32be
+        10 -> BftSlotsRatio <$> getMilli
+        11 -> AddBftLeader <$> getLeaderId
+        12 -> RemoveBftLeader <$> getLeaderId
+        13 -> AllowAccountCreation <$> getBool
+        14 -> ConfigLinearFee <$> getLinearFee
+        15 -> ProposalExpiration <$> getWord32be
+        a -> fail $ "Invalid config param with tag " ++ show a
+
+data Discrimination = Production | Test
+    deriving (Eq, Show)
+
+newtype Milli = Milli Word64
+    deriving (Eq, Show)
+
+newtype LeaderId = LeaderId ByteString
+    deriving (Eq, Show)
+
+data LinearFee = LinearFee Word64 Word64 Word64
+    deriving (Eq, Show)
+
+getDiscrimination :: Get Discrimination
+getDiscrimination = getWord8 >>= \case
+    1 -> return Production
+    2 -> return Test
+    a -> fail $ "Invalid discrimination value: " ++ show a
+
+getMilli :: Get Milli
+getMilli = Milli <$> getWord64be
+
+getLeaderId :: Get LeaderId
+getLeaderId = LeaderId <$> getByteString 32
+
+getLinearFee :: Get LinearFee
+getLinearFee = LinearFee <$> getWord64be <*> getWord64be <*> getWord64be
+
+getBool :: Get Bool
+getBool = getWord8 >>= \case
+    1 -> return True
+    0 -> return False
+    other -> fail $ "Unexpected boolean integer: " ++ show other
+
 {-------------------------------------------------------------------------------
                               Helpers
 -------------------------------------------------------------------------------}

lib/jormungandr/test/unit/Cardano/Wallet/Binary/JormungandrSpec.hs

@@ -7,7 +7,18 @@ module Cardano.Wallet.Binary.JormungandrSpec (spec) where
 import Prelude
 
 import Cardano.Wallet.Binary.Jormungandr
-    ( BlockHeader (..), getBlockHeader, runGet )
+    ( Block (..)
+    , BlockHeader (..)
+    , ConfigParam (..)
+    , Discrimination (..)
+    , LeaderId (..)
+    , LinearFee (..)
+    , Message (..)
+    , Milli (..)
+    , getBlock
+    , getBlockHeader
+    , runGet
+    )
 import Cardano.Wallet.Primitive.Types
     ( Hash (..), SlotId (..) )
 import Data.ByteArray.Encoding
@@ -24,24 +35,61 @@ spec :: Spec
 spec = do
     describe "Decoding blocks" $ do
         it "should decode a genesis block header" $ do
-            runGet getBlockHeader genesisBlock
+            runGet getBlockHeader genesisBlockBinary
             `shouldBe`
-            (BlockHeader
-                { version = 0
-                , contentSize = 159
-                , slot = SlotId {epochNumber = 0 , slotNumber = 0}
-                , chainLength = 0
-                , contentHash = Hash "\255\173\235\254\205Y\217\234\161.\144:\213\129\NUL\247\193\227X\153s\156=\ENQ\208\"\131\\\ACK\157+O"
-                , parentHeaderHash = Hash "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"
-                })
-
-genesisBlock :: BL.ByteString
-genesisBlock = either error BL.fromStrict $ convertFromBase @ByteString Base16
-    "005200000000009f000000000000000000000000ffadebfecd59d9eaa12e903a\
-    \d58100f7c1e35899739c3d05d022835c069d2b4f000000000000000000000000\
-    \00000000000000000000000000000000000000000047000048000000005cc1c2\
-    \4900810200c200010108000000000000087001410f01840000000a01e030a694\
-    \b80dbba2d1b8a4b55652b03d96315c8414b054fa737445ac2d2a865c76002604\
-    \0001000000ff0005000006000000000000000000000000000000000000000000\
-    \0000000000002c020001833324c37869c122689a35917df53a4f2294a3a52f68\
-    \5e05f5f8e53b87e7ea452f000000000000000e"
+            genesisHeader
+
+        it "should decode a genesis block" $ do
+            runGet getBlock genesisBlockBinary
+            `shouldBe`
+            genesisBlock
+
+
+
+genesisHeader :: BlockHeader
+genesisHeader = BlockHeader
+    { version = 0
+    , contentSize = 458
+    , slot = SlotId {epochNumber = 0 , slotNumber = 0}
+    , chainLength = 0
+    , contentHash = Hash "\247\190\205\248\a\199\ACK\206\245N\196\131-*tu\145\195\242\DC4\GS\227\228\242\174\245\154\DC3\r\137\f\DC2"
+    , parentHeaderHash = Hash "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"
+    }
+
+genesisBlock :: Block
+genesisBlock = Block genesisHeader
+    [ Initial
+        [ Block0Date 1556202057
+        , ConfigDiscrimination Test
+        , ConsensusVersion 1
+        , SlotsPerEpoch 2160
+        , SlotDuration 15
+        , EpochStabilityDepth 10
+        , AddBftLeader (LeaderId "0\166\148\184\r\187\162\209\184\164\181VR\176=\150\&1\\\132\DC4\176T\250stE\172-*\134\\v")
+        , ConsensusGenesisPraosActiveSlotsCoeff (Milli 220)
+        , MaxNumberOfTransactionsPerBlock 255
+        , BftSlotsRatio (Milli 220)
+        , AllowAccountCreation True
+        , ConfigLinearFee (LinearFee 0 0 0)
+        ]
+    , UnimplementedMessage 2
+    , UnimplementedMessage 1
+    , UnimplementedMessage 3
+    ]
+
+genesisBlockBinary :: BL.ByteString
+genesisBlockBinary = either error BL.fromStrict $ convertFromBase @ByteString Base16
+    "00520000000001ca000000000000000000000000f7becdf807c706cef54ec4832d2a747591c3f21\
+    \41de3e4f2aef59a130d890c12000000000000000000000000000000000000000000000000000000\
+    \0000000000007c00000c0088000000005cc1c24900410200c2000101040000087001410f0184000\
+    \0000a02e030a694b80dbba2d1b8a4b55652b03d96315c8414b054fa737445ac2d2a865c76020800\
+    \000000000000dc0244000000ff028800000000000000dc034101039800000000000000000000000\
+    \0000000000000000000000000002c020001833324c37869c122689a35917df53a4f2294a3a52f68\
+    \5e05f5f8e53b87e7ea452f000000000000000e00620101000000000000007b005682d818584c835\
+    \81c2ac3cc97bbec476496e84807f35df7349acfbaece200a24b7e26250ca20058208200581ca6d9\
+    \aef475f3418967e87f7e93f20f99d8c7af406cba146affdb71910146450102030405001a89a5937\
+    \100b803000004000000000000000000000000000000d501d0fa7e180d33987d17f77cbf70e1463b\
+    \ce01d32d952ed6f9823f0d69eb37e35f931417c6075e0f3e5858198fe15831ba7fb51368fa2f0ac\
+    \27a799032729e08a624a4aafb7a4dde35e4742d258d04c5f3ec87e616b9bcb0cdc070b503fe634b\
+    \46010040a856b8a6f8d18d588b5e1cfd3ea2e56ae45b80126bb25feb8ccde27fe61ebc7fd64deb7\
+    \667ab1a79ca2448f56e60f3097c2fa657febdec19e7bd7abfb0ea4705"