Try #1012:

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

@@ -30,7 +30,7 @@ import Prelude
 
 import Cardano.Wallet.Jormungandr.Binary
     ( Block
-    , MessageType (..)
+    , FragmentSpec (..)
     , getBlock
     , putSignedTx
     , runGet
@@ -181,7 +181,7 @@ instance MimeUnrender JormungandrBinary Block where
 
 instance MimeRender JormungandrBinary (Tx, [TxWitness]) where
     mimeRender _ (Tx _ ins outs, wits) =
-        runPut $ withHeader MsgTypeTransaction $ putSignedTx ins outs wits
+        runPut $ withHeader FragmentTransaction $ putSignedTx ins outs wits
 
 data Hex
 

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Client.hs

@@ -56,7 +56,7 @@ import Cardano.Wallet.Jormungandr.Api
     , api
     )
 import Cardano.Wallet.Jormungandr.Binary
-    ( ConfigParam (..), Message (..), convertBlock )
+    ( ConfigParam (..), Fragment (..), convertBlock )
 import Cardano.Wallet.Jormungandr.Compatibility
     ( softTxMaxSize )
 import Cardano.Wallet.Network

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

@@ -13,11 +13,11 @@
 -- License: Apache-2.0
 --
 -- The format is for the Shelley era as implemented by the Jörmungandr node.
