Merge pull request #73 from SamirTalwar/json-errors

Make sure the full path is included in JSON errors.

fixtures/malformed-specs/unknown-matcher.yaml

@@ -0,0 +1,13 @@
+command:
+  - ruby
+  - fixtures/calculator.rb
+
+tests:
+  - name: addition
+    stdin: |
+      2 + 2
+    stdout:
+      compute:
+        plus:
+          - 2
+          - 2

fixtures/malformed-specs/wrong-type.yaml

@@ -0,0 +1,9 @@
+command:
+  - ruby
+  - fixtures/calculator.rb
+
+tests:
+  - name: addition
+    stdin: |
+      2 + 2
+    stdout: [4]

package.yaml

@@ -13,6 +13,10 @@ synopsis: An integration test framework for console applications.
 category: Testing
 description: Please see README.md
 
+default-extensions:
+  - DataKinds
+  - ScopedTypeVariables
+
 dependencies:
   - base >= 4.13 && < 5
   - aeson
@@ -41,8 +45,6 @@ library:
     - -Wall
     - -Werror
     - -Wno-unticked-promoted-constructors
-  default-extensions:
-    - DataKinds
   when:
     condition: os(windows)
     then:
@@ -70,8 +72,6 @@ executables:
       - -threaded
       - -rtsopts
       - -with-rtsopts=-N
-    default-extensions:
-      - DataKinds
     when:
       condition: os(windows)
       then:
@@ -94,8 +94,6 @@ tests:
       - -threaded
       - -rtsopts
       - -with-rtsopts=-N
-    default-extensions:
-      - DataKinds
     dependencies:
       - smoke
       - hedgehog

spec/malformed-specs.yaml

@@ -6,11 +6,9 @@ tests:
     stderr:
       - |
         The test specification "fixtures/malformed-specs/empty.yaml" is invalid:
-          Aeson exception:
           Error in $: parsing Suite failed, expected Object, but encountered Null
       - |
         The test specification "fixtures\malformed-specs\empty.yaml" is invalid:
-          Aeson exception:
           Error in $: parsing Suite failed, expected Object, but encountered Null
 
   - name: invalid-yaml
@@ -36,9 +34,31 @@ tests:
     stderr:
       - |
         The test specification "fixtures/malformed-specs/test-as-dict.yaml" is invalid:
-          Aeson exception:
           Error in $.tests: parsing [] failed, expected Array, but encountered Object
       - |
         The test specification "fixtures\malformed-specs\test-as-dict.yaml" is invalid:
-          Aeson exception:
           Error in $.tests: parsing [] failed, expected Array, but encountered Object
+
+  - name: wrong-type
+    args:
+      - fixtures/malformed-specs/wrong-type.yaml
+    exit-status: 2
+    stderr:
+      - |
+        The test specification "fixtures/malformed-specs/wrong-type.yaml" is invalid:
+          Error in $.tests[0].stdout[0]: expected "contents" or a "file", but encountered Number
+      - |
+        The test specification "fixtures\malformed-specs\wrong-type.yaml" is invalid:
+          Error in $.tests[0].stdout[0]: expected "contents" or a "file", but encountered Number
+
+  - name: unknown-matcher
+    args:
+      - fixtures/malformed-specs/unknown-matcher.yaml
+    exit-status: 2
+    stderr:
+      - |
+        The test specification "fixtures/malformed-specs/unknown-matcher.yaml" is invalid:
+          Error in $.tests[0].stdout: Expected "contents" or a "file"
+      - |
+        The test specification "fixtures\malformed-specs\unknown-matcher.yaml" is invalid:
+          Error in $.tests[0].stdout: Expected "contents" or a "file"

src/lib/Test/Smoke/Discovery.hs

@@ -7,11 +7,13 @@ where
 
 import Control.Monad (forM, unless)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT (..), throwE, withExceptT)
+import Control.Monad.Trans.Except (ExceptT (..), except, throwE, withExceptT)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Internal as Aeson.Internal
 import qualified Data.List as List
 import qualified Data.Text as Text
 import Data.Vector (Vector)
-import Data.Yaml
+import qualified Data.Yaml as Yaml
 import System.Directory (doesDirectoryExist, doesFileExist)
 import qualified System.FilePath as FilePath
 import qualified System.FilePath.Glob as Glob
