payload: encode payloads without base64

Signed-off-by: Austin Seipp <[email protected]>
Change-Id: I832611067595ae19b6deeb5e8faf68ec367e7b1e

src/Chainweb/Payload.hs

@@ -59,6 +59,19 @@ module Chainweb.Payload
 , BlockTransactions_(..)
 , verifyBlockPayload
 
+-- * Binary encodings
+
+, encodeBlockPayloads
+, decodeBlockPayloads
+, encodeBlockTransactions
+, decodeBlockTransactions
+, encodeBlockOutputs
+, decodeBlockOutputs
+, encodeTransactionTree
+, decodeTransactionTree
+, encodeOutputTree
+, decodeOutputTree
+
 -- * Redundant Data / Caches
 
 , BlockOutputs
@@ -110,7 +123,7 @@ module Chainweb.Payload
 ) where
 
 import Control.DeepSeq
-import Control.Monad ((<$!>))
+import Control.Monad
 import Control.Monad.Catch
 
 import Data.Aeson
@@ -138,6 +151,7 @@ import Chainweb.Storage.Table
 
 import Chainweb.Utils
 import Chainweb.Utils.Serialization
+import Crypto.Hash.Algorithms
 
 -- -------------------------------------------------------------------------- --
 -- Block Transactions Hash
@@ -476,6 +490,110 @@ data BlockTransactions_ a = BlockTransactions
     }
     deriving (Show, Eq, Ord, Generic)
 
