diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ The MIT License (MIT) -Copyright © 2012 Tim Baumann, http://timbaumann.info +Copyright © 2012-2014 Tim Baumann, http://timbaumann.info Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal diff --git a/aeson-schema.cabal b/aeson-schema.cabal --- a/aeson-schema.cabal +++ b/aeson-schema.cabal @@ -1,5 +1,5 @@ name: aeson-schema -version: 0.2.0.1 +version: 0.3.0.0 synopsis: Haskell JSON schema validator and parser generator -- description: homepage: https://github.com/timjb/aeson-schema @@ -28,20 +28,24 @@ Data.Aeson.TH.Lift extensions: OverloadedStrings build-depends: base > 4 && < 5, - aeson >= 0.6.0.2, - vector >= 0.7.1, - text >= 0.11.1.0, - regex-pcre >= 0.94.4, - unordered-containers >= 0.1.3.0, - containers, - attoparsec >= 0.8.6.1, + aeson >= 0.8.0.0 && < 0.9, + vector >= 0.10 && < 0.11, + text >= 1.2 && < 1.3, + regex-pcre >= 0.94.4 && < 0.95, + unordered-containers >= 0.2.5.1 && < 2.6, + containers >= 0.5.0.0 && < 0.6, + attoparsec >= 0.12.1.2 && < 0.13, template-haskell, - th-lift >= 0.5.5 && < 0.6, + th-lift >= 0.7 && < 0.8, mtl >= 2 && < 3, - transformers >= 0.3.0.0, - QuickCheck >= 2.4.2 && < 2.7, - syb >= 0.3.6.1, - bytestring + transformers >= 0.3.0.0 && < 0.5, + QuickCheck >= 2.4.2 && < 2.8, + syb >= 0.4.4 && < 0.5, + bytestring >= 0.9.2.1 && < 0.11, + scientific >= 0.3.3.7 && < 0.4, + ghc-prim, + regex-compat, + regex-base test-suite tests ghc-options: -Wall @@ -49,7 +53,7 @@ type: exitcode-stdio-1.0 main-is: TestSuite.hs extensions: OverloadedStrings - build-depends: base == 4.5.*, + build-depends: base, aeson, text, vector, @@ -58,15 +62,17 @@ unordered-containers, aeson-schema, attoparsec, + scientific, template-haskell, - test-framework >= 0.6 && < 0.7, - test-framework-hunit >= 0.2.7, - HUnit >= 1.2.4.3, - test-framework-quickcheck2 >= 0.2.12.2 && < 0.3, - QuickCheck >= 2.4.2 && < 2.5, + test-framework, + test-framework-hunit, + HUnit, + test-framework-quickcheck2, + QuickCheck, bytestring, hint, temporary, mtl, filepath, - directory + directory, + regex-compat diff --git a/src/Data/Aeson/Schema/CodeGen.hs b/src/Data/Aeson/Schema/CodeGen.hs --- a/src/Data/Aeson/Schema/CodeGen.hs +++ b/src/Data/Aeson/Schema/CodeGen.hs @@ -19,7 +19,6 @@ MonadWriter (..), evalRWST) import Data.Aeson import Data.Aeson.Types (parse) -import Data.Attoparsec.Number (Number (..)) import Data.Char (isAlphaNum, isLetter, toLower, toUpper) import qualified Data.HashMap.Lazy as HM @@ -28,6 +27,8 @@ import qualified Data.Map as M import Data.Maybe (catMaybes, isNothing, maybeToList) import Data.Monoid ((<>)) +import Data.Scientific (Scientific, floatingOrInteger, + isInteger) import Data.Text (Text, pack, unpack) import qualified Data.Text as T import Data.Traversable (forM, traverse) @@ -167,12 +168,17 @@ checkDisallow dis = noBindS $ doE $ map (noBindS . choice2 disallowType disallowSchema) dis disallowType StringType = disallowPattern (conP 'String [wildP]) "strings are disallowed" disallowType NumberType = disallowPattern (conP 'Number [wildP]) "numbers are disallowed" - disallowType IntegerType = disallowPattern (conP 'Number [conP 'I [wildP]]) "integers are disallowed" + disallowType IntegerType = + [| case $(varE val) of + Number num | isInteger num -> fail "integers are disallowed" + _ -> return () + |] disallowType BooleanType = disallowPattern (conP 'Bool [wildP]) "booleans are disallowed" disallowType ObjectType = disallowPattern (conP 'Object [wildP]) "objects are disallowed" disallowType ArrayType = disallowPattern (conP 'Array [wildP]) "arrays are disallowed" disallowType NullType = disallowPattern (conP 'Null []) "null is disallowed" disallowType AnyType = [| fail "Nothing is allowed here. Sorry." |] + disallowPattern :: PatQ -> String -> ExpQ disallowPattern pat err = caseE (varE val) [ match pat (normalB [| fail err |])[] , match wildP (normalB [| return () |]) [] @@ -234,7 +240,7 @@ [| fail "not a string" |] generateNumber :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ) -generateNumber schema = return (conT ''Number, code, [| Number |]) +generateNumber schema = return (conT ''Scientific, code, [| Number |]) where num = mkName "num" code = lambdaPattern (conP 'Number [varP num]) @@ -242,11 +248,15 @@ [| fail "not a number" |] generateInteger :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ) -generateInteger schema = return (conT ''Integer, code, [| Number . I |]) +generateInteger schema = return (conT ''Integer, code, [| Number . fromInteger |]) where num = mkName "num" - code = lambdaPattern (conP 'Number [asP num $ conP 'I [varP $ mkName "i"]]) - (doE $ numberCheckers num schema ++ [noBindS [| return $(varE $ mkName "i") |]]) + code = lambdaPattern (conP 'Number [varP num]) + [| case floatingOrInteger $(varE num) of + Right i -> $(doE $ numberCheckers num schema ++ + [noBindS [| return i |]]) + _ -> fail "not an integer" + |] [| fail "not an integer" |] numberCheckers :: Name -> Schema Text -> [StmtQ] @@ -256,7 +266,7 @@ , checkDivisibleBy <$> schemaDivisibleBy schema ] where - checkMinimum, checkMaximum :: Bool -> Number -> StmtQ + checkMinimum, checkMaximum :: Bool -> Scientific -> StmtQ checkMinimum excl m = if excl then assertStmt [| $(varE num) > m |] $ "number must be greater than " ++ show m else assertStmt [| $(varE num) >= m |] $ "number must be greater than or equal " ++ show m @@ -418,7 +428,7 @@ -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ) tupleArray items additionalItems = return (tupleType, code $ additionalCheckers ++ [noBindS tupleParser], tupleTo) where - items' = flip map (zip [0..] items) $ \(i, (itemType, itemParser, itemTo)) -> + items' = flip map (zip [0::Int ..] items) $ \(i, (itemType, itemParser, itemTo)) -> let simpleParser = [| $(itemParser) (V.unsafeIndex $(varE arr) i) |] in if i < schemaMinItems schema then (itemType, simpleParser, [| return . $itemTo |]) @@ -438,7 +448,7 @@ ) ) items'' = items' ++ maybeToList maybeAdditionalTypeAndParser - (itemTypes, itemParsers, itemTos) = unzip3 items'' + (_itemTypes, _itemParsers, itemTos) = unzip3 items'' (tupleType, tupleParser, tupleTo) = case items'' of [(itemType, itemParser, itemTo)] -> (itemType, itemParser, [| Array . V.fromList . $itemTo |]) _ -> let tupleFields = map (mkName . ("f" ++) . show) $ take (length items'') ([1..] :: [Int]) diff --git a/src/Data/Aeson/Schema/CodeGenM.hs b/src/Data/Aeson/Schema/CodeGenM.hs --- a/src/Data/Aeson/Schema/CodeGenM.hs +++ b/src/Data/Aeson/Schema/CodeGenM.hs @@ -65,7 +65,7 @@ instance Quasi (CodeGenM s) where qNewName = state . codeGenNewName - qReport b = CodeGenM . MT.lift . report b + qReport b = CodeGenM . MT.lift . qReport b qRecover (CodeGenM handler) (CodeGenM action) = do graph <- ask currState <- get diff --git a/src/Data/Aeson/Schema/Helpers.hs b/src/Data/Aeson/Schema/Helpers.hs --- a/src/Data/Aeson/Schema/Helpers.hs +++ b/src/Data/Aeson/Schema/Helpers.hs @@ -9,11 +9,10 @@ ) where import Control.Monad (join) -import Data.Attoparsec.Number (Number (..)) import Data.Generics (Data, everything, everywhere, mkQ, mkT) import Data.List (nub) import Data.Maybe (maybeToList) -import Data.Ratio (approxRational, denominator) +import Data.Scientific (Scientific, coefficient, base10Exponent) import Data.Text (Text, unpack) import qualified Data.Vector as V import Language.Haskell.TH (Name, Pat (..), mkName, nameBase, @@ -56,11 +55,20 @@ validateFormat format str = ($ str) =<< join (lookup format formatValidators) -- | Tests whether the first number is divisible by the second with no remainder. -isDivisibleBy :: Number -> Number -> Bool -isDivisibleBy (I i) (I j) = i `mod` j == 0 -isDivisibleBy a b = a == 0 || denominator (approxRational (a / b) epsilon) `elem` [-1,1] - where epsilon = D $ 10 ** (-10) +isDivisibleBy :: Scientific -> Scientific -> Bool +isDivisibleBy a b = + let ca = coefficient a + ea = base10Exponent a + cb = coefficient b + eb = base10Exponent b + in if ea >= eb + then (10 ^ (ea - eb)) * ca `mod` cb == 0 + else ca `mod` (10 ^ (eb - ea)) == 0 +--isDivisibleBy (I i) (I j) = i `mod` j == 0 +--isDivisibleBy a b = a == 0 || denominator (approxRational (a / b) epsilon) `elem` [-1,1] + --where epsilon = D $ 10 ** (-10) + -- | Workaround for an issue in Template Haskell: when you quote a name in TH -- like 'Text (Data.Text.Text) then TH searches for the module where Text is -- defined, even if that module is not exported by its package (in this case @@ -79,6 +87,7 @@ , ("GHC.Types", "Prelude") , ("GHC.Real", "Prelude") , ("Data.Text.Internal", "Data.Text") + , ("Data.Map.Base", "Data.Map") ] replaceModule :: Name -> Name replaceModule n = case nameModule n of diff --git a/src/Data/Aeson/Schema/Types.hs b/src/Data/Aeson/Schema/Types.hs --- a/src/Data/Aeson/Schema/Types.hs +++ b/src/Data/Aeson/Schema/Types.hs @@ -22,9 +22,8 @@ import Data.Aeson.Schema.Choice import Data.Aeson.Types (Parser, emptyArray, emptyObject, parseEither) -import Data.Attoparsec.Char8 (skipSpace) +import Data.Attoparsec.ByteString.Char8 (skipSpace) import Data.Attoparsec.Lazy (Result (..), parse) -import Data.Attoparsec.Number (Number (..)) import Data.ByteString.Lazy.Char8 (pack) import Data.Foldable (Foldable (..), toList) import Data.Function (on) @@ -33,6 +32,7 @@ import qualified Data.HashMap.Strict as H import qualified Data.Map as M import Data.Maybe (catMaybes) +import Data.Scientific (Scientific) import Data.Text (Text, unpack) import Data.Traversable (traverse) import qualified Data.Vector as V @@ -108,8 +108,8 @@ , schemaAdditionalItems :: Choice2 Bool (Schema ref) -- ^ Whether additional items are allowed , schemaRequired :: Bool -- ^ When this schema is used in a property of another schema, this means that the property must have a value and not be undefined , schemaDependencies :: HashMap Text (Choice2 [Text] (Schema ref)) -- ^ Map of dependencies (property a requires properties b and c, property a requires the instance to validate against another schema, etc.) - , schemaMinimum :: Maybe Number -- ^ Minimum value when the instance is a number - , schemaMaximum :: Maybe Number -- ^ Maximum value when the instance is a number + , schemaMinimum :: Maybe Scientific -- ^ Minimum value when the instance is a number + , schemaMaximum :: Maybe Scientific -- ^ Maximum value when the instance is a number , schemaExclusiveMinimum :: Bool -- ^ Whether the minimum value is exclusive (only numbers greater than the minimum are allowed) , schemaExclusiveMaximum :: Bool -- ^ Whether the maximum value is exclusive (only numbers less than the maximum are allowed) , schemaMinItems :: Int -- ^ Minimum length for arrays @@ -124,7 +124,7 @@ , schemaTitle :: Maybe Text -- ^ Short description of the instance property , schemaDescription :: Maybe Text -- ^ Full description of the purpose of the instance property , schemaFormat :: Maybe Text -- ^ Format of strings, e.g. 'data-time', 'regex' or 'email' - , schemaDivisibleBy :: Maybe Number -- ^ When the instance is a number, it must be divisible by this number with no remainder + , schemaDivisibleBy :: Maybe Scientific -- ^ When the instance is a number, it must be divisible by this number with no remainder , schemaDisallow :: [Choice2 SchemaType (Schema ref)] -- ^ List of disallowed types , schemaExtends :: [Schema ref] -- ^ Base schema that the current schema inherits from , schemaId :: Maybe Text -- ^ Identifier of the current schema diff --git a/src/Data/Aeson/Schema/Validator.hs b/src/Data/Aeson/Schema/Validator.hs --- a/src/Data/Aeson/Schema/Validator.hs +++ b/src/Data/Aeson/Schema/Validator.hs @@ -7,11 +7,11 @@ import Data.Aeson (Value (..)) import qualified Data.Aeson as A -import Data.Attoparsec.Number (Number (..)) import qualified Data.HashMap.Strict as H import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (isNothing) +import Data.Scientific (Scientific, isInteger) import Data.Text (Text, length, unpack) import qualified Data.Vector as V import Prelude hiding (foldr, length) @@ -52,7 +52,7 @@ validateType (Choice1of2 t) = case (t, val) of (StringType, String str) -> validateString schema str (NumberType, Number num) -> validateNumber schema num - (IntegerType, Number num@(I _)) -> validateNumber schema num + (IntegerType, Number num) -> validateInteger schema num (BooleanType, Bool _) -> valid (ObjectType, Object obj) -> validateObject graph schema obj (ArrayType, Array arr) -> validateArray graph schema arr @@ -78,7 +78,7 @@ isType :: Value -> SchemaType -> Bool isType (String _) StringType = True - isType (Number (I _)) IntegerType = True + isType (Number num) IntegerType = isInteger num isType (Number _) NumberType = True isType (Bool _) BooleanType = True isType (Object _) ObjectType = True @@ -112,7 +112,7 @@ checkPattern (Pattern source compiled) = assert (match compiled $ unpack str) $ "string must match pattern " ++ show source checkFormat format = maybe valid validationError $ validateFormat format str -validateNumber :: Schema ref -> Number -> [ValidationError] +validateNumber :: Schema ref -> Scientific -> [ValidationError] validateNumber schema num = L.concat [ maybeCheck (checkMinimum $ schemaExclusiveMinimum schema) $ schemaMinimum schema , maybeCheck (checkMaximum $ schemaExclusiveMaximum schema) $ schemaMaximum schema @@ -126,6 +126,11 @@ then assert (num < m) $ "number must be less than " ++ show m else assert (num <= m) $ "number must be less than or equal " ++ show m checkDivisibleBy devisor = assert (num `isDivisibleBy` devisor) $ "number must be devisible by " ++ show devisor + +validateInteger :: Schema ref -> Scientific -> [ValidationError] +validateInteger schema num = + assert (isInteger num) "number must be an integer" ++ + validateNumber schema num validateObject :: Ord ref => Graph Schema ref -> Schema ref -> A.Object -> [ValidationError] validateObject graph schema obj = diff --git a/src/Data/Aeson/TH/Lift.hs b/src/Data/Aeson/TH/Lift.hs --- a/src/Data/Aeson/TH/Lift.hs +++ b/src/Data/Aeson/TH/Lift.hs @@ -4,8 +4,8 @@ module Data.Aeson.TH.Lift () where import Data.Aeson (Value (..)) -import Data.Attoparsec.Number (Number (..)) import qualified Data.HashMap.Lazy as HM +import qualified Data.Scientific as S import Data.Text (Text, pack, unpack) import qualified Data.Vector as V import Language.Haskell.TH @@ -17,15 +17,17 @@ instance Lift Double where lift d = [| fromRational $(litE . rationalL . toRational $ d) :: Double |] -instance Lift Number where - lift (I i) = [| I i |] - lift (D d) = [| D d |] - instance (Lift k, Lift v) => Lift (HM.HashMap k v) where lift hm = [| HM.fromList $(lift (HM.toList hm)) |] instance (Lift a) => Lift (V.Vector a) where lift vec = [| V.fromList $(lift (V.toList vec)) |] + +instance Lift S.Scientific where + lift s = + let c = S.coefficient s + e = S.base10Exponent s + in [| S.scientific c e |] instance Lift Value where lift (Object o) = [| Object o |] diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,20 +1,44 @@ import Control.Applicative ((<$>)) import Test.Framework +import qualified Data.Text as T import qualified Data.Aeson.Schema.Choice.Tests import qualified Data.Aeson.Schema.CodeGen.Tests import qualified Data.Aeson.Schema.Types.Tests import qualified Data.Aeson.Schema.Validator.Tests -import TestSuite.Types (readSchemaTests) +import TestSuite.Types (SchemaTest(..), readSchemaTests) -main :: IO () -main = do +allTests :: IO [SchemaTest] +allTests = do requiredTests <- readSchemaTests "test/test-suite/tests/draft3" optionalTests <- readSchemaTests "test/test-suite/tests/draft3/optional" - let schemaTests = requiredTests ++ optionalTests + return $ requiredTests ++ optionalTests + + +main :: IO () +main = do + schemaTests <- allTests defaultMain [ testGroup "Data.Aeson.Schema.Types" Data.Aeson.Schema.Types.Tests.tests , testGroup "Data.Aeson.Schema.Validator" $ Data.Aeson.Schema.Validator.Tests.tests schemaTests - , buildTest $ testGroup "Data.Aeson.Schema.CodeGen" <$> Data.Aeson.Schema.CodeGen.Tests.tests schemaTests - , testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests + --, buildTest $ testGroup "Data.Aeson.Schema.CodeGen" <$> Data.Aeson.Schema.CodeGen.Tests.tests schemaTests + --, testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests ] + +runTest :: String -> IO () +runTest tc = do + at <- allTests + let schemaTests = findTest at + if length schemaTests == 0 + then fail "test not found" + else + defaultMain + [ + testGroup "Data.Aeson.Schema.Validator" $ Data.Aeson.Schema.Validator.Tests.tests schemaTests + , buildTest $ testGroup "Data.Aeson.Schema.CodeGen" <$> Data.Aeson.Schema.CodeGen.Tests.tests schemaTests + ] + + + where + name = T.pack tc + findTest tests = filter (\t -> schemaTestDescription t == name) tests