Merge pull request #245 from input-output-hk/anviking/218/decode-headers

Do some header decoding

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -34,11 +34,7 @@ library
   build-depends:
       base
     , cardano-wallet-core
---    , binary
---    , bytestring
---    , cardano-crypto
---    , cryptonite
---    , digest
+    , binary
     , text
     , text-class
   hs-source-dirs:

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- |
@@ -8,5 +9,129 @@
 -- The format is for the Shelley era as implemented by the Jörmungandr node.
 
 module Cardano.Wallet.Binary.Jormungandr
-    (
+    ( getBlockHeader
+    , getBlock
+    , Message (..)
+    , BlockHeader (..)
+
+     -- * Re-export
+    , runGet
+
     ) where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.Types
+    ( Hash (..), SlotId (..) )
+import Data.Binary.Get
+    ( Get
+    , getByteString
+    , getWord16be
+    , getWord32be
+    , getWord8
+    , isEmpty
+    , isolate
+    , runGet
+    , skip
+    )
+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
+
+
+data BlockHeader = BlockHeader
+    { version :: Word16
+    , contentSize :: Word32
+    , slot :: SlotId
+    , chainLength :: Word32
+    , contentHash :: Hash "content"
+    , parentHeaderHash :: Hash "parentHeader"
+    } deriving (Show, Eq)
+
+data Block = Block BlockHeader [Message]
+    deriving Show
+
+data SignedUpdateProposal = SignedUpdateProposal
+    deriving Show
+data TODO = TODO
+    deriving Show
+data SignedVote = SignedVote
+    deriving Show
+data ConfigParam = ConfigParam
+    deriving Show
+
+{-# ANN getBlockHeader ("HLint: ignore Use <$>" :: String) #-}
+getBlockHeader :: Get BlockHeader
+getBlockHeader =  (fromIntegral <$> getWord16be) >>= \s -> isolate s $ do
+    version <- getWord16be
+    contentSize <- getWord32be
+    slotEpoch <- fromIntegral <$> getWord32be
+    slotId <- fromIntegral <$> getWord32be
+    chainLength <- getWord32be
+    contentHash <- Hash <$> getByteString 32 -- or 256 bits
+    parentHeaderHash <- Hash <$> getByteString 32
+
+    -- TODO: Handle special case for BFT
+    -- TODO: Handle special case for Praos/Genesis
+
+    return $ BlockHeader
+        { version = version
+        , contentSize = contentSize
+        , slot = (SlotId slotId slotEpoch)
+        , chainLength = chainLength
+        , contentHash = contentHash
+        , parentHeaderHash = parentHeaderHash
+        }
+
+getBlock :: Get Block
+getBlock = do
+    header <- getBlockHeader
+    msgs <- isolate (fromIntegral $ contentSize header)
+        $ whileM (not <$> isEmpty) getMessage
+    return $ Block header msgs
+
+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
+        1 -> unimpl
+        2 -> unimpl
+        3 -> unimpl
+        4 -> unimpl
+        5 -> unimpl
+        other -> fail $ "Unexpected content type tag " ++ show other
+
+{-------------------------------------------------------------------------------
+                              Helpers
+-------------------------------------------------------------------------------}
+
+whileM :: Monad m => m Bool -> m a -> m [a]
+whileM cond next = go
+  where
+    go = do
+        c <- cond
+        if c then do
+            a <- next
+            as <- go
+            return (a : as)
+        else return []

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

@@ -2,39 +2,41 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Cardano.Wallet.Binary.JormungandrSpec
-    ( spec
-    ) where
+module Cardano.Wallet.Binary.JormungandrSpec (spec) where
 
 import Prelude
 
 import Cardano.Wallet.Binary.Jormungandr
-    ()
-import Data.ByteString
-    ( ByteString )
-
+    ( BlockHeader (..), getBlockHeader, runGet )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..), Hash (..), SlotId (..) )
-
+    ( Hash (..), SlotId (..) )
 import Data.ByteArray.Encoding
     ( Base (Base16), convertFromBase )
+import Data.ByteString
+    ( ByteString )
 import Test.Hspec
-    ( Spec, describe, shouldBe, xit )
+    ( Spec, describe, it, shouldBe )
+
+import qualified Data.ByteString.Lazy as BL
 
 {-# ANN spec ("HLint: ignore Use head" :: String) #-}
 spec :: Spec
 spec = do
     describe "Decoding blocks" $ do
-        xit "should decode a genesis block" $ do
-            unsafeDeserialiseFromBytes decodeGenesisBlock genesisBlock
+        it "should decode a genesis block header" $ do
+            runGet getBlockHeader genesisBlock
             `shouldBe`
-            BlockHeader (SlotId 0 0) (Hash "?")
-  where
-    unsafeDeserialiseFromBytes = undefined
-    decodeGenesisBlock = error "TODO: import from Binary.Jormungandr"
+            (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 :: ByteString
-genesisBlock = either error id $ convertFromBase @ByteString Base16
+genesisBlock :: BL.ByteString
+genesisBlock = either error BL.fromStrict $ convertFromBase @ByteString Base16
     "005200000000009f000000000000000000000000ffadebfecd59d9eaa12e903a\
     \d58100f7c1e35899739c3d05d022835c069d2b4f000000000000000000000000\
     \00000000000000000000000000000000000000000047000048000000005cc1c2\