--- It is described [here](https://github.com/input-output-hk/chain-libs/blob/master/chain-impl-mockchain/doc/format.md)
+-- It is described [here](https://github.com/input-output-hk/chain-libs/blob/master/chain-impl-mockchain/doc/format.abnf)
 --
 -- The module to some extent defines its own Jörmungandr-specific types,
 -- different from "Cardano.Wallet.Primitive.Types". Here, transactions are just
--- one of many possible 'Message's that can be included in a block.
+-- one of many possible 'Fragment' that can be included in a block.
 --
 -- In some cases it also leads us to /throw exceptions/ when integers would
 -- otherwise overflow (look for uses of 'toEnum').
@@ -28,13 +28,13 @@ module Cardano.Wallet.Jormungandr.Binary
     , ConfigParam (..)
     , ConsensusVersion (..)
     , LeaderId (..)
-    , Message (..)
-    , MessageType (..)
+    , Fragment (..)
+    , FragmentSpec (..)
     , Milli (..)
     , getBlock
     , getBlockHeader
     , getBlockId
-    , getMessage
+    , getFragment
     , getTransaction
     , putSignedTx
     , putTx
@@ -111,7 +111,6 @@ import Data.Binary.Get
     , getByteString
     , getLazyByteString
     , getWord16be
-    , getWord16le
     , getWord32be
     , getWord64be
     , getWord8
@@ -125,14 +124,7 @@ import Data.Binary.Get
     , skip
     )
 import Data.Binary.Put
-    ( Put
-    , putByteString
-    , putWord16be
-    , putWord16le
-    , putWord64be
-    , putWord8
-    , runPut
-    )
+    ( Put, putByteString, putWord16be, putWord64be, putWord8, runPut )
 import Data.Bits
     ( shift, (.&.) )
 import Data.ByteString
@@ -181,7 +173,7 @@ data BlockHeader = BlockHeader
 
 data Block = Block
     { header :: BlockHeader
-    , messages :: [Message]
+    , fragments :: [Fragment]
     } deriving (Eq, Show)
 
 getBlockHeader :: Get BlockHeader
@@ -195,7 +187,7 @@ getBlockHeader = label "getBlockHeader" $ do
         slotEpoch <- fromIntegral <$> getWord32be
         slotId <- toEnum . fromEnum <$> getWord32be
         chainLength <- getWord32be
-        contentHash <- Hash <$> getByteString 32 -- or 256 bits
+        contentHash <- Hash <$> getByteString 32
         parentHeaderHash <- Hash <$> getByteString 32
         let headerHash = Hash $ blake2b256 bytes
         -- Proof.
@@ -207,8 +199,7 @@ getBlockHeader = label "getBlockHeader" $ do
         -- We could make sure we get the right kind of proof, but we don't need
         -- to.  Just checking that the length is not totally wrong is much
         -- simpler and gives us sanity about the binary format being correct.
-        read' <- fromIntegral <$> bytesRead
-        let remaining = size - read'
+        remaining <- (size -) . fromIntegral <$> bytesRead
         producedBy <- case remaining of
             0 ->
                 -- no proof
@@ -235,9 +226,9 @@ getBlockHeader = label "getBlockHeader" $ do
 getBlock :: Get Block
 getBlock = label "getBlock" $ do
     header <- getBlockHeader
-    messages <- isolate (fromIntegral $ contentSize header)
-        (whileM (not <$> isEmpty) getMessage)
-    return $ Block{header,messages}
+    fragments <- isolate (fromIntegral $ contentSize header)
+        (whileM (not <$> isEmpty) getFragment)
+    return $ Block{header,fragments}
 
 -- | Extract a 'Block' id from a serialized 'Block'.
 getBlockId :: Get (Hash "BlockHeader")
@@ -247,29 +238,38 @@ getBlockId = lookAhead getBlock *> label "getBlockId" (do
     return $ Hash $ blake2b256 bytes)
 
 {-------------------------------------------------------------------------------
-                           Messages
+                           Fragments
 -------------------------------------------------------------------------------}
 
--- | The block-body consists of messages. There are several types of messages.
---
---  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
+-- | The block-body consists of fragments. There are several types of fragments.
+data Fragment
     = Initial [ConfigParam]
     -- ^ Found in the genesis block.
     | Transaction (Tx, [TxWitness])
     -- ^ A standard signed transaction
     | StakeDelegation (PoolId, ChimericAccount, Tx, [TxWitness])
     -- ^ A signed transaction with stake pool delegation
-    | UnimplementedMessage Int
-    -- Messages not yet supported go there.
+    | UnimplementedFragment Word8
+    -- Fragments not yet supported go there.
     deriving (Eq, Show)
 
-data MessageType
-    = MsgTypeInitial
-    | MsgTypeLegacyUTxO
-    | MsgTypeTransaction
-    | MsgTypeDelegation
+data FragmentSpec
+    = FragmentInitial
+    | FragmentLegacyUTxO
+    | FragmentTransaction
+    | FragmentDelegation
+
+putFragmentSpec :: FragmentSpec -> Put
+putFragmentSpec spec = do
+    putWord8 0x00
+    putWord8 (fragmentSpec spec)
+  where
+    fragmentSpec :: FragmentSpec -> Word8
+    fragmentSpec = \case
+        FragmentInitial -> 0
+        FragmentLegacyUTxO -> 1
+        FragmentTransaction -> 2
+        FragmentDelegation -> 4
 
 data TxWitnessTag
     = TxWitnessLegacyUTxO
@@ -293,9 +293,9 @@ getTxWitnessTag = getWord8 >>= \case
     3 -> pure TxWitnessMultisig
     other -> fail $ "Invalid witness type: " ++ show other
 
--- | Decode a message (header + contents).
-getMessage :: Get Message
-getMessage = label "getMessage" $ do
+-- | Decode a fragment (header + contents).
+getFragment :: Get Fragment
+getFragment = label "getFragment" $ do
     size <- fromIntegral <$> getWord16be
 
     -- We lazily compute the fragment-id, using lookAHead, before calling the
@@ -305,33 +305,29 @@ getMessage = label "getMessage" $ do
     -- corresponds to the txId (a.k.a "tx hash").
     fragId <- Hash . blake2b256 . BL.toStrict
         <$> lookAhead (getLazyByteString $ fromIntegral size)
-    msgType <- fromIntegral <$> getWord16le
+
+    -- A null byte for later extension
+    _nullByte <- getWord8
+    fragSpec <- getWord8
     let remaining = size - 2
-    let unimpl = skip remaining >> return (UnimplementedMessage msgType)
-    let typeLabelStr = "fragmentType " ++ show msgType
+    let unimpl = skip remaining >> return (UnimplementedFragment fragSpec)
+    let typeLabelStr = "fragmentType " ++ show fragSpec
 
-    label typeLabelStr $ isolate remaining $ case msgType of
+    label typeLabelStr $ isolate remaining $ case fragSpec of
         0 -> Initial <$> getInitial
         1 -> Transaction <$> getLegacyTransaction fragId
         2 -> Transaction <$> getTransaction fragId
         3 -> unimpl -- OwnerStakeDelegation
-        4 -> maybe (UnimplementedMessage msgType) StakeDelegation <$>
-            lookAheadM (getStakeDelegation fragId)
+        4 -> maybe (UnimplementedFragment fragSpec) StakeDelegation
+            <$> lookAheadM (getStakeDelegation fragId)
         5 -> unimpl -- PoolRegistration
         6 -> unimpl -- PoolRetirement
         7 -> unimpl -- PoolUpdate
         8 -> unimpl -- UpdateProposal
         9 -> unimpl -- UpdateVote
         other -> fail $ "Unexpected content type tag " ++ show other
 
-messageTypeTag :: MessageType -> Word16
-messageTypeTag = \case
-    MsgTypeInitial -> 0
-    MsgTypeLegacyUTxO -> 1
-    MsgTypeTransaction -> 2
-    MsgTypeDelegation -> 4
-
--- | Decode the contents of a @Initial@-message.
+-- | Decode the contents of a @Initial@-fragment.
 getInitial :: Get [ConfigParam]
 getInitial = label "getInitial" $ do
     len <- fromIntegral <$> getWord16be
@@ -341,6 +337,10 @@ getInitial = label "getInitial" $ do
                                 Transactions
 -------------------------------------------------------------------------------}
 
