Skip to content
Permalink
Browse files

Add 'Initial' message-decoder with config parameters

  • Loading branch information...
Anviking committed May 15, 2019
1 parent aecc07f commit 1fad1233366a9c1cf46110d0379989412f7b12a5
@@ -33,8 +33,10 @@ library
-Werror
build-depends:
base
, cardano-wallet-core
, binary
, bytestring
, cardano-wallet-core
, memory
, text
, text-class
hs-source-dirs:
@@ -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,19 +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 )
( Word16, Word32, Word64, Word8 )


-- | Messages are what the block body consists of.
@@ -52,7 +66,7 @@ data Message
| UpdateProposal SignedUpdateProposal
| UpdateVote SignedVote
| UnimplementedMessage Int -- For development. Remove later.
deriving Show
deriving (Eq, Show)


data BlockHeader = BlockHeader
@@ -65,16 +79,21 @@ 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)
newtype Milli = Milli Word64
deriving (Eq, Show)
newtype LeaderId = LeaderId ByteString
deriving (Eq, Show)
data LinearFee = LinearFee Word64 Word64 Word64
deriving (Eq, Show)


{-# ANN getBlockHeader ("HLint: ignore Use <$>" :: String) #-}
getBlockHeader :: Get BlockHeader
@@ -113,14 +132,102 @@ getMessage = do
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


{-------------------------------------------------------------------------------
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)

-- | @TagLen@ contains the tag/type of a @ConfigParam@ as well as the length
-- in number of bytes.
--
-- This information is stored in a /single/ @Word16@ in the binary format.
-- (@getTagLen@)
{-# ANN len ("HLint: ignore Defined but not used" :: String) #-}
{-# ANN tag ("HLint: ignore Defined but not used" :: String) #-}
data TagLen = TagLen { tag :: Int, len :: Int}

getTagLen :: Get TagLen
getTagLen = do
w <- getWord16be
return $ TagLen
{ tag = fromIntegral $ w `shift` (-6)
, len = fromIntegral $ w .&. (63) -- 0b111111
}


getInitial :: Get [ConfigParam]
getInitial = do
len <- fromIntegral <$> getWord16be
replicateM len getConfigParam

getConfigParam :: Get ConfigParam
getConfigParam = do
TagLen tag len <- getTagLen
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
where
getBool = getWord8 >>= \case
1 -> return True
0 -> return False
other -> fail $ "Unexpected boolean integer: " ++ show other

getLinearFee = LinearFee <$> getWord64be <*> getWord64be <*> getWord64be

data Discrimination = Production | Test
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

{-------------------------------------------------------------------------------
Helpers
-------------------------------------------------------------------------------}
@@ -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,48 @@ 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"

0 comments on commit 1fad123

Please sign in to comment.
You can’t perform that action at this time.