Stricter jörmungandr binary encoders regarding integer overflow

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

@@ -12,8 +12,14 @@
 -- License: MIT
 --
 -- The format is for the Shelley era as implemented by the Jörmungandr node.
---
 -- It is described [here](https://github.com/input-output-hk/rust-cardano/blob/master/chain-impl-mockchain/doc/format.md)
+--
+-- The module to some extent defines its own Jörmungandr-specific types,
+-- different from "Cardano.Wallet.Primitive.Types". Here, transactions are just
+-- one of many possible 'Message's that can be included in a block.
+--
+-- In some cases it also leads us to /throw exceptions/ when integers would
+-- otherwise overflow (look for uses of 'toEnum').
 
 module Cardano.Wallet.Jormungandr.Binary
     ( Block (..)
@@ -70,7 +76,7 @@ import Cardano.Wallet.Primitive.Types
 import Control.Applicative
     ( many )
 import Control.Monad
-    ( replicateM )
+    ( replicateM, unless )
 import Data.Binary.Get
     ( Get
     , bytesRead
@@ -133,7 +139,7 @@ getBlockHeader = label "getBlockHeader" $
         version <- getWord16be
         contentSize <- getWord32be
         slotEpoch <- fromIntegral <$> getWord32be
-        slotId <- fromIntegral <$> getWord32be
+        slotId <- toEnum . fromEnum <$> getWord32be
         chainLength <- getWord32be
         contentHash <- Hash <$> getByteString 32 -- or 256 bits
         parentHeaderHash <- Hash <$> getByteString 32
@@ -259,9 +265,11 @@ getTransaction = label "getTransaction" $ do
 putSignedTx :: (Tx, [TxWitness]) -> Put
 putSignedTx (tx@(Tx inputs outputs), witnesses) = withSizeHeader16be $ do
     putWord8 2
-    putWord8 $ fromIntegral $ length inputs
-    putWord8 $ fromIntegral $ length outputs
+    putWord8 $ toEnum $ length inputs
+    putWord8 $ toEnum $ length outputs
     putTx tx
+    unless (length inputs == length witnesses) $
+        fail "number of witnesses must equal number of inputs"
     mapM_ putWitness witnesses
   where
     -- Assumes the `TxWitness` has been faithfully constructed
@@ -272,13 +280,17 @@ putSignedTx (tx@(Tx inputs outputs), witnesses) = withSizeHeader16be $ do
 
 putTx :: Tx -> Put
 putTx (Tx inputs outputs) = do
+    unless (length inputs <= fromIntegral (maxBound :: Word8)) $
+        fail "number of inputs cannot be greater than 255"
+    unless (length outputs <= fromIntegral (maxBound :: Word8)) $
+        fail "number of outputs cannot be greater than 255"
     mapM_ putInput inputs
     mapM_ putOutput outputs
   where
     putInput (TxIn inputId inputIx, coin) = do
         -- NOTE: special value 0xff indicates account spending
         -- only old utxo/address scheme supported for now
-        putWord8 $ fromIntegral inputIx
+        putWord8 . toEnum . fromEnum $ inputIx
         putWord64be $ getCoin coin
         putByteString $ getHash inputId
 
@@ -454,7 +466,7 @@ isolatePut l x = do
 withSizeHeader16be :: Put -> Put
 withSizeHeader16be x = do
     let bs = BL.toStrict $ runPut x
-    putWord16be (fromIntegral $ BS.length bs)
+    putWord16be (toEnum $ BS.length bs)
     putByteString bs
 
 {-------------------------------------------------------------------------------

lib/jormungandr/test/integration/Cardano/Wallet/Jormungandr/NetworkSpec.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
+
 module Cardano.Wallet.Jormungandr.NetworkSpec
     ( spec
     ) where
@@ -23,7 +24,6 @@ import Cardano.Wallet.Jormungandr.Primitive.Types
 import Cardano.Wallet.Network
     ( ErrGetBlock (..)
     , ErrNetworkTip (..)
-    , ErrPostTx (..)
     , NetworkLayer (..)
     , defaultRetryPolicy
     , waitForConnection
@@ -70,7 +70,6 @@ import Test.Hspec
     , beforeAll
     , describe
     , it
-    , pendingWith
     , shouldBe
     , shouldReturn
     , shouldSatisfy
@@ -82,6 +81,8 @@ import Test.QuickCheck
 import qualified Cardano.Wallet.Jormungandr.Network as Jormungandr
 import qualified Data.ByteString as BS
 
+{-# ANN spec ("HLint: ignore Use head" :: String) #-}
+
 spec :: Spec
 spec = do
     let startNode' = startNode url (`waitForConnection` defaultRetryPolicy)
@@ -169,20 +170,26 @@ spec = do
         $ beforeAll startNode' $ afterAll killNode $ do
 
         it "empty tx succeeds" $ \(_, nw) -> do
+            -- Would be rejected eventually.
             let signedEmpty = (Tx [] [], [])
             runExceptT (postTx nw signedEmpty) `shouldReturn` Right ()
 
         it "some tx succeeds" $ \(_, nw) -> do
             let signed = (txNonEmpty, [pkWitness])
             runExceptT (postTx nw signed) `shouldReturn` Right ()
 
-        it "more inputs than witnesses" $ \(_, nw) -> do
+        it "unbalanced tx (surplus) succeeds" $ \(_, nw) -> do
+            -- Jormungandr will eventually reject txs that are not perfectly
+            -- balanced though.
+            let signed = (unbalancedTx, [pkWitness])
+            runExceptT (postTx nw signed) `shouldReturn` Right ()
+
+        it "more inputs than witnesses - encoder throws" $ \(_, nw) -> do
             let signed = (txNonEmpty, [])
-            let err = Left $ ErrPostTxBadRequest ""
-            runExceptT (postTx nw signed) `shouldReturn` err
+            runExceptT (postTx nw signed) `shouldThrow` someException
 
         it "more witnesses than inputs - fine apparently" $ \(_, nw) -> do
-            -- Becase of how signed txs are encoded:
+            -- Because of how signed txs are encoded:
             -- n                      :: Word8
             -- m                      :: Word8
             -- in_0 .. in_n           :: [TxIn]
@@ -192,9 +199,10 @@ spec = do
             -- this should in practice be like appending bytes to the end of
             -- the message.
             let signed = (txNonEmpty, [pkWitness, pkWitness, pkWitness])
-            runExceptT (postTx nw signed) `shouldReturn` Right ()
+            runExceptT (postTx nw signed) `shouldThrow` someException
 
         it "no input, one output" $ \(_, nw) -> do
+            -- Would be rejected eventually.
             let tx = (Tx []
                     [ (TxOut $ unsafeDecodeAddress proxy
                         "ca1qwunuat6snw60g99ul6qvte98fja\
@@ -203,13 +211,20 @@ spec = do
                     ], [])
             runExceptT (postTx nw tx) `shouldReturn` Right ()
 
-        it "fails when addresses and hashes have wrong length" $ \(_, nw) -> do
-            pendingWith "We need to handle errors in Jormungandr.Binary"
-            let tx = (Tx [] [ TxOut (Address "<not an address>") (Coin 1227362560) ], [])
-            let err = Left $ ErrPostTxBadRequest ""
-            runExceptT (postTx nw tx) `shouldReturn` err
+        it "throws when addresses and hashes have wrong length" $ \(_, nw) -> do
+            let out = TxOut (Address "<not an address>") (Coin 1227362560)
+            let tx = (Tx [] [out] , [])
+            runExceptT (postTx nw tx) `shouldThrow` someException
 
+        it "encoder throws an exception if tx is invalid (eg too many inputs)" $
+            \(_, nw) -> do
+            let inp = head (inputs txNonEmpty)
+            let out = head (outputs txNonEmpty)
+            let tx = (Tx (replicate 300 inp) (replicate 3 out), [])
+            runExceptT (postTx nw tx) `shouldThrow` someException
   where
+    someException = (const True :: SomeException -> Bool)
+
     url :: BaseUrl
     url = BaseUrl Http "localhost" 8081 "/api"
 
@@ -269,3 +284,29 @@ spec = do
                 }
             ]
         }
+
+    unbalancedTx :: Tx
+    unbalancedTx = Tx
+        { inputs =
+            [ (TxIn
+                { inputId = Hash $ unsafeFromHex
+                    "666984dec4bc0ff1888be97bfe0694a9\
+                    \6b35c58d025405ead51d5cc72a3019f4"
+                , inputIx = 0
+                }, Coin 100)
+            ]
+        , outputs =
+            [ TxOut
+                { address = unsafeDecodeAddress proxy
+                    "ca1q0u7k6ltp3e52pch47rhdkld2gdv\
+                    \gu26rwyqh02csu3ah3384f2nvhlk7a6"
+                , coin = Coin 5
+                }
+            , TxOut
+                { address = unsafeDecodeAddress proxy
+                    "ca1qwunuat6snw60g99ul6qvte98fja\
+                    \le2k0uu5mrymylqz2ntgzs6vs386wxd"
+                , coin = Coin 5
+                }
+            ]
+        }