+data AccountType
+    = SingleAccount
+    | MultiAccount
+
 txWitnessSize :: TxWitnessTag -> Int
 txWitnessSize = \case
     TxWitnessLegacyUTxO -> 128
@@ -375,7 +375,7 @@ stakeDelegationTypeTag = \case
     DlgFull -> 1
     DlgRatio -> 2
 
--- | Decode the contents of a @Transaction@-message carrying a delegation cert.
+-- | Decode the contents of a @Transaction@-fragment carrying a delegation cert.
 --
 -- Returns 'Nothing' for unsupported stake delegation types: DLG-NONE & DLG-RATIO
 getStakeDelegation
@@ -396,7 +396,7 @@ getStakeDelegation tid = do
     getStakeDelegationFull accId = Just <$> do
         poolId <- getByteString 32
         (tx, wits) <- getGenericTransaction tid
-        _accSignature <- getByteString 64
+        _accSignature <- getByteString 65
         pure (PoolId poolId, ChimericAccount accId, tx, wits )
 
     getStakeDelegationRatio =
@@ -419,12 +419,25 @@ putStakeDelegationTx
     -> [TxOut]
     -> [TxWitness]
     -> Put
-putStakeDelegationTx poolId accId (Hash accSig) inputs outputs witnesses = do
+putStakeDelegationTx poolId accId accSig inputs outputs witnesses = do
     putStakeCertificate poolId accId
     putSignedTx inputs outputs witnesses
+    putAccountSignature SingleAccount accSig
+
+putAccountSignature
+    :: AccountType
+    -> Hash "AccountSignature"
+    -> Put
+putAccountSignature tag (Hash accSig) = do
+    putWord8 (accountType tag)
     putByteString accSig
+  where
+    accountType :: AccountType -> Word8
+    accountType = \case
+        SingleAccount -> 0x01
+        MultiAccount  -> 0x02
 
--- | Decode the contents of a @Transaction@-message.
+-- | Decode the contents of a @Transaction@-fragment.
 getTransaction :: Hash "Tx" -> Get (Tx, [TxWitness])
 getTransaction = label "getTransaction" . getGenericTransaction
 
@@ -681,17 +694,23 @@ putAddress (Address bs) = putByteString bs
                               Helpers
 -------------------------------------------------------------------------------}
 
--- | Add a corresponding header to a message. Every message is encoded as:
---
---     HEADER(MESSAGE) | MESSAGE
---
--- where `HEADER` is:
---
---     SIZE (2 bytes) | TYPE (1 byte)
+-- | Add a corresponding header to a fragment. Every fragment is encoded as:
 --
-withHeader :: MessageType -> Put -> Put
-withHeader typ content = do
-    let bs = BL.toStrict $ runPut (putWord16le (messageTypeTag typ) *> content)
+-- FRAGMENT         = FRAGMENT-SIZE %x00 FRAGMENT-SPEC
+-- FRAGMENT-SIZE    = SIZE-BYTES-16BIT
+-- FRAGMENT-SPEC    = %x00 INITIAL
+--                  / %x01 OLD-UTXO-DECL
+--                  / %x02 SIMPLE-TRANSACTION
+--                  / %x03 OWNER-STAKE-DELEGATION
+--                  / %x04 STAKE-DELEGATION
+--                  / %x05 POOL-REGISTRATION
+--                  / %x06 POOL-RETIREMENT
+--                  / %x07 POOL-UPDATE
+--                  / %x08 UPDATE-PROPOSAL
+--                  / %x09 UPDATE-VOTE
+withHeader :: FragmentSpec -> Put -> Put
+withHeader spec content = do
+    let bs = BL.toStrict $ runPut (putFragmentSpec spec *> content)
     putWord16be (toEnum $ BS.length bs)
     putByteString bs
 
