git.iko.soy/typeable/hjsonschema
on doctest help sign in
typeable/hjsonschema/test/Shared.hs
136 lines 4.7 kB history raw
2module Shared where
4import Protolude
6import Control.Monad (fail)
7import Data.Aeson
8import Data.Aeson.TH (fieldLabelModifier)
9import qualified Data.ByteString as BS
10import Data.Char (toLower)
11import Data.List (stripPrefix, unlines)
12import qualified Data.Text as T
13import qualified System.Directory as SD
14import System.FilePath ((</>))
15import Test.Hspec
17-- Recursively return the contents of a directory
18-- (or return itself if given a file as an argument).
19--
20-- Return paths are relative to that directory.
21listFiles :: FilePath -> IO [FilePath]
22listFiles path = fmap ( fromMaybe "stripPrefix failed"
23 . stripPrefix (path <> "/")
24 ) <$> listFilesFullPath path
26-- Recursively return the contents of a directory
27-- (or return itself if given a file as an argument).
28--
29-- All return paths start with the 'FilePath' argument.
30listFilesFullPath :: FilePath -> IO [FilePath]
31listFilesFullPath path = do
32 -- Check if it's a file or directory:
33 res <- SD.doesFileExist path
34 if res
35 then pure [path]
36 else do
37 fs <- fmap (path </>) <$> SD.listDirectory path
38 concat <$> traverse listFilesFullPath fs
40isHTTPTest :: FilePath -> Bool
41isHTTPTest file = (file == "definitions.json")
42 || (file == "ref.json")
43 || (file == "refRemote.json")
45-- | We may never support the @"format"@ keywords
46-- and are currently failing the others listed here.
47skipOptional :: FilePath -> Bool
48skipOptional file = (file == "optional/format.json")
49 || (file == "optional/zeroTerminatedFloats.json")
50 || (file == "optional/ecmascript-regex.json")
52data SchemaTest = SchemaTest
53 { _stDescription :: Text
54 , _stSchema :: Value
55 , _stCases :: [SchemaTestCase]
56 }
58data SchemaTestCase = SchemaTestCase
59 { _scDescription :: Text
60 , _scData :: Value
61 , _scValid :: Bool
62 } deriving Generic
64instance FromJSON SchemaTest where
65 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
66 <$> o .: "description"
67 <*> o .: "schema"
68 <*> o .: "tests" -- Perhaps "cases" would have been
69 -- a more descriptive key.
71instance FromJSON SchemaTestCase where
72 parseJSON = genericParseJSON
73 defaultOptions
74 { fieldLabelModifier = fmap toLower . drop 3 }
76readSchemaTests
77 :: FilePath
78 -- ^ The path to a directory.
79 -> (FilePath -> Bool)
80 -- ^ A function to decide what we're interested in within that directory.
81 -> IO [SchemaTest]
82readSchemaTests dir filterFunc = do
83 files <- filter filterFunc <$> listFiles dir
84 concat <$> traverse fileToCases files
85 where
86 -- Each file contains an array of SchemaTests, not just one.
87 fileToCases :: FilePath -> IO [SchemaTest]
88 fileToCases name = do
89 let fullPath = dir </> name
90 jsonBS <- BS.readFile fullPath
91 case eitherDecodeStrict jsonBS of
92 Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
93 Right schemaTests -> pure $ prependFileName name <$> schemaTests
95 prependFileName :: FilePath -> SchemaTest -> SchemaTest
96 prependFileName fileName s = s
97 { _stDescription = T.pack fileName <> ": " <> _stDescription s
98 }
100toTest
101 :: forall schema. FromJSON schema
102 => (schema -> SchemaTestCase -> Expectation)
103 -> SchemaTest
104 -> Spec
105toTest validate st =
106 it (T.unpack (_stDescription st)) $
107 forM_ (_stCases st) (validate schema)
108 where
109 schema :: schema
110 schema = case fromJSON (_stSchema st) of
111 Error e -> panic ("Couldn't parse schema: " <> show e)
112 Success a -> a
114assertResult :: Show err => SchemaTestCase -> [err] -> Expectation
115assertResult sc failures
116 | _scValid sc = assertValid sc failures
117 | otherwise = assertInvalid sc failures
119assertValid :: Show err => SchemaTestCase -> [err] -> Expectation
120assertValid _ [] = pure ()
121assertValid sc failures =
122 expectationFailure $ unlines
123 [ " Failed to validate data"
124 , " Description: " <> T.unpack (_scDescription sc)
125 , " Data: " <> show (_scData sc)
126 , " Validation failures: " <> show failures
127 ]
129assertInvalid :: SchemaTestCase -> [err] -> Expectation
130assertInvalid sc [] =
131 expectationFailure $ unlines
132 [ " Validated invalid data"
133 , " Description: " <> T.unpack (_scDescription sc)
134 , " Data: " <> show (_scData sc)
135 ]
136assertInvalid _ _ = pure ()