Add a basic API client for the Rust Cardano HTTP Bridge

cardano-wallet.cabal

@@ -39,18 +39,25 @@ library
     , cryptonite
     , deepseq
     , digest
+    , http-api-data
+    , http-media
     , memory
+    , servant
+    , servant-client
+    , text
     , transformers
   hs-source-dirs:
       src
   exposed-modules:
-      Cardano.Wallet.Binary
-      Cardano.Wallet.Binary.Packfile
-      Cardano.Wallet.Primitive
+      Cardano.ChainProducer.RustHttpBridge.Api
+    , Cardano.ChainProducer.RustHttpBridge.Client
+    , Cardano.Wallet.Binary
+    , Cardano.Wallet.Binary.Packfile
+    , Cardano.Wallet.Primitive
+    , Servant.Extra.ContentTypes
   other-modules:
       Paths_cardano_wallet
 
-
 executable cardano-wallet-server
   default-language:
       Haskell2010

src/Cardano/ChainProducer/RustHttpBridge/Api.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | An API specification for the Cardano HTTP Bridge.
+module Cardano.ChainProducer.RustHttpBridge.Api
+    ( Api
+    , api
+    , Block (..)
+    , BlockHeader (..)
+    , EpochId (..)
+    , NetworkName (..)
+    ) where
+
+import Cardano.Wallet.Binary
+    ( decodeBlock, decodeBlockHeader )
+import Crypto.Hash.Algorithms
+    ( Blake2b_256 )
+import Data.Proxy
+    ( Proxy (..) )
+import Data.Text
+    ( Text )
+import Prelude
+import Servant.API
+    ( (:<|>), (:>), Capture, Get, ToHttpApiData (..) )
+import Servant.Extra.ContentTypes
+    ( CBOR, ComputeHash, FromCBOR (..), Hash, Packed, WithHash )
+
+import qualified Cardano.Wallet.Primitive as Primitive
+
+api :: Proxy Api
+api = Proxy
+
+type Api
+    =    GetBlockByHash
+    :<|> GetEpochById
+    :<|> GetTipBlockHeader
+
+-- | Retrieve a block identified by the unique hash of its header.
+type GetBlockByHash
+    =  Capture "networkName" NetworkName
+    :> "block"
+    :> Capture "blockHeaderHash" (Hash Blake2b_256 BlockHeader)
+    :> Get '[CBOR] Block
+
+-- | Retrieve all the blocks for the epoch identified by the given integer ID.
+type GetEpochById
+    =  Capture "networkName" NetworkName
+    :> "epoch"
+    :> Capture "epochId" EpochId
+    :> Get '[Packed CBOR] [Block]
+
+-- | Retrieve the header of the latest known block.
+type GetTipBlockHeader
+    = Capture "networkName" NetworkName
+    :> "tip"
+    :> Get '[ComputeHash Blake2b_256 CBOR] (WithHash Blake2b_256 BlockHeader)
+
+-- | Represents a block.
+--
+newtype Block = Block
+  { getBlock :: Primitive.Block
+  } deriving Eq
+
+instance FromCBOR Block where
+  fromCBOR = Block <$> decodeBlock
+
+-- | Represents a block header.
+--
+newtype BlockHeader = BlockHeader
+  { getBlockHeader :: Primitive.BlockHeader
+  } deriving Eq
+
+instance FromCBOR BlockHeader where
+  fromCBOR = BlockHeader <$> decodeBlockHeader
+
+-- | Represents a unique epoch.
+--
+newtype EpochId = EpochId
+  { getEpochId :: Primitive.EpochId
+  } deriving (Eq, Show)
+
+instance ToHttpApiData (EpochId) where
+    toUrlPiece = toUrlPiece . Primitive.getEpochId . getEpochId
+
+-- | Represents the name of a Cardano network.
+--
+newtype NetworkName = NetworkName
+  { getNetworkName :: Text
+  } deriving (Eq, Show)
+
+instance ToHttpApiData NetworkName where
+    toUrlPiece = getNetworkName
+

