Implement txId hash using CBOR encoders

cardano-wallet.cabal

@@ -36,7 +36,10 @@ library
     , bytestring
     , cborg
     , containers
+    , cryptonite
     , deepseq
+    , digest
+    , memory
     , transformers
   hs-source-dirs:
       src

src/Cardano/Wallet/Binary.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Copyright: © 2018-2019 IOHK
@@ -16,8 +17,17 @@
 -- by components like the Rust <https://github.com/input-output-hk/cardano-http-bridge cardano-http-bridge>.
 
 module Cardano.Wallet.Binary
-    ( decodeBlock
+    (
+    -- * Decoding
+      decodeBlock
     , decodeBlockHeader
+    , decodeTx
+
+    -- * Encoding
+    , encodeTx
+
+    -- * Hashing
+    , txId
 
     -- * Helpers
     , inspectNextToken
@@ -39,10 +49,16 @@ import Cardano.Wallet.Primitive
     )
 import Control.Monad
     ( void )
-import qualified Data.ByteString.Lazy as BL
+import Crypto.Hash
+    ( hash )
+import Crypto.Hash.Algorithms
+    ( Blake2b_256 )
+import Data.ByteString
+    ( ByteString )
+import Data.Digest.CRC32
+    ( crc32 )
 import Data.Set
     ( Set )
-import qualified Data.Set as Set
 import Data.Word
     ( Word16, Word64 )
 import Debug.Trace
@@ -52,8 +68,13 @@ import qualified Codec.CBOR.Decoding as CBOR
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Write as CBOR
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Set as Set
 
 
+-- Decoding
+
 decodeAddress :: CBOR.Decoder s Address
 decodeAddress = do
     _ <- CBOR.decodeListLenCanonicalOf 2 -- CRC Protection Wrapper
@@ -73,6 +94,13 @@ decodeAddress = do
         <> CBOR.encodeBytes bytes
         <> CBOR.encodeWord32 crc
 
+decodeAddressPayload :: CBOR.Decoder s ByteString
+decodeAddressPayload = do
+    _ <- CBOR.decodeListLenCanonicalOf 2
+    _ <- CBOR.decodeTag
+    bytes <- CBOR.decodeBytes
+    _ <- CBOR.decodeWord32 -- CRC
+    return bytes
 
 decodeAttributes :: CBOR.Decoder s ((), CBOR.Encoding)
 decodeAttributes = do
@@ -305,6 +333,16 @@ decodeSignature = do
         2 -> decodeProxySignature decodeHeavyIndex
         _ -> fail $ "decodeSignature: unknown signature constructor: " <> show t
 
+decodeSignedTx :: CBOR.Decoder s Tx
+decodeSignedTx = do
+    _ <- CBOR.decodeListLenCanonicalOf 2
+    _ <- CBOR.decodeListLenCanonicalOf 3
+    ins <- decodeListIndef decodeTxIn
+    outs <- decodeListIndef decodeTxOut
+    _ <- decodeAttributes
+    _ <- decodeList decodeTxWitness
+    return $ Tx ins outs
+
 decodeSharesProof :: CBOR.Decoder s ()
 decodeSharesProof = do
     _ <- CBOR.decodeBytes -- Shares Hash
@@ -327,16 +365,14 @@ decodeSoftwareVersion = do
 
 decodeTx :: CBOR.Decoder s Tx
 decodeTx = do
-    _ <- CBOR.decodeListLenCanonicalOf 2
     _ <- CBOR.decodeListLenCanonicalOf 3
     ins <- decodeListIndef decodeTxIn
     outs <- decodeListIndef decodeTxOut
     _ <- decodeAttributes
-    _ <- decodeList decodeTxWitness
     return $ Tx ins outs
 
 decodeTxPayload :: CBOR.Decoder s (Set Tx)
-decodeTxPayload = Set.fromList <$> decodeListIndef decodeTx
+decodeTxPayload = Set.fromList <$> decodeListIndef decodeSignedTx
 
 {-# ANN decodeTxIn ("HLint: ignore Use <$>" :: String) #-}
 decodeTxIn :: CBOR.Decoder s TxIn
@@ -391,6 +427,65 @@ decodeUpdateProof = do
     return ()
 
 
+-- * Encoding
+
+encodeAddressPayload :: ByteString -> CBOR.Encoding
+encodeAddressPayload payload = mempty
+    <> CBOR.encodeListLen 2
+    <> CBOR.encodeTag 24 -- Hard-Coded Tag value in cardano-sl
+    <> CBOR.encodeBytes payload
+    <> CBOR.encodeWord32 (crc32 payload)
+
+encodeTx :: Tx -> CBOR.Encoding
+encodeTx tx = mempty
+    <> CBOR.encodeListLen 3
+    <> CBOR.encodeListLenIndef
+    <> mconcat (encodeTxIn <$> inputs tx)
+    <> CBOR.encodeBreak
+    <> CBOR.encodeListLenIndef
+    <> mconcat (encodeTxOut <$> outputs tx)
+    <> CBOR.encodeBreak
+    <> encodeTxAttributes
+
+encodeTxAttributes :: CBOR.Encoding
+encodeTxAttributes = mempty
+    <> CBOR.encodeMapLen 0
+
+encodeTxIn :: TxIn -> CBOR.Encoding
+encodeTxIn (TxIn (Hash txid) ix) = mempty
+    <> CBOR.encodeListLen 2
+    <> CBOR.encodeWord8 0
+    <> CBOR.encodeTag 24 -- Hard-coded Tag value in cardano-sl
+    <> CBOR.encodeBytes bytes
+  where
+    bytes = CBOR.toStrictByteString $ mempty
+        <> CBOR.encodeListLen 2
+        <> CBOR.encodeBytes txid
+        <> CBOR.encodeWord32 ix
+
+encodeTxOut :: TxOut -> CBOR.Encoding
+encodeTxOut (TxOut (Address addr) (Coin c)) = mempty
+    <> CBOR.encodeListLen 2
+    <> encodeAddressPayload payload
+    <> CBOR.encodeWord64 c
+  where
+    invariant =
+        error $ "encodeTxOut: unable to decode address payload: " <> show addr
+    payload =
+        either (const invariant) snd $ CBOR.deserialiseFromBytes
+            decodeAddressPayload
+            (BL.fromStrict addr)
+
+-- * Hashing
+
+-- | Compute a transaction id; assumed to be effectively injective.
+-- It returns an hex-encoded 64-byte hash.
+--
+-- NOTE: This is a rather expensive operation
+txId :: Tx -> Hash "Tx"
+txId = blake2b256 . encodeTx
+
+
 -- * Helpers
 
 -- | Inspect the next token that has to be decoded and print it to the console
@@ -435,3 +530,13 @@ decodeListIndef :: forall s a. CBOR.Decoder s a -> CBOR.Decoder s [a]
 decodeListIndef decodeOne = do
     _ <- CBOR.decodeListLenIndef
     CBOR.decodeSequenceLenIndef (flip (:)) [] reverse decodeOne
+
+-- | Encode a value to a corresponding Hash.
+--
+-- @
+--     txId :: Tx -> Hash "Tx"
+--     txId = blake2b256 . encodeTx
+-- @
+blake2b256 :: forall tag. CBOR.Encoding -> Hash tag
+blake2b256 =
+    Hash . BA.convert . hash @_ @Blake2b_256 . CBOR.toStrictByteString

src/Cardano/Wallet/Primitive.hs

@@ -27,7 +27,6 @@ module Cardano.Wallet.Primitive
     , Tx(..)
     , TxIn(..)
     , TxOut(..)
-    , txId
     , txIns
     , txOutsOurs
     , updatePending
@@ -43,8 +42,6 @@ module Cardano.Wallet.Primitive
     -- * UTxO
     , UTxO (..)
     , balance
-    , changeUTxO
-    , utxoFromTx
     , excluding
     , isSubsetOf
     , restrictedBy
@@ -123,12 +120,6 @@ data Tx = Tx
 
 instance NFData Tx
 
--- | Calculating a transaction id. Assumed to be effectively injective
-txId :: Tx -> Hash "Tx"
-txId = error
-    "txId: not yet implemented. We need the ability to encode a Tx to CBOR for:\
-    \ BA.convert . hash @_ @Blake2b_256 . CBOR.toStrictByteString . encodeTx"
-
 txIns :: Set Tx -> Set TxIn
 txIns =
     foldMap (Set.fromList . inputs)
@@ -237,21 +228,6 @@ balance :: UTxO -> Integer
 balance =
     Map.foldl' (\total out -> total + fromIntegral (getCoin (coin out))) 0 . getUTxO
 
-utxoFromTx :: Tx -> UTxO
-utxoFromTx tx@(Tx _ outs) =
-    UTxO $ Map.fromList $ zip (TxIn (txId tx) <$> [0..]) outs
-
-changeUTxO
-    :: IsOurs s
-    => Set Tx
-    -> s
-    -> (UTxO, s)
-changeUTxO pending = runState $ do
-    ours <- state $ txOutsOurs pending
-    let utxo = foldMap utxoFromTx pending
-    let ins = txIns pending
-    return $ (utxo `restrictedTo` ours) `restrictedBy` ins
-
 -- ins⋪ u
 excluding :: UTxO -> Set TxIn ->  UTxO
 excluding (UTxO utxo) =

test/unit/Cardano/Wallet/BinarySpec.hs

@@ -10,7 +10,7 @@ module Cardano.Wallet.BinarySpec
 import Prelude
 
 import Cardano.Wallet.Binary
-    ( decodeBlock, decodeBlockHeader )
+    ( decodeBlock, decodeBlockHeader, decodeTx, encodeTx, txId )
 import Cardano.Wallet.Primitive
     ( Address (..)
     , Block (..)
@@ -32,11 +32,13 @@ import Test.Hspec
 
 import qualified Codec.CBOR.Decoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
+import qualified Codec.CBOR.Write as CBOR
 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
     describe "Decoding blocks" $ do
@@ -60,6 +62,29 @@ spec = do
             let decoded = unsafeDeserialiseFromBytes decodeBlock bs
             decoded `shouldBe` block3
 
+    describe "Encoding Tx" $ do
+        let txs = Set.toList (transactions block2 <> transactions block3)
+        let roundTripTx tx = do
+                let bytes = CBOR.toLazyByteString (encodeTx tx)
+                let tx' = unsafeDeserialiseFromBytes decodeTx bytes
+                tx `shouldBe` tx'
+
+        it "encode . decode = pure (1)" $ do
+            roundTripTx (txs !! 0)
+
+        it "encode . decode = pure (2)" $ do
+            roundTripTx (txs !! 1)
+
+        it "should compute correct txId (1)" $ do
+            let hash = txId (txs !! 0)
+            let hash' = hash16 "c470563001e448e61ff1268c2a6eb458ace1d04011a02cb262b6d709d66c23d0"
+            hash `shouldBe` hash'
+
+        it "should compute correct txId (2)" $ do
+            let hash = txId (txs !! 1)
+            let hash' = hash16 "d30d37f1f8674c6c33052826fdc5bc198e3e95c150364fd775d4bc663ae6a9e6"
+            hash `shouldBe` hash'
+
 
 -- A mainnet block header
 blockHeader1 :: BlockHeader

test/unit/Cardano/Wallet/PrimitiveSpec.hs

@@ -26,12 +26,11 @@ import Cardano.Wallet.Primitive
     , restrictedBy
     , restrictedTo
     , updatePending
-    , utxoFromTx
     )
 import Data.Set
     ( Set, (\\) )
 import Test.Hspec
-    ( Spec, describe, it, pendingWith )
+    ( Spec, describe, it )
 import Test.QuickCheck
     ( Arbitrary (..)
     , Property
@@ -40,7 +39,6 @@ import Test.QuickCheck
     , cover
     , oneof
     , property
-    , quickCheck
     , scale
     , vectorOf
     , (===)
@@ -85,11 +83,6 @@ spec = do
         it "3.3) updatePending b pending ⊆ pending"
             (checkCoverage prop_3_2)
 
-    describe "Miscellaneous properties" $ do
-        it "utxoFromTx preserve number of outputs" $ do
-            pendingWith "Need txId to be implemented first"
-            quickCheck $ checkCoverage prop_utxoFromTx
-
 
 {-------------------------------------------------------------------------------
        Wallet Specification - Lemma 2.1 - Properties of UTxO operations
@@ -217,18 +210,6 @@ prop_3_2 (b, pending) =
     prop = updatePending b pending `Set.isSubsetOf` pending
 
 
-{-------------------------------------------------------------------------------
-                        Miscellaneous Properties
--------------------------------------------------------------------------------}
-
-prop_utxoFromTx :: Tx -> Property
-prop_utxoFromTx tx =
-    cover 50 cond "outputs tx ≠ ∅ " (property prop)
-  where
-    cond = not $ null $ outputs tx
-    prop = Map.size (getUTxO $ utxoFromTx tx) === length (outputs tx)
-
-
 {-------------------------------------------------------------------------------
                             Arbitrary Instances