aeson-schema 0.2.0.1 → 0.3.0.0
raw patch · 9 files changed
+113/−57 lines, 9 filesdep +ghc-primdep +regex-basedep +regex-compatdep ~HUnitdep ~QuickCheckdep ~aeson
Dependencies added: ghc-prim, regex-base, regex-compat, scientific
Dependency ranges changed: HUnit, QuickCheck, aeson, attoparsec, base, bytestring, containers, regex-pcre, syb, test-framework, test-framework-hunit, test-framework-quickcheck2, text, th-lift, transformers, unordered-containers, vector
Files
- LICENSE +1/−1
- aeson-schema.cabal +26/−20
- src/Data/Aeson/Schema/CodeGen.hs +19/−9
- src/Data/Aeson/Schema/CodeGenM.hs +1/−1
- src/Data/Aeson/Schema/Helpers.hs +15/−6
- src/Data/Aeson/Schema/Types.hs +5/−5
- src/Data/Aeson/Schema/Validator.hs +9/−4
- src/Data/Aeson/TH/Lift.hs +7/−5
- test/TestSuite.hs +30/−6
LICENSE view
@@ -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
aeson-schema.cabal view
@@ -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
src/Data/Aeson/Schema/CodeGen.hs view
@@ -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])
src/Data/Aeson/Schema/CodeGenM.hs view
@@ -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
src/Data/Aeson/Schema/Helpers.hs view
@@ -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
src/Data/Aeson/Schema/Types.hs view
@@ -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
src/Data/Aeson/Schema/Validator.hs view
@@ -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 =
src/Data/Aeson/TH/Lift.hs view
@@ -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 |]
test/TestSuite.hs view
@@ -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