Implement Jörmungandr Transaction-message decoder

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE BinaryLiterals #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -16,7 +17,6 @@ module Cardano.Wallet.Binary.Jormungandr
     , Block (..)
     , BlockHeader (..)
     , ConfigParam (..)
-    , Discrimination (..)
     , LeaderId (..)
     , LinearFee (..)
     , Milli (..)
@@ -28,8 +28,18 @@ module Cardano.Wallet.Binary.Jormungandr
 
 import Prelude
 
+import Cardano.Environment.Jormungandr
+    ( Network (..) )
 import Cardano.Wallet.Primitive.Types
-    ( Hash (..), SlotId (..) )
+    ( Address (..)
+    , Coin (..)
+    , Hash (..)
+    , SlotId (..)
+    , Tx (..)
+    , TxIn (..)
+    , TxOut (..)
+    , TxWitness (..)
+    )
 import Control.Monad
     ( replicateM )
 import Data.Binary.Get
@@ -70,8 +80,9 @@ data TODO = TODO
 data SignedVote = SignedVote
     deriving (Eq, Show)
 
+-- Do-notation is favoured over applicative syntax for readability:
+{-# ANN module ("HLint: ignore Use <$>" :: String) #-}
 
-{-# ANN getBlockHeader ("HLint: ignore Use <$>" :: String) #-}
 getBlockHeader :: Get BlockHeader
 getBlockHeader =  (fromIntegral <$> getWord16be) >>= \s -> isolate s $ do
     version <- getWord16be
@@ -114,7 +125,7 @@ getBlock = do
 data Message
     = Initial [ConfigParam]
     | OldUtxoDeclaration TODO
-    | Transaction TODO
+    | Transaction Tx
     | Certificate TODO
     | UpdateProposal SignedUpdateProposal
     | UpdateVote SignedVote
@@ -130,7 +141,7 @@ getMessage = do
     isolate remaining $ case contentType of
         0 -> Initial <$> getInitial
         1 -> unimpl
-        2 -> unimpl
+        2 -> Transaction <$> getTransaction
         3 -> unimpl
         4 -> unimpl
         5 -> unimpl
@@ -141,14 +152,85 @@ getInitial = do
     len <- fromIntegral <$> getWord16be
     replicateM len getConfigParam
 
+getTransaction :: Get Tx
+getTransaction = isolate 43 $ do
+    (ins, outs) <- getTokenTransfer
+
+    let witnessCount = length ins
+    _wits <- replicateM witnessCount getWitness
+
+    return $ Tx ins outs
+  where
+    getWitness = do
+        tag <- getWord8
+        case tag of
+            1 -> isolate 128 $ do
+                -- Old address witness scheme
+                xpub <- getByteString 64
+                sig <- Hash <$> getByteString 64
+                return $ PublicKeyWitness xpub sig
+
+            2 -> isolate 64 $ do
+                _sig <- Hash <$> getByteString 64
+                error "unimplemented: New address witness scheme"
+
+            3 -> isolate 68 $ do
+                error "unimplemented: Account witness"
+            other -> fail $ "Invalid witness type: " ++ show other
+
+
+{-------------------------------------------------------------------------------
+                            Common Structure
+-------------------------------------------------------------------------------}
+
+getTokenTransfer :: Get ([TxIn], [TxOut])
+getTokenTransfer = do
+    inCount <- fromIntegral <$> getWord8
+    outCount <- fromIntegral <$> getWord8
+    ins <- replicateM inCount getInput
+    outs <- replicateM outCount getOutput
+    return (ins, outs)
+  where
+    getInput = isolate 41 $ do
+        -- NOTE: special value 0xff indicates account spending
+        index <- fromIntegral <$> getWord8
+        tx <- Hash <$> getByteString 32
+
+        return $ TxIn tx index
+
+    getOutput = do
+        addr <- getAddress
+        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
+
 {-------------------------------------------------------------------------------
                             Config Parameters
 -------------------------------------------------------------------------------}
 
 data ConfigParam
     -- Seconds elapsed since 1-Jan-1970 (unix time)
     = Block0Date Word64
-    | ConfigDiscrimination Discrimination
+    | ConfigDiscrimination Network
     | ConsensusVersion Word16 -- ?
     | SlotsPerEpoch Word32
     | SlotDuration Word8
@@ -175,7 +257,7 @@ getConfigParam = do
     let len = fromIntegral $ taglen .&. (63) -- 0b111111
 
     isolate len $ case tag of
-        1 -> ConfigDiscrimination <$> getDiscrimination
+        1 -> ConfigDiscrimination <$> getNetwork
         2 -> Block0Date <$> getWord64be
         3 -> ConsensusVersion <$> getWord16be -- ?
         4 -> SlotsPerEpoch <$> getWord32be
@@ -191,9 +273,6 @@ getConfigParam = do
         15 -> ProposalExpiration <$> getWord32be
         a -> fail $ "Invalid config param with tag " ++ show a
 
-data Discrimination = Production | Test
-    deriving (Eq, Show)
-
 newtype Milli = Milli Word64
     deriving (Eq, Show)
 
@@ -203,11 +282,11 @@ newtype LeaderId = LeaderId ByteString
 data LinearFee = LinearFee Word64 Word64 Word64
     deriving (Eq, Show)
 
-getDiscrimination :: Get Discrimination
-getDiscrimination = getWord8 >>= \case
-    1 -> return Production
-    2 -> return Test
-    a -> fail $ "Invalid discrimination value: " ++ show a
+getNetwork :: Get Network
+getNetwork = getWord8 >>= \case
+    1 -> return Mainnet
+    2 -> return Testnet
+    a -> fail $ "Invalid network/discrimination value: " ++ show a
 
 getMilli :: Get Milli
 getMilli = Milli <$> getWord64be

lib/jormungandr/test/unit/Cardano/Wallet/Binary/JormungandrSpec.hs

@@ -6,11 +6,12 @@ module Cardano.Wallet.Binary.JormungandrSpec (spec) where
 
 import Prelude
 
+import Cardano.Environment.Jormungandr
+    ( Network (..) )
 import Cardano.Wallet.Binary.Jormungandr
     ( Block (..)
     , BlockHeader (..)
     , ConfigParam (..)
-    , Discrimination (..)
     , LeaderId (..)
     , LinearFee (..)
     , Message (..)
@@ -20,7 +21,7 @@ import Cardano.Wallet.Binary.Jormungandr
     , runGet
     )
 import Cardano.Wallet.Primitive.Types
-    ( Hash (..), SlotId (..) )
+    ( Address (..), Coin (..), Hash (..), SlotId (..), Tx (..), TxOut (..) )
 import Data.ByteArray.Encoding
     ( Base (Base16), convertFromBase )
 import Data.ByteString
@@ -60,7 +61,7 @@ genesisBlock :: Block
 genesisBlock = Block genesisHeader
     [ Initial
         [ Block0Date 1556202057
-        , ConfigDiscrimination Test
+        , ConfigDiscrimination Testnet
         , ConsensusVersion 1
         , SlotsPerEpoch 2160
         , SlotDuration 15
@@ -72,7 +73,15 @@ genesisBlock = Block genesisHeader
         , AllowAccountCreation True
         , ConfigLinearFee (LinearFee 0 0 0)
         ]
-    , UnimplementedMessage 2
+    , Transaction $ Tx
+        { 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/"
+                , coin = Coin 14
+                }
+            ]
+        }
     , UnimplementedMessage 1
     , UnimplementedMessage 3
     ]