api-tools-0.8.0.1: tests/Data/API/Test/JSON.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Data.API.Test.JSON
( jsonTests
) where
import Data.API.API.Gen ( apiAPITestsJSON, apiAPITestsCBOR, apiAPITestsCBORToJSON, apiAPITestsJSONToCBOR )
import Data.API.JSON
import Data.API.NormalForm
import Data.API.Tools
import Data.API.Tools.JSONTests
import Data.API.Test.DSL
import Data.API.Test.Gen hiding ( Foo )
import Data.API.Test.MigrationData
import Data.API.Types
import Data.API.Utils
import qualified Data.API.Value as Value
import qualified Data.Aeson as JS
import qualified Data.HashMap.Strict as HMap
import Data.Time
import Test.Tasty
import Test.Tasty.HUnit
import qualified Test.Tasty.QuickCheck as QC
$(generate startSchema)
$(generateAPITools startSchema
[ enumTool
, jsonTool'
, quickCheckTool
])
-- | Test that literals are decoded correctly, including the dubious
-- use of strings for numbers and numbers for booleans, and missing
-- fields being treated as nulls.
basicValueDecoding :: Assertion
basicValueDecoding = sequence_ [ help (JS.String "12") (12 :: Int) True
, help (JS.String "0") (0 :: Int) True
, help (JS.String "-9") (-9 :: Int) True
, help (JS.String "1a") (1 :: Int) False
, help (JS.Number 1.1) (1 :: Int) True
, help (JS.Number 1.9) (1 :: Int) True
, help (JS.Number 0) False True
, help (JS.Number 1) True True
, help (JS.Number 2) True False
, help (JS.String "0") False False
, help (JS.String "1") True False
, help (JS.Object (HMap.singleton "id" (JS.Number 3)))
(Recursive (Id 3) Nothing)
True
, help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True
, help' noFilter (JS.String "cabcage") (UnsafeMkFilteredString "cabcage") True
, help' noFilter (JS.String "2014-10-13T15:20:10Z") (UnsafeMkFilteredUTC (pUTC "2014-10-13T15:20:10Z")) True
]
where
help v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x)
(prop_decodesTo v x == yes)
help' pf v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x)
(prop_decodesTo' pf v x == yes)
noFilter = defaultParseFlags { enforceFilters = False }
-- | Test that the correct errors are generated for bad JSON data
errorDecoding :: [TestTree]
errorDecoding = [ help "not enough input" "" (proxy :: Int)
#if MIN_VERSION_aeson(0,10,0)
[(SyntaxError "Error in $: not enough input", [])]
#else
[(SyntaxError "not enough input", [])]
#endif
, help "object for int" "{}" (proxy :: Int)
[(Expected ExpInt "Int" (JS.Object HMap.empty), [])]
, help "missing alt" "{}" (proxy :: AUnion)
[(MissingAlt ["bar"], [])]
, help "error inside alt" "{\"bar\": {}}" (proxy :: AUnion)
[(MissingField, [InField "id", InField "bar"])]
, help "unexpected value" "[\"no\"]" (proxy :: [AnEnum])
[(UnexpectedEnumVal ["bar", "foo"] "no", [InElem 0])]
, help "missing field" "{}" (proxy :: Bar)
[(MissingField, [InField "id"])]
, help "int out of range" "[0]" (proxy :: [FilteredInt])
[(IntRangeError "FilteredInt" 0 (IntRange (Just 3) (Just 5)), [InElem 0])]
, help "string mismatch" "[\"cabcage\"]" (proxy :: [FilteredString])
[(RegexError "FilteredString" "cabcage" (mkRegEx "cab*age"), [InElem 0])]
, help "utc out of range" "[\"2014-10-13T15:20:10Z\"]" (proxy :: [FilteredUTC])
[(UTCRangeError "FilteredUTC" (pUTC "2014-10-13T15:20:10Z") (UTCRange (parseUTC_ "2014-10-13T15:20:11Z") Nothing), [InElem 0])]
]
where
proxy = error "proxy"
help x s v es = testCase x $ case decodeWithErrs s `asTypeOf` Right v of
Right _ -> assertFailure $ "Decode returned value: " ++ show s
Left es' -> assertBool ("Unexpected error when decoding: " ++ show s
++ "\n" ++ prettyJSONErrorPositions es'
++ "\ninstead of\n" ++ prettyJSONErrorPositions es)
(es == es')
-- | Test that smart constructors correctly enforce the invariants
smartConstructors :: [TestTree]
smartConstructors =
[ testCase "mkFilteredInt" $ do mkFilteredInt 2 @?= Nothing
mkFilteredInt 3 @?= Just (UnsafeMkFilteredInt 3)
, testCase "mkFilteredUTC" $ do mkFilteredUTC bad_time @?= Nothing
mkFilteredUTC good_time @?= Just (UnsafeMkFilteredUTC good_time)
, testCase "mkFilteredString" $ do mkFilteredString "cabcage" @?= Nothing
mkFilteredString "cabbage" @?= Just (UnsafeMkFilteredString "cabbage")
]
where
bad_time = pUTC "2014-10-13T15:20:10Z"
good_time = pUTC "2014-10-13T15:20:13Z"
pUTC :: String -> UTCTime
pUTC = maybe (error "pUTC") id . parseUTC_
jsonTests :: TestTree
jsonTests = testGroup "JSON"
[ testCase "Basic value decoding" basicValueDecoding
, testGroup "Decoding invalid data" errorDecoding
, testGroup "Smart constructors" smartConstructors
, testGroup "Round-trip tests"
[ testGroup "example JSON" $ map (uncurry QC.testProperty) exampleTestsJSON
, testGroup "example CBOR" $ map (uncurry QC.testProperty) exampleTestsCBOR
, testGroup "example CBOR to JSON" $ map (uncurry QC.testProperty) exampleTestsCBORToJSON
, testGroup "example JSON to CBOR" $ map (uncurry QC.testProperty) exampleTestsJSONToCBOR
, testGroup "example2 JSON" $ map (uncurry QC.testProperty) example2TestsCBOR
, testGroup "example2 CBOR" $ map (uncurry QC.testProperty) example2TestsCBOR
, testGroup "example2 CBOR to JSON" $ map (uncurry QC.testProperty) example2TestsCBORToJSON
, testGroup "example2 JSON to CBOR" $ map (uncurry QC.testProperty) example2TestsJSONToCBOR
, testGroup "api JSON" $ map (uncurry QC.testProperty) apiAPITestsJSON
, testGroup "api CBOR" $ map (uncurry QC.testProperty) apiAPITestsCBOR
, testGroup "api CBOR to JSON" $ map (uncurry QC.testProperty) apiAPITestsCBORToJSON
, testGroup "api JSON to CBOR" $ map (uncurry QC.testProperty) apiAPITestsJSONToCBOR
, QC.testProperty "Aeson Value to CBOR" (prop_cborRoundtrip :: JS.Value -> Bool)
]
, testGroup "Generic values"
[ QC.testProperty "example JSON round-trip" (Value.prop_jsonRoundTrip exampleNF)
, QC.testProperty "example2 JSON round-trip" (Value.prop_jsonRoundTrip example2NF)
, QC.testProperty "example CBOR round-trip" (Value.prop_cborRoundTrip exampleNF)
, QC.testProperty "example2 CBOR round-trip" (Value.prop_cborRoundTrip example2NF)
, testGroup "example agreement with ToJSON" $ map (uncurry QC.testProperty) exampleJSONGenericValueTests
, testGroup "example2 agreement with ToJSON" $ map (uncurry QC.testProperty) example2JSONGenericValueTests
, testGroup "example agreement with Serialise" $ map (uncurry QC.testProperty) exampleCBORGenericValueTests
, testGroup "example2 agreement with Serialise" $ map (uncurry QC.testProperty) example2CBORGenericValueTests
]
]
exampleNF :: NormAPI
exampleNF = apiNormalForm example
example2NF :: NormAPI
example2NF = apiNormalForm example2