src/Cardano/ChainProducer/RustHttpBridge/Client.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | An API client for the Cardano HTTP Bridge.
+module Cardano.ChainProducer.RustHttpBridge.Client
+    ( getBlockByHash
+    , getEpochById
+    , getTipBlockHeader
+    ) where
+
+import Cardano.ChainProducer.RustHttpBridge.Api
+    ( Block, BlockHeader, EpochId, NetworkName, api )
+import Crypto.Hash.Algorithms
+    ( Blake2b_256 )
+import Servant.API
+    ( (:<|>) (..) )
+import Servant.Client
+    ( ClientM, client )
+import Servant.Extra.ContentTypes
+    ( Hash, WithHash )
+
+-- | Retrieve a block identified by the unique hash of its header.
+getBlockByHash :: NetworkName -> Hash Blake2b_256 BlockHeader -> ClientM Block
+
+-- | Retrieve all the blocks for the epoch identified by the given integer ID.
+getEpochById :: NetworkName -> EpochId -> ClientM [Block]
+
+-- | Retrieve the header of the latest known block.
+getTipBlockHeader :: NetworkName -> ClientM (WithHash Blake2b_256 BlockHeader)
+
+getBlockByHash
+    :<|> getEpochById
+    :<|> getTipBlockHeader
+    = client api
+

src/Cardano/Wallet/Binary.hs

@@ -42,7 +42,9 @@ import Cardano.Wallet.Primitive
     , Block (..)
     , BlockHeader (..)
     , Coin (..)
+    , EpochId (..)
     , Hash (..)
+    , SlotId (..)
     , Tx (..)
     , TxIn (..)
     , TxOut (..)
@@ -191,7 +193,7 @@ decodeGenesisBlockHeader = do
     -- number of `0`. In practices, when parsing a full epoch, we can discard
     -- the genesis block entirely and we won't bother about modelling this
     -- extra complexity at the type-level. That's a bit dodgy though.
-    return $ BlockHeader epoch 0 previous
+    return $ BlockHeader (EpochId epoch) (SlotId 0) previous
 
 decodeGenesisConsensusData :: CBOR.Decoder s Word64
 decodeGenesisConsensusData = do
@@ -246,7 +248,7 @@ decodeMainBlockHeader = do
     _ <- decodeMainProof
     (epoch, slot) <- decodeMainConsensusData
     _ <- decodeMainExtraData
-    return $ BlockHeader epoch slot previous
+    return $ BlockHeader (EpochId epoch) (SlotId slot) previous
 
 decodeMainConsensusData :: CBOR.Decoder s (Word64, Word16)
 decodeMainConsensusData = do

src/Cardano/Wallet/Primitive.hs

@@ -23,6 +23,12 @@ module Cardano.Wallet.Primitive
       Block(..)
     , BlockHeader(..)
 
+    -- * Epoch
+    , EpochId (..)
+
+    -- * Slot
+    , SlotId (..)
+
     -- * Tx
     , Tx(..)
     , TxIn(..)
@@ -78,6 +84,17 @@ import GHC.TypeLits
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
+-- * Epoch
+
+newtype EpochId = EpochId
+    { getEpochId :: Word64
+    } deriving (Eq, Generic, NFData, Num, Show)
+
+-- * Slot
+
+newtype SlotId = SlotId
+    { getSlotId :: Word16
+    } deriving (Eq, Generic, NFData, Num, Show)
 
 -- * Block
 
@@ -90,19 +107,17 @@ data Block = Block
 
 instance NFData Block
 
-
 data BlockHeader = BlockHeader
     { epochIndex
-        :: !Word64
+        :: !EpochId
     , slotNumber
-        :: !Word16
+        :: !SlotId
     , prevBlockHash
         :: !(Hash "BlockHeader")
     } deriving (Show, Eq, Generic)
 
 instance NFData BlockHeader
 
-
 -- * Tx
 
 data Tx = Tx