@@ -67,10 +69,14 @@ splitSuitePath path =
   )
 
 decodeSpecificationFile :: Path Relative File -> Discovery Suite
-decodeSpecificationFile path = do
+decodeSpecificationFile path = withExceptT (InvalidSpecification path) $ do
   resolvedPath <- liftIO $ resolve path
-  withExceptT (InvalidSpecification path . prettyPrintParseException) $
-    ExceptT $ decodeFileEither (toFilePath resolvedPath)
+  value :: Aeson.Value <-
+    withExceptT Yaml.prettyPrintParseException $
+      ExceptT $ Yaml.decodeFileEither (toFilePath resolvedPath)
+  except $ case Aeson.Internal.ifromJSON value of
+    Aeson.Internal.IError jsonPath message -> Left $ Aeson.Internal.formatError jsonPath message
+    Aeson.Internal.ISuccess suite -> Right suite
 
 parseRoot :: String -> Discovery Root
 parseRoot location = do

src/lib/Test/Smoke/Types/Tests.hs

@@ -3,8 +3,7 @@
 module Test.Smoke.Types.Tests where
 
 import Data.Aeson
-import Data.Aeson.Types (Parser)
-import Data.Default
+import Data.Default (def)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Vector (Vector)
@@ -38,7 +37,7 @@ instance FromJSON Suite where
         <$> (v .:? "working-directory")
         <*> (v .:? "shell")
         <*> (v .:? "command")
-        <*> (mapM parseJSON =<< (v .: "tests"))
+        <*> (v .: "tests")
 
 data Test = Test
   { testName :: TestName,
@@ -64,8 +63,8 @@ instance FromJSON Test where
         <*> (v .:? "args")
         <*> (v .:? "stdin")
         <*> (v .:? "exit-status" .!= def)
-        <*> (manyMaybe =<< (v .:? "stdout"))
-        <*> (manyMaybe =<< (v .:? "stderr"))
+        <*> (manyMaybe <$> (v .:? "stdout"))
+        <*> (manyMaybe <$> (v .:? "stderr"))
         <*> ( Map.fromList . map (\(TestFile path contents) -> (path, contents)) . Vector.toList
                 <$> (v .:? "files" .!= Vector.empty)
             )
@@ -79,11 +78,14 @@ data TestFile = TestFile
 instance FromJSON TestFile where
   parseJSON =
     withObject "TestFile" $ \v ->
-      TestFile <$> (v .: "path") <*> (many =<< (v .: "contents"))
+      TestFile <$> (v .: "path") <*> (unMany <$> (v .: "contents"))
 
-many :: FromJSON a => Value -> Parser (Vector a)
-many (Array v) = mapM parseJSON v
-many v = Vector.singleton <$> parseJSON v
+newtype Many a = Many {unMany :: Vector a}
 
-manyMaybe :: FromJSON a => Maybe Value -> Parser (Vector a)
-manyMaybe = maybe (return Vector.empty) many
+instance FromJSON a => FromJSON (Many a) where
+  parseJSON a@(Array _) = Many <$> parseJSON a
+  parseJSON v = Many . Vector.singleton <$> parseJSON v
+
+manyMaybe :: FromJSON a => Maybe (Many a) -> Vector a
+manyMaybe Nothing = Vector.empty
+manyMaybe (Just v) = unMany v

src/lib/Test/Smoke/Types/Values.hs

@@ -22,11 +22,11 @@ instance (FixtureType a, FromJSON a) => FromJSON (Contents a) where
     maybeContents <- v .:? "contents"
     maybeFile <- v .:? "file"
     case (maybeContents, maybeFile) of
-      (Just _, Just _) -> fail "Expected \"contents\" or a \"file\", not both."
+      (Just _, Just _) -> fail "Expected \"contents\" or a \"file\", not both"
       (Just contents, Nothing) -> Inline <$> parseJSON contents
       (Nothing, Just file) -> return $ FileLocation file
-      (Nothing, Nothing) -> fail "Expected \"contents\" or a \"file\"."
-  parseJSON invalid = typeMismatch "contents" invalid
+      (Nothing, Nothing) -> fail "Expected \"contents\" or a \"file\""
+  parseJSON invalid = typeMismatch "\"contents\" or a \"file\"" invalid
 
 data TestInput a where
   TestInput :: Contents a -> TestInput a