@@ -706,7 +725,7 @@ estimateMaxNumberOfInputsParams
     :: EstimateMaxNumberOfInputsParams t
 estimateMaxNumberOfInputsParams = EstimateMaxNumberOfInputsParams
     { estMeasureTx = \ins outs wits -> fromIntegral $ BL.length $
-        runPut $ withHeader MsgTypeTransaction $
+        runPut $ withHeader FragmentTransaction $
             putSignedTx (map (, Coin 0) ins) outs wits
 
     -- Block IDs are always this long.
@@ -727,7 +746,7 @@ fragmentId
     -> Hash "Tx"
 fragmentId inps outs wits =
     Hash $ blake2b256 $ BL.toStrict $ runPut $ do
-        putWord16le (messageTypeTag MsgTypeTransaction)
+        putFragmentSpec FragmentTransaction
         putSignedTx inps outs wits
 
 delegationFragmentId
@@ -740,7 +759,7 @@ delegationFragmentId
     -> Hash "Tx"
 delegationFragmentId poolId accId accSig inps outs wits =
     Hash $ blake2b256 $ BL.toStrict $ runPut $ do
-        putWord16le (messageTypeTag MsgTypeDelegation)
+        putFragmentSpec FragmentDelegation
         putStakeDelegationTx poolId accId accSig inps outs wits
 
 -- | See 'fragmentId'. This computes the signing data required for producing
@@ -760,13 +779,13 @@ signData inps outs =
 -- | Convert the Jörmungandr binary format block into a simpler Wallet block.
 convertBlock :: Block -> W.Block
 convertBlock (Block h msgs) =
-    W.Block (convertBlockHeader h) coerceMessages
+    W.Block (convertBlockHeader h) coerceFragments
   where
-    coerceMessages = msgs >>= \case
+    coerceFragments = msgs >>= \case
         Initial _ -> []
         Transaction (tx, _wits) -> return tx
         StakeDelegation (_poolId, _xpub, tx, _wits) -> return tx
-        UnimplementedMessage _ -> []
+        UnimplementedFragment _ -> []
 
 -- | Convert the Jörmungandr binary format header into a simpler Wallet header.
 convertBlockHeader :: BlockHeader -> W.BlockHeader

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

@@ -18,9 +18,9 @@ module Cardano.Wallet.Jormungandr.Transaction
 import Prelude
 
 import Cardano.Wallet.Jormungandr.Binary
-    ( Message (..)
+    ( Fragment (..)
     , fragmentId
-    , getMessage
+    , getFragment
     , legacyUtxoWitness
     , maxNumberOfInputs
     , maxNumberOfOutputs
@@ -98,7 +98,7 @@ newTransactionLayer (Hash block0H) = TransactionLayer
     , decodeSignedTx = \payload -> do
         let errInvalidPayload =
                 ErrDecodeSignedTxWrongPayload "wrongly constructed binary blob"
-        case runGetOrFail getMessage (BL.fromStrict payload) of
+        case runGetOrFail getFragment (BL.fromStrict payload) of
             Left _ -> Left errInvalidPayload
             Right (_,_,msg) -> case msg of
                 Transaction stx -> pure stx

lib/jormungandr/test/data/jormungandr/funds/regenerate.sh

@@ -6,7 +6,7 @@ set -euo pipefail
 # First argument is the index for the account. (e.g. "1")
 # Second argument is the folder-name for the stake-pool (e.g. "a")
 delegate () {
-  jcli certificate new stake-delegation $(cat ../stake_pools/$2/pool_id) $(cat account$1.pub) > stake_delegation$1.cert
+  jcli certificate new stake-delegation $(cat account$1.pub) $(cat ../stake_pools/$2/stake_pool.id) > stake_delegation$1.cert
   cat stake_delegation$1.cert | jcli certificate sign -k account$1.prv > stake_delegation$1.signedcert
 }
 

lib/jormungandr/test/data/jormungandr/funds/stake_delegation1.cert

@@ -1 +1 @@
-cert1qxkalz75s4vtw2e9wsy2q9jvsu3qtz6d2vm3xj4e5q4ufejpjjfn5q2wlgecssyxf683fx6z0kaj9hrwgnlld5u4q4npmpjfjx2dwvuswqyxhn7l
+cert1qxkalz75s4vtw2e9wsy2q9jvsu3qtz6d2vm3xj4e5q4ufejpjjfn5q20345x5qkxucjmtfvue83rfuewt4efsuqjl8p9exntvrw6mcvh6y2k8z3n