src/Servant/Extra/ContentTypes.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Extra content types for Servant.
+--
+module Servant.Extra.ContentTypes
+    ( ComputeHash
+    , CBOR
+    , FromCBOR (..)
+    , Hash (..)
+    , Packed
+    , WithHash (..)
+    ) where
+
+import Cardano.Wallet.Binary.Packfile
+    ( decodePackfile )
+import Crypto.Hash
+    ( Digest, hashWith )
+import Crypto.Hash.IO
+    ( HashAlgorithm (..) )
+import Data.Proxy
+    ( Proxy (..) )
+import Data.Text.Encoding
+    ( decodeUtf8 )
+import Network.HTTP.Media
+    ( (//) )
+import Prelude
+import Servant.API
+    ( Accept (..), MimeUnrender (..), ToHttpApiData (..) )
+
+import qualified Codec.CBOR.Decoding as CBOR
+import qualified Codec.CBOR.Read as CBOR
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Lazy as BL
+
+-- | Represents a CBOR (Concise Binary Object Representation) object.
+--
+-- See RFC 7049 (http://cbor.io/) for further details.
+--
+data CBOR
+
+-- | The class of types that can be converted to from CBOR.
+--
+class FromCBOR a where
+    fromCBOR :: CBOR.Decoder s a
+
+instance Accept CBOR where
+    contentType _ = "application" // "cbor"
+
+instance FromCBOR a => MimeUnrender CBOR a where
+    mimeUnrender _ bl = either
+        (Left . show)
+        (Right . snd)
+        (CBOR.deserialiseFromBytes fromCBOR bl)
+
+-- | Represents a piece of binary data for which a hash value should be
+--   calculated before performing any further deserialization.
+--
+data ComputeHash algorithm a
+
+-- | Represents the result of hashing a piece of data.
+--
+newtype Hash algorithm a = Hash (Digest algorithm)
+
+instance ToHttpApiData (Hash algorithm a) where
+    toUrlPiece (Hash digest) = decodeUtf8 $ BA.convert digest
+
+-- | Represents a piece of data with an accompanying hash value.
+data WithHash algorithm a = WithHash
+    { getHash  :: Digest algorithm
+    , getValue :: a
+    } deriving Show
+
+instance Accept a => Accept (ComputeHash algorithm a) where
+    contentType _ = contentType (Proxy :: Proxy a)
+
+instance forall a b alg . (MimeUnrender a b, HashAlgorithm alg) =>
+    MimeUnrender (ComputeHash alg a) (WithHash alg b) where
+        mimeUnrender _ bl =
+            WithHash (hashWith (undefined :: alg) $ BL.toStrict bl)
+                <$> mimeUnrender (Proxy :: Proxy a) bl
+
+-- | Represents something that has been packed with the Cardano packfile format.
+--
+data Packed a
+
+instance Accept a => Accept (Packed a) where
+    contentType _ = "application" // "cardano-pack"
+
+instance forall a b . MimeUnrender a b => MimeUnrender (Packed a) [b] where
+    mimeUnrender _ bs = either
+        (Left . show)
+        (traverse $ mimeUnrender (Proxy :: Proxy a) . BL.fromStrict)
+        (decodePackfile bs)
+

test/unit/Cardano/Wallet/BinarySpec.hs

@@ -37,7 +37,6 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as L8
 import qualified Data.Set as Set
 
-
 {-# ANN spec ("HLint: ignore Use head" :: String) #-}
 spec :: Spec
 spec = do
@@ -85,7 +84,6 @@ spec = do
             let hash' = hash16 "d30d37f1f8674c6c33052826fdc5bc198e3e95c150364fd775d4bc663ae6a9e6"
             hash `shouldBe` hash'
 
-
 -- A mainnet block header
 blockHeader1 :: BlockHeader
 blockHeader1 = BlockHeader

test/unit/Cardano/Wallet/PrimitiveSpec.hs

@@ -14,7 +14,9 @@ import Cardano.Wallet.Primitive
     , BlockHeader (..)
     , Coin (..)
     , Dom (..)
+    , EpochId (..)
     , Hash (..)
+    , SlotId (..)
     , Tx (..)
     , TxIn (..)
     , TxOut (..)
@@ -240,6 +242,12 @@ instance Arbitrary Coin where
     -- No Shrinking
     arbitrary = Coin <$> choose (0, 3)
 
+instance Arbitrary EpochId where
+    arbitrary = EpochId <$> arbitrary
+
+instance Arbitrary SlotId where
+    arbitrary = SlotId <$> arbitrary
+
 instance Arbitrary TxOut where
     -- No Shrinking
     arbitrary = TxOut