+-- -------------------------------------------------------------------------- --
+
+encodeBlockPayloads :: BlockPayload_ a -> B.ByteString
+encodeBlockPayloads BlockPayload{..} = runPutS $ do
+    encodeBlockPayloadHash _blockPayloadPayloadHash
+    encodeBlockTransactionsHash _blockPayloadTransactionsHash
+    encodeBlockOutputsHash _blockPayloadOutputsHash
+
+decodeBlockPayloads :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (BlockPayload_ a)
+decodeBlockPayloads = runGetS $ BlockPayload
+    <$> decodeBlockPayloadHash
+    <*> decodeBlockTransactionsHash
+    <*> decodeBlockOutputsHash
+
+encodeBlockTransactions :: BlockTransactions_ a -> B.ByteString
+encodeBlockTransactions txs = runPutS $ do
+    encodeBlockTransactionsHash (_blockTransactionsHash txs)
+    putWord64be (fromIntegral $ V.length (_blockTransactions txs))
+    forM_ (_blockTransactions txs) $ \tx -> do
+        putWord64be (fromIntegral $ B.length (_transactionBytes tx))
+        putByteString (_transactionBytes tx)
+    putWord64be (fromIntegral $ B.length $ _minerData $ _blockMinerData txs)
+    putByteString (_minerData $ _blockMinerData txs)
+
+decodeBlockTransactions :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (BlockTransactions_ a)
+decodeBlockTransactions = runGetS $ do
+    hsh <- decodeBlockTransactionsHash
+    txsCount <- fromIntegral <$> getWord64be
+    txs <- replicateM txsCount $ do
+        txSz <- fromIntegral <$> getWord64be
+        txData <- getByteString txSz
+        pure $ Transaction txData
+    minerDataSz <- fromIntegral <$> getWord64be
+    minerData <- MinerData <$> getByteString minerDataSz
+    return BlockTransactions
+        { _blockTransactionsHash = hsh
+        , _blockTransactions = V.fromList txs
+        , _blockMinerData = minerData
+        }
+
+encodeBlockOutputs :: BlockOutputs_ a -> B.ByteString
+encodeBlockOutputs bo = runPutS $ do
+    encodeBlockOutputsHash (_blockOutputsHash bo)
+    putWord64be (fromIntegral $ V.length (_blockOutputs bo))
+    forM_ (_blockOutputs bo) $ \tx -> do
+        putWord64be (fromIntegral $ B.length (_transactionOutputBytes tx))
+        putByteString (_transactionOutputBytes tx)
+    putWord64be (fromIntegral $ B.length $ _coinbaseOutput $ _blockCoinbaseOutput bo)
+    putByteString $ _coinbaseOutput $ _blockCoinbaseOutput bo
+
+decodeBlockOutputs :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (BlockOutputs_ a)
+decodeBlockOutputs = runGetS $ do
+    hsh <- decodeBlockOutputsHash
+    txsCount <- fromIntegral <$> getWord64be
+    txs <- replicateM txsCount $ do
+        txSz <- fromIntegral <$> getWord64be
+        txData <- getByteString txSz
+        pure $ TransactionOutput txData
+    coinbaseSz <- fromIntegral <$> getWord64be
+    coinbaseData <- getByteString coinbaseSz
+    return BlockOutputs
+        { _blockOutputsHash = hsh
+        , _blockOutputs = V.fromList txs
+        , _blockCoinbaseOutput = CoinbaseOutput coinbaseData
+        }
+
+encodeTransactionTree :: TransactionTree_ a -> B.ByteString
+encodeTransactionTree tt = runPutS $ do
+    encodeBlockTransactionsHash (_transactionTreeHash tt)
+    let bs = encodeMerkleTree (_transactionTree tt)
+    putWord64be (fromIntegral $ B.length bs)
+    putByteString bs
+
+decodeTransactionTree :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (TransactionTree_ a)
+decodeTransactionTree = runGetS $ do
+    hsh <- decodeBlockTransactionsHash
+    sz <- fromIntegral <$> getWord64be
+    bs <- getByteString sz
+    mt <- decodeMerkleTree bs
+    return TransactionTree
+        { _transactionTreeHash = hsh
+        , _transactionTree = mt
+        }
+
+encodeOutputTree :: OutputTree_ a -> B.ByteString
+encodeOutputTree ot = runPutS $ do
+    encodeBlockOutputsHash (_outputTreeHash ot)
+    let bs = encodeMerkleTree (_outputTree ot)
+    putWord64be (fromIntegral $ B.length bs)
+    putByteString bs
+
+decodeOutputTree :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (OutputTree_ a)
+decodeOutputTree = runGetS $ do
+    hsh <- decodeBlockOutputsHash
+    sz <- fromIntegral <$> getWord64be
+    bs <- getByteString sz
+    mt <- decodeMerkleTree bs
+    return OutputTree
+        { _outputTreeHash = hsh
+        , _outputTree = mt
+        }
+
+-- -------------------------------------------------------------------------- --
+
 blockTransactionsProperties
     :: MerkleHashAlgorithm a
     => A.KeyValue e kv

src/Chainweb/Payload/PayloadStore/RocksDB.hs

@@ -45,15 +45,15 @@ newTransactionDb db = TransactionDb
 
     newBlockPayloadStore :: RocksDbTable (BlockHeight, BlockPayloadHash) BlockPayload
     newBlockPayloadStore = newTable db
