Better story for handling JSON exceptions.

Author: Patrick Thomson

src/Data/Handle.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveAnyClass, GADTs #-}
 
 module Data.Handle
   ( Handle (..)
@@ -11,14 +11,15 @@ module Data.Handle
   , readBlobPairsFromHandle
   , readFromHandle
   , openFileForReading
+  , InvalidJSONException (..)
   ) where
 
 import Prologue
 
+import           Control.Exception (throw)
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
-import           System.Exit
 import qualified System.IO as IO
 
 import Data.Blob
@@ -58,9 +59,14 @@ readPathsFromHandle (ReadHandle h) = liftIO $ fmap BLC.unpack . BLC.lines <$> BL
 readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
 readBlobPairsFromHandle = fmap blobs <$> readFromHandle
 
+newtype InvalidJSONException = InvalidJSONException String
+  deriving (Eq, Show, Exception)
+
+-- | Read JSON-encoded data from a 'Handle'. Throws
+-- 'InvalidJSONException' on parse failure.
 readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
 readFromHandle (ReadHandle h) = do
   input <- liftIO $ BL.hGetContents h
   case eitherDecode input of
-    Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
+    Left e  -> throw (InvalidJSONException e)
     Right d -> pure d

test/Semantic/IO/Spec.hs

@@ -84,15 +84,15 @@ spec = parallel $ do
 
     it "throws on blank input" $ do
       h <- openFileForReading "test/fixtures/cli/blank.json"
-      readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
+      readBlobPairsFromHandle h `shouldThrow` jsonException
 
     it "throws if language field not given" $ do
       h <- openFileForReading "test/fixtures/cli/diff-no-language.json"
-      readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
+      readBlobsFromHandle h `shouldThrow` jsonException
 
     it "throws if null on before and after" $ do
       h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json"
-      readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
+      readBlobPairsFromHandle h `shouldThrow` jsonException
 
   describe "readBlobsFromHandle" $ do
     it "returns blobs for valid JSON encoded parse input" $ do
@@ -103,9 +103,13 @@ spec = parallel $ do
 
     it "throws on blank input" $ do
       h <- openFileForReading "test/fixtures/cli/blank.json"
-      readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
+      readBlobsFromHandle h `shouldThrow` jsonException
 
   where blobsFromFilePath path = do
           h <- openFileForReading path
           blobs <- readBlobPairsFromHandle h
           pure blobs
+
+jsonException :: Selector InvalidJSONException
+jsonException = const True
+