Add keyToAddress & separate concern with get/putAddress

Previously:
    `getAddress :: ByteString 33 bytes -> Address 32 bytes`
    `putAddress :: Address 32 bytes -> ByteString 33 bytes`
Now:
    `getAddress :: ByteString 33 bytes -> Address 33 bytes`
    `putAddress Address 33 bytes -> ByteString 33 bytes`
     **Implemented** `keyToAddress :: XPub 32 bytes -> Address 33 bytes`

- Implement Jörmungandr keyToAddress
- Refactor to have singleAddressFromKey in Binary module
- Ignore chaincode in jörmungandr keyToAddress & add tests

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -37,6 +37,7 @@ library
     , binary
     , bytestring
     , cardano-wallet-core
+    , cardano-crypto
     , cborg
     , exceptions
     , http-client

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

@@ -20,6 +20,7 @@ module Cardano.Wallet.Jormungandr.Binary
     , Message (..)
     , getBlockHeader
     , getBlock
+    , getTransaction
 
     , putTransaction
 
@@ -29,6 +30,11 @@ module Cardano.Wallet.Jormungandr.Binary
     , LinearFee (..)
     , Milli (..)
 
+    -- * Addresses
+    , putAddress
+    , getAddress
+    , singleAddressFromKey
+
       -- * Classes
     , FromBinary (..)
 
@@ -43,8 +49,10 @@ module Cardano.Wallet.Jormungandr.Binary
 
 import Prelude
 
+import Cardano.Crypto.Wallet
+    ( XPub (xpubPublicKey) )
 import Cardano.Wallet.Jormungandr.Environment
-    ( KnownNetwork (..), Network (..) )
+    ( KnownNetwork, Network (..), single )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
     , Coin (..)
@@ -68,11 +76,12 @@ import Data.Binary.Get
     , isEmpty
     , isolate
     , label
+    , lookAhead
     , runGet
     , skip
     )
 import Data.Binary.Put
-    ( Put, putByteString, putWord64be, putWord8 )
+    ( Put, putByteString, putLazyByteString, putWord64be, putWord8, runPut )
 import Data.Bits
     ( shift, (.&.) )
 import Data.ByteString
@@ -87,6 +96,7 @@ import Data.Word
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Codec.CBOR.Decoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 
 data BlockHeader = BlockHeader
@@ -224,10 +234,9 @@ getTransaction = label "getTransaction" $ do
                 error "unimplemented: Account witness"
             other -> fail $ "Invalid witness type: " ++ show other
 
-
-putTransaction :: forall n. KnownNetwork n => Proxy n -> (Tx, [TxWitness]) -> Put
-putTransaction _ (tx, witnesses) = do
-    putTokenTransfer (Proxy @n) tx
+putTransaction :: (Tx, [TxWitness]) -> Put
+putTransaction (tx, witnesses) = do
+    putTokenTransfer tx
     mapM_ putWitness witnesses
 
 putWitness :: TxWitness -> Put
@@ -252,8 +261,8 @@ putWitness witness =
                             Common Structure
 -------------------------------------------------------------------------------}
 
-putTokenTransfer :: forall n. KnownNetwork n => Proxy n -> Tx -> Put
-putTokenTransfer _ (Tx inputs outputs) = do
+putTokenTransfer :: Tx -> Put
+putTokenTransfer (Tx inputs outputs) = do
     putWord8 $ fromIntegral $ length inputs
     putWord8 $ fromIntegral $ length outputs
     mapM_ putInput inputs
@@ -267,10 +276,6 @@ putTokenTransfer _ (Tx inputs outputs) = do
     putOutput (TxOut address coin) = do
         putAddress address
         putWord64be $ getCoin coin
-    putAddress address = do
-        -- NOTE: only single address supported for now
-        putWord8 (single @n)
-        putByteString $ getAddress address
 
 getTokenTransfer :: Get ([TxIn], [TxOut])
 getTokenTransfer = label "getTokenTransfer" $ do
@@ -291,25 +296,7 @@ getTokenTransfer = label "getTokenTransfer" $ do
         value <- Coin <$> getWord64be
         return $ TxOut addr value
 
-    getAddress = do
-        headerByte <- getWord8
-        let kind = kindValue headerByte
-        let _discrimination = discriminationValue headerByte
-        case kind of
-            -- Single Address
-            0x3 -> Address <$> getByteString 32
-            0x4 -> error "unimplemented group address decoder"
-            0x5 -> error "unimplemented account address decoder"
-            0x6 -> error "unimplemented multisig address decoder"
-            other -> fail $ "Invalid address type: " ++ show other
-
-    kindValue :: Word8 -> Word8
-    kindValue = (.&. 0b01111111)
 