-        (Codec encodeToByteString decodeStrictOrThrow')
+        (Codec encodeBlockPayloads decodeBlockPayloads)
         (Codec
           (\(bh, bp) -> runPutS (encodeBlockHeight bh >> encodeBlockPayloadHash bp))
           (runGetS ((,) <$> decodeBlockHeight <*> decodeBlockPayloadHash)))
         ["BlockPayload2"]
 
     newBlockTransactionsStore :: RocksDbTable (BlockHeight, BlockTransactionsHash) BlockTransactions
     newBlockTransactionsStore = newTable db
-        (Codec encodeToByteString decodeStrictOrThrow')
+        (Codec encodeBlockTransactions decodeBlockTransactions)
         (Codec
           (\(h, hsh) -> runPutS $ encodeBlockHeight h >> encodeBlockTransactionsHash hsh)
           (runGetS ((,) <$> decodeBlockHeight <*> decodeBlockTransactionsHash)))
@@ -88,7 +88,7 @@ newPayloadDb db = PayloadDb (newTransactionDb db) newPayloadCache
 
         newBlockOutputsTbl :: RocksDbTable (BlockHeight, BlockOutputsHash) BlockOutputs
         newBlockOutputsTbl = newTable db
-            (Codec encodeToByteString decodeStrictOrThrow')
+            (Codec encodeBlockOutputs decodeBlockOutputs)
             (Codec
                 (\(h, hsh) -> runPutS $ encodeBlockHeight h >> encodeBlockOutputsHash hsh)
                 (runGetS $ (,) <$> decodeBlockHeight <*> decodeBlockOutputsHash))
@@ -105,7 +105,7 @@ newPayloadDb db = PayloadDb (newTransactionDb db) newPayloadCache
 
         newTransactionTreeTbl :: RocksDbTable (BlockHeight, BlockTransactionsHash) TransactionTree
         newTransactionTreeTbl = newTable db
-            (Codec encodeToByteString decodeStrictOrThrow')
+            (Codec encodeTransactionTree decodeTransactionTree)
             (Codec
                 (\(h, hsh) -> runPutS $ encodeBlockHeight h >> encodeBlockTransactionsHash hsh)
                 (runGetS $ (,) <$> decodeBlockHeight <*> decodeBlockTransactionsHash))
@@ -122,7 +122,7 @@ newPayloadDb db = PayloadDb (newTransactionDb db) newPayloadCache
 
         newOutputTreeTbl :: RocksDbTable (BlockHeight, BlockOutputsHash) OutputTree
         newOutputTreeTbl = newTable db
-            (Codec encodeToByteString decodeStrictOrThrow')
+            (Codec encodeOutputTree decodeOutputTree)
             (Codec
                 (\(h, hsh) -> runPutS $ encodeBlockHeight h >> encodeBlockOutputsHash hsh)
                 (runGetS $ (,) <$> decodeBlockHeight <*> decodeBlockOutputsHash))

test/Chainweb/Test/Misc.hs

@@ -13,11 +13,15 @@ module Chainweb.Test.Misc
   ( tests
   ) where
 
+import Chainweb.Payload
+import Chainweb.Test.Orphans.Internal ()
+
 import Control.Concurrent (threadDelay)
 import Control.Scheduler (Comp(..), scheduleWork, terminateWith, withScheduler)
 
 import Test.Tasty
 import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
 
 ---
 
@@ -26,6 +30,11 @@ tests = testGroup "Misc. Unit Tests"
     [ testGroup "scheduler"
           [ testCase "early termination result order" terminateOrder
           ]
+    , testGroup "binary encoding"
+          [ testProperty "BlockPayload" propPayloadBinaryEncoding
+          , testProperty "BlockTransactions" propBlockTransactionsEncoding
+          , testProperty "BlockOutputs" propBlockOutputsEncoding
+          ]
     ]
 
 -- | Guarantee that `terminateWith` makes the scheduler's "head" return value be
@@ -37,3 +46,18 @@ terminateOrder = do
         scheduleWork sch (threadDelay 5_000_000 >> pure 1)
         scheduleWork sch (terminateWith sch 10)
     head r @?= (10 :: Int)
+
+propPayloadBinaryEncoding :: BlockPayload -> Bool
+propPayloadBinaryEncoding bp 
+  | Right x <- decodeBlockPayloads (encodeBlockPayloads bp) = x == bp
+  | otherwise = False
+
+propBlockTransactionsEncoding :: BlockTransactions -> Bool
+propBlockTransactionsEncoding bt
+  | Right x <- decodeBlockTransactions (encodeBlockTransactions bt) = x == bt
+  | otherwise = False
+
+propBlockOutputsEncoding :: BlockOutputs -> Bool
+propBlockOutputsEncoding bo
+  | Right x <- decodeBlockOutputs (encodeBlockOutputs bo) = x == bo
+  | otherwise = False