payloads: support octet-stream content type with binary encoding

Mostly a transparent change for the server-side API handlers, with the proper
encoding/decoding functions added.

Client support will be added in an upcoming diff.

Change-Id: I3824265421303278d5394711a4d789c86a364f87

src/Chainweb/BlockHeaderDB/RestAPI.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 
 -- |
 -- Module: Chainweb.BlockHeaderDB.RestAPI
@@ -90,6 +91,7 @@ module Chainweb.BlockHeaderDB.RestAPI
 
 import Data.Aeson
 import Data.Bifunctor
+import Data.ByteString.Lazy qualified as L
 import Data.Maybe
 import Data.Proxy
 import Data.Text (Text)
@@ -195,6 +197,80 @@ instance MimeRender JsonBlockHeaderObject BlockHeaderPage where
     mimeRender _ = encode . fmap ObjectEncoded
     {-# INLINE mimeRender #-}
 
+-- -------------------------------------------------------------------------- --
+
+instance MimeRender OctetStream BlockPayload where
+    mimeRender _ = L.fromStrict . encodeBlockPayloads
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream BlockPayload where
+    mimeUnrender _ = first show . decodeBlockPayloads . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream BlockTransactions where
+    mimeRender _ = L.fromStrict . encodeBlockTransactions
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream BlockTransactions where
+    mimeUnrender _ = first show . decodeBlockTransactions . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream BlockOutputs where
+    mimeRender _ = L.fromStrict . encodeBlockOutputs
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream BlockOutputs where
+    mimeUnrender _ = first show . decodeBlockOutputs . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream TransactionTree where
+    mimeRender _ = L.fromStrict . encodeTransactionTree
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream TransactionTree where
+    mimeUnrender _ = first show . decodeTransactionTree . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream OutputTree where
+    mimeRender _ = L.fromStrict . encodeOutputTree
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream OutputTree where
+    mimeUnrender _ = first show . decodeOutputTree . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream PayloadWithOutputs where
+    mimeRender _ = L.fromStrict . encodePayloadWithOutputs
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream PayloadWithOutputs where
+    mimeUnrender _ = first show . decodePayloadWithOutputs . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream PayloadData where
+    mimeRender _ = L.fromStrict . encodePayloadData
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream PayloadData where
+    mimeUnrender _ = first show . decodePayloadData . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream PayloadDataList where
+    mimeRender _ = L.fromStrict . encodePayloadDataList
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream PayloadDataList where
+    mimeUnrender _ = first show . decodePayloadDataList . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
+instance MimeRender OctetStream PayloadWithOutputsList where
+    mimeRender _ = L.fromStrict . encodePayloadWithOutputsList
+    {-# INLINE mimeRender #-}
+
+instance MimeUnrender OctetStream PayloadWithOutputsList where
+    mimeUnrender _ = first show . decodePayloadWithOutputsList . L.toStrict
+    {-# INLINE mimeUnrender #-}
+
 -- -------------------------------------------------------------------------- --
 -- Type indexed BlockHeaderDb
 
@@ -492,4 +568,3 @@ type BlockStreamApi_ =
 -- | A stream of all new blocks that are accepted into the true `Cut`.
 --
 type BlockStreamApi (v :: ChainwebVersionT) = 'ChainwebEndpoint v :> BlockStreamApi_
-

src/Chainweb/Payload.hs

@@ -73,6 +73,14 @@ module Chainweb.Payload
 , decodeTransactionTree
 , encodeOutputTree
 , decodeOutputTree
+, encodePayloadData
+, decodePayloadData
+, encodePayloadWithOutputs
+, decodePayloadWithOutputs
+, encodePayloadDataList
+, decodePayloadDataList
+, encodePayloadWithOutputsList
+, decodePayloadWithOutputsList
 
 -- * Redundant Data / Caches
 
@@ -616,6 +624,126 @@ decodeOutputTree = runGetS $ do
         , _outputTree = mt
         }
 
+encodeMinerData :: MinerData -> Put
+encodeMinerData (MinerData md) = do
+    putWord64be (fromIntegral $ B.length md)
+    putByteString md
+
+decodeMinerData :: Get MinerData
+decodeMinerData = do
+    sz <- fromIntegral <$> getWord64be
+    MinerData <$> getByteString sz
+
+putPayloadData :: PayloadData_ a -> Put
+putPayloadData pd = do
+    -- first encode _payloadDataTransactions: Vector Transaction
+    putWord64be (fromIntegral $ V.length (_payloadDataTransactions pd))
+    forM_ (_payloadDataTransactions pd) $ \tx -> do
+        putWord64be (fromIntegral $ B.length (_transactionBytes tx))
+        putByteString (_transactionBytes tx)
+    encodeMinerData (_payloadDataMiner pd)
+    encodeBlockPayloadHash (_payloadDataPayloadHash pd)
+    encodeBlockTransactionsHash (_payloadDataTransactionsHash pd)
+    encodeBlockOutputsHash (_payloadDataOutputsHash pd)
+
+getPayloadData :: HashAlgorithm a => Get (PayloadData_ a)
+getPayloadData = do
+    txsCount <- fromIntegral <$> getWord64be
+    txs <- replicateM txsCount $ do
+        txSz <- fromIntegral <$> getWord64be
+        txData <- getByteString txSz
+        pure $ Transaction txData
+    minerData <- decodeMinerData
+    payloadHash <- decodeBlockPayloadHash
+    txHash <- decodeBlockTransactionsHash
+    outHash <- decodeBlockOutputsHash
+    return PayloadData
+        { _payloadDataTransactions = V.fromList txs
+        , _payloadDataMiner = minerData
+        , _payloadDataPayloadHash = payloadHash
+        , _payloadDataTransactionsHash = txHash
+        , _payloadDataOutputsHash = outHash
+        }
+
+decodePayloadData :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (PayloadData_ a)
+decodePayloadData = runGetS getPayloadData
+
+encodePayloadData :: PayloadData_ a -> B.ByteString
+encodePayloadData = runPutS . putPayloadData
+
+encodeCoinbaseOutput :: CoinbaseOutput -> Put
+encodeCoinbaseOutput (CoinbaseOutput co) = do
+    putWord64be (fromIntegral $ B.length co)
+    putByteString co
+
+decodeCoinbaseOutput :: Get CoinbaseOutput
+decodeCoinbaseOutput = do
+    sz <- fromIntegral <$> getWord64be
+    CoinbaseOutput <$> getByteString sz
+
+putPayloadWithOutputs :: PayloadWithOutputs_ a -> Put
+putPayloadWithOutputs pwo = do
+    putWord64be (fromIntegral $ V.length (_payloadWithOutputsTransactions pwo))
+    forM_ (_payloadWithOutputsTransactions pwo) $ \(tx, txo) -> do
+        putWord64be (fromIntegral $ B.length (_transactionBytes tx))
+        putByteString (_transactionBytes tx)
+        putWord64be (fromIntegral $ B.length (_transactionOutputBytes txo))
+        putByteString (_transactionOutputBytes txo)
+    encodeMinerData (_payloadWithOutputsMiner pwo)
+    encodeCoinbaseOutput (_payloadWithOutputsCoinbase pwo)
+    encodeBlockPayloadHash (_payloadWithOutputsPayloadHash pwo)
+    encodeBlockTransactionsHash (_payloadWithOutputsTransactionsHash pwo)
+    encodeBlockOutputsHash (_payloadWithOutputsOutputsHash pwo)
+
+encodePayloadWithOutputs :: PayloadWithOutputs_ a -> B.ByteString
+encodePayloadWithOutputs = runPutS . putPayloadWithOutputs
+
+getPayloadWithOutputs :: HashAlgorithm a => Get (PayloadWithOutputs_ a)
+getPayloadWithOutputs = do
+    txsCount <- fromIntegral <$> getWord64be
+    txs <- replicateM txsCount $ do
+        txSz <- fromIntegral <$> getWord64be
+        txData <- getByteString txSz
+        txoSz <- fromIntegral <$> getWord64be
+        txoData <- getByteString txoSz
+        pure (Transaction txData, TransactionOutput txoData)
+    minerData <- decodeMinerData
+    coinbaseOutput <- decodeCoinbaseOutput
+    payloadHash <- decodeBlockPayloadHash
+    txHash <- decodeBlockTransactionsHash
+    outHash <- decodeBlockOutputsHash
+    return PayloadWithOutputs
+        { _payloadWithOutputsTransactions = V.fromList txs
+        , _payloadWithOutputsMiner = minerData
+        , _payloadWithOutputsCoinbase = coinbaseOutput
+        , _payloadWithOutputsPayloadHash = payloadHash
+        , _payloadWithOutputsTransactionsHash = txHash
+        , _payloadWithOutputsOutputsHash = outHash
+        }
+
+decodePayloadWithOutputs :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (PayloadWithOutputs_ a)
+decodePayloadWithOutputs = runGetS getPayloadWithOutputs
+
+encodePayloadDataList :: PayloadDataList -> B.ByteString
+encodePayloadDataList (PayloadDataList xs) = runPutS $ do
+    putWord64be (fromIntegral $ length xs)
+    forM_ xs putPayloadData
+
+decodePayloadDataList :: (MonadThrow m) => B.ByteString -> m PayloadDataList
+decodePayloadDataList = runGetS $ do
+    xsCount <- fromIntegral <$> getWord64be
+    PayloadDataList <$> replicateM xsCount getPayloadData
+
+encodePayloadWithOutputsList :: PayloadWithOutputsList -> B.ByteString
+encodePayloadWithOutputsList (PayloadWithOutputsList xs) = runPutS $ do
+    putWord64be (fromIntegral $ length xs)
+    forM_ xs putPayloadWithOutputs 
+
+decodePayloadWithOutputsList :: (MonadThrow m) => B.ByteString -> m PayloadWithOutputsList
+decodePayloadWithOutputsList = runGetS $ do
+    xsCount <- fromIntegral <$> getWord64be
+    PayloadWithOutputsList <$> replicateM xsCount getPayloadWithOutputs
+
 -- -------------------------------------------------------------------------- --
 
 blockTransactionsProperties

src/Chainweb/Payload/RestAPI.hs

@@ -75,6 +75,7 @@ import Chainweb.RestAPI.Orphans ()
 import Chainweb.RestAPI.Utils
 import Chainweb.Version
 import Chainweb.BlockHeight
+import Chainweb.BlockHeaderDB.RestAPI ()
 
 -- -------------------------------------------------------------------------- --
 -- Constants
@@ -115,7 +116,7 @@ type PayloadGetApi_
     = "payload"
     :> Capture "BlockPayloadHash" BlockPayloadHash
     :> QueryParam "height" BlockHeight
-    :> Get '[JSON] PayloadData
+    :> Get '[JSON, OctetStream] PayloadData
 
 type PayloadGetApi (v :: ChainwebVersionT) (c :: ChainIdT)
     = 'ChainwebEndpoint v :> ChainEndpoint c :> PayloadGetApi_
@@ -162,7 +163,7 @@ type PayloadPostApi_
     = "payload"
     :> "batch"
     :> ReqBody '[JSON] BatchBody
-    :> Post '[JSON] PayloadDataList
+    :> Post '[JSON, OctetStream] PayloadDataList
 
 type PayloadPostApi (v :: ChainwebVersionT) (c :: ChainIdT)
     = 'ChainwebEndpoint v :> ChainEndpoint c :> PayloadPostApi_
@@ -182,7 +183,7 @@ type OutputsGetApi_
     :> Capture "BlockPayloadHash" BlockPayloadHash
     :> "outputs"
     :> QueryParam "height" BlockHeight
-    :> Get '[JSON] PayloadWithOutputs
+    :> Get '[JSON, OctetStream] PayloadWithOutputs
 
 type OutputsGetApi (v :: ChainwebVersionT) (c :: ChainIdT)
     = 'ChainwebEndpoint v :> ChainEndpoint c :> OutputsGetApi_
@@ -205,7 +206,7 @@ type OutputsPostApi_
     :> "outputs"
     :> "batch"
     :> ReqBody '[JSON] BatchBody
-    :> Post '[JSON] PayloadWithOutputsList
+    :> Post '[JSON, OctetStream] PayloadWithOutputsList
 
 type OutputsPostApi (v :: ChainwebVersionT) (c :: ChainIdT)
     = 'ChainwebEndpoint v :> ChainEndpoint c :> OutputsPostApi_

test/Chainweb/Test/Misc.hs

@@ -34,6 +34,8 @@ tests = testGroup "Misc. Unit Tests"
           [ testProperty "BlockPayload" propPayloadBinaryEncoding
           , testProperty "BlockTransactions" propBlockTransactionsEncoding
           , testProperty "BlockOutputs" propBlockOutputsEncoding
+          , testProperty "PayloadData" propPayloadDataEncoding
+          , testProperty "PayloadWithOutputs" propPayloadWithOutputsEncoding
           ]
     ]
 
@@ -61,3 +63,13 @@ propBlockOutputsEncoding :: BlockOutputs -> Bool
 propBlockOutputsEncoding bo
   | Right x <- decodeBlockOutputs (encodeBlockOutputs bo) = x == bo
   | otherwise = False
+
+propPayloadDataEncoding :: PayloadData -> Bool
+propPayloadDataEncoding pd
+  | Right x <- decodePayloadData (encodePayloadData pd) = x == pd
+  | otherwise = False
+
+propPayloadWithOutputsEncoding :: PayloadWithOutputs -> Bool
+propPayloadWithOutputsEncoding pwo
+  | Right x <- decodePayloadWithOutputs (encodePayloadWithOutputs pwo) = x == pwo
+  | otherwise = False