-    discriminationValue :: Word8 -> Network
-    discriminationValue b = case b .&. 0b10000000 of
-        0 -> Mainnet
-        _ -> Testnet
 
 
 {-------------------------------------------------------------------------------
@@ -430,10 +417,64 @@ getBool = getWord8 >>= \case
     other -> fail $ "Unexpected integer: " ++ show other
                 ++ ". Expected a boolean 0 or 1."
 
+
+{-------------------------------------------------------------------------------
+                            Addresses
+-------------------------------------------------------------------------------}
+
+getAddress :: Get Address
+getAddress = do
+    -- We use 'lookAhead' to not consume the header, and let it
+    -- be included in the underlying Address ByteString.
+    headerByte <- label "address header" . lookAhead $ getWord8
+    let kind = kindValue headerByte
+    let _discrimination = discriminationValue headerByte
+    case kind of
+        -- Single Address
+        0x3 -> Address <$> getByteString 33
+        0x4 -> error "unimplemented group address decoder"
+        0x5 -> error "unimplemented account address decoder"
+        0x6 -> error "unimplemented multisig address decoder"
+        other -> fail $ "Invalid address type: " ++ show other
+  where
+    kindValue :: Word8 -> Word8
+    kindValue = (.&. 0b01111111)
+
+    discriminationValue :: Word8 -> Network
+    discriminationValue b = case b .&. 0b10000000 of
+        0 -> Mainnet
+        _ -> Testnet
+
+putAddress :: Address -> Put
+putAddress addr@(Address bs)
+    | l == 33 = putByteString bs -- bootstrap or account addr
+    | l == 65 = putByteString bs -- delegation addr
+    | otherwise = fail
+        $ "Address have unexpected length "
+        ++ (show l)
+        ++ ": " ++ show addr
+  where l = BS.length bs
+
+singleAddressFromKey :: forall n. KnownNetwork n => Proxy n -> XPub -> Address
+singleAddressFromKey _ xPub = Address $ BL.toStrict $ runPut $ do
+    putWord8 (single @n)
+    isolatePut 32 $ putByteString (xpubPublicKey xPub )
+
 {-------------------------------------------------------------------------------
                               Helpers
 -------------------------------------------------------------------------------}
 
+-- | Make sure a 'Put' encodes into a specific length
+isolatePut :: Int -> Put -> Put
+isolatePut l x = do
+    let bs = runPut x
+    if BL.length bs == (fromIntegral l)
+    then putLazyByteString bs
+    else fail $ "length was "
+        ++ show (BL.length bs)
+        ++ ", but expected to be "
+        ++ (show l)
+
 whileM :: Monad m => m Bool -> m a -> m [a]
 whileM cond next = go
   where

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

@@ -23,11 +23,11 @@ module Cardano.Wallet.Jormungandr.Compatibility
 import Prelude
 
 import Cardano.Wallet.Jormungandr.Binary
-    ( decodeLegacyAddress )
+    ( decodeLegacyAddress, singleAddressFromKey )
 import Cardano.Wallet.Jormungandr.Environment
     ( KnownNetwork (..), Network (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
-    ( KeyToAddress (..) )
+    ( KeyToAddress (..), getKey )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
     , BlockHeader (..)
@@ -47,6 +47,8 @@ import Data.ByteString.Base58
     ( bitcoinAlphabet, decodeBase58, encodeBase58 )
 import Data.Maybe
     ( isJust )
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Text.Class
     ( TextDecodingError (..) )
 
@@ -69,8 +71,9 @@ genesis = BlockHeader
 instance TxId (Jormungandr n) where
     txId = undefined
 
-instance KeyToAddress (Jormungandr n) where
-    keyToAddress = undefined
+instance forall n. KnownNetwork n => KeyToAddress (Jormungandr n) where
+    keyToAddress key = singleAddressFromKey (Proxy @n) (getKey key)
+
 
 -- | Encode an 'Address' to a human-readable format. This produces two kinds of
 -- encodings:

lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/BinarySpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
@@ -19,13 +20,16 @@ import Cardano.Wallet.Jormungandr.Binary
     , getBlock
     , getBlockHeader
     , runGet
+    , singleAddressFromKey
     )
 import Cardano.Wallet.Jormungandr.Compatibility
     ( genesis )
 import Cardano.Wallet.Jormungandr.Environment
     ( Network (..) )
 import Cardano.Wallet.Primitive.Types
     ( Address (..), Coin (..), Hash (..), SlotId (..), Tx (..), TxOut (..) )
+import Control.Exception
+    ( evaluate )
 import Data.ByteArray.Encoding
     ( Base (Base16), convertFromBase )
 import Data.ByteString
@@ -34,11 +38,14 @@ import Data.Generics.Internal.VL.Lens
     ( (^.) )
 import Data.Generics.Labels
     ()
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Quantity
     ( Quantity (..) )
 import Test.Hspec
-    ( Spec, describe, it, runIO, shouldBe )
+    ( Spec, anyErrorCall, describe, it, runIO, shouldBe, shouldThrow )
 
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 
 {-# ANN spec ("HLint: ignore Use head" :: String) #-}
@@ -71,6 +78,16 @@ spec = do
                     , parentHeaderHash = Hash {getHash = "\216OY\rX\199\234\188.<O\\\244Y\211\210\254\224`i\216\DC3\167\132\139\154\216\161T\174\247\155"}
                     }
                 []
+    describe "singleAddressFromKey" $ do
+        let pub = "3$\195xi\193\"h\154\&5\145}\245:O\"\148\163\165/h^\ENQ\245\248\229;\135\231\234E/"
+        let singleAddrOnMainnet = 0x3
+        it "encodes (network <> tag <> key) correctly into an address" $
+            singleAddressFromKey (Proxy @'Mainnet) pub
+            `shouldBe`
+            Address (BS.pack [singleAddrOnMainnet] <> pub)
+        it "throws when length (key) != 32" $
+            evaluate (singleAddressFromKey (Proxy @'Mainnet) (pub <> "\148"))
+            `shouldThrow` anyErrorCall
 
 genesisHeader :: BlockHeader
 genesisHeader = BlockHeader
@@ -102,7 +119,7 @@ genesisBlock = Block genesisHeader
         { inputs = []
         , outputs =
             [ TxOut
-                { address = Address "3$\195xi\193\"h\154\&5\145}\245:O\"\148\163\165/h^\ENQ\245\248\229;\135\231\234E/"
+                { address = Address "\131\&3$\195xi\193\"h\154\&5\145}\245:O\"\148\163\165/h^\ENQ\245\248\229;\135\231\234E/"
                 , coin = Coin 14
                 }
             ]