Merge pull request #149 from input-output-hk/rvl/listen-no-die

NetworkLayer.listen: don't "die" when node backend fails

src/Cardano/Wallet.hs

@@ -35,6 +35,8 @@ import Cardano.Wallet.Primitive.Model
     ( Wallet, applyBlock, initWallet )
 import Cardano.Wallet.Primitive.Types
     ( Block (..), WalletId (..), WalletMetadata (..), WalletName (..) )
+import Control.Exception
+    ( Exception )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
@@ -84,7 +86,7 @@ newtype CreateWalletError
 
 -- | Create a new instance of the wallet layer.
 mkWalletLayer
-    :: (Show e0)
+    :: (Exception e0)
     => DBLayer IO SeqState
     -> NetworkLayer IO e0 e1
     -> WalletLayer SeqState

src/Cardano/Wallet/Network.hs

@@ -17,16 +17,14 @@ import Cardano.Wallet.Primitive.Types
     ( Block (..), BlockHeader (..), Hash (..), SignedTx, SlotId (..) )
 import Control.Concurrent
     ( threadDelay )
+import Control.Exception
+    ( Exception, throwIO )
 import Control.Monad.IO.Class
     ( MonadIO, liftIO )
 import Control.Monad.Trans.Except
     ( ExceptT, runExceptT )
 import Data.Time.Units
     ( Millisecond, toMicroseconds )
-import Fmt
-    ( fmt, (+||), (||+) )
-import System.Exit
-    ( die )
 
 
 data NetworkLayer m e0 e1 = NetworkLayer
@@ -75,7 +73,7 @@ data TickResult a
 -- | Retrieve blocks from a chain producer and execute some given action for
 -- each block.
 listen
-    :: forall e0 e1. (Show e0)
+    :: forall e0 e1. (Exception e0)
     => NetworkLayer IO e0 e1
     -> ([Block] -> IO ())
     -> IO ()
@@ -93,8 +91,7 @@ listen network action = do
         -- which is fair price to pay in order NOT to have to do any slotting
         -- arithmetic nor track how many blocks are present per epochs.
         case res of
-            Left err ->
-                die $ fmt $ "Chain producer error: "+||err||+""
+            Left err -> throwIO err
             Right bs | length bs < 2 ->
                 pure (Sleep, current)
             Right blocks ->

src/Cardano/Wallet/Network/HttpBridge.hs

@@ -196,7 +196,14 @@ data HttpBridgeError
       -- ^ Could not connect to or read from the node API.
     | BadResponseFromNode String
       -- ^ The node returned an unexpected response.
-    deriving (Show, Eq)
+    deriving (Eq)
+
+instance Show HttpBridgeError where
+    show (NodeUnavailable msg) =
+        "Could not connect to or read from the node API: " ++ msg
+    show (BadResponseFromNode msg) =
+        "The node returned an unexpected response: " ++ msg
+instance Exception HttpBridgeError
 
 blockHeaderHash
     :: WithHash algorithm (ApiT BlockHeader)

test/integration/Cardano/Wallet/Network/HttpBridgeSpec.hs

@@ -41,7 +41,7 @@ import Test.Hspec
     , beforeAll
     , describe
     , it
-    , shouldEndWith
+    , shouldContain
     , shouldReturn
     , shouldSatisfy
     )
@@ -109,36 +109,36 @@ spec = do
 
             let signed = sign txEmpty []
             (Left err) <- runExceptT $ postTx network signed
-            (show err) `shouldEndWith`
-                "Transaction failed verification: transaction has no inputs\\\"})\""
+            (show err) `shouldContain`
+                "Transaction failed verification: transaction has no inputs"
 
         it "empty tx fails 2" $ \(_, network) -> do
 
             let signed = sign txEmpty [pkWitness]
             (Left err) <- runExceptT $ postTx network signed
-            (show err) `shouldEndWith`
-                "Transaction failed verification: transaction has no inputs\\\"})\""
+            (show err) `shouldContain`
+                "Transaction failed verification: transaction has no inputs"
 
         it "old tx fails" $ \(_, network) -> do
 
             let signed = sign txNonEmpty [pkWitness]
             (Left err) <- runExceptT $ postTx network signed
-            (show err) `shouldEndWith`
-                "Failed to send to peers: Blockchain protocol error\\\"})\""
+            (show err) `shouldContain`
+                "Failed to send to peers: Blockchain protocol error"
 
         it "tx fails - more inputs than witnesses" $ \(_, network) -> do
 
             let signed = sign txNonEmpty []
             (Left err) <- runExceptT $ postTx network signed
-            (show err) `shouldEndWith`
-                "Transaction failed verification: transaction has more inputs than witnesses\\\"})\""
+            (show err) `shouldContain`
+                "Transaction failed verification: transaction has more inputs than witnesses"
 
         it "tx fails - more witnesses than inputs" $ \(_, network) -> do
 
             let signed = sign txNonEmpty [pkWitness, pkWitness]
             (Left err) <- runExceptT $ postTx network signed
-            (show err) `shouldEndWith`
-                "Transaction failed verification: transaction has more witnesses than inputs\\\"})\""
+            (show err) `shouldContain`
+                "Transaction failed verification: transaction has more witnesses than inputs"
   where
     sign :: Tx -> [TxWitness] -> SignedTx
     sign tx witnesses = SignedTx . toBS $ encodeSignedTx (tx, witnesses)