aeson-schema (empty) → 0.1.0.0
raw patch · 13 files changed
+1394/−0 lines, 13 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, aeson-schema, attoparsec, base, bytestring, cmdargs, containers, hashable, hint, mtl, regex-pcre, syb, template-haskell, temporary, test-framework, test-framework-hunit, test-framework-quickcheck2, text, th-lift, transformers, unordered-containers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- aeson-schema.cabal +78/−0
- generate-aeson-schema.hs +48/−0
- src/Data/Aeson/Schema.hs +18/−0
- src/Data/Aeson/Schema/Choice.hs +26/−0
- src/Data/Aeson/Schema/Choice/TH.hs +96/−0
- src/Data/Aeson/Schema/CodeGen.hs +460/−0
- src/Data/Aeson/Schema/Helpers.hs +106/−0
- src/Data/Aeson/Schema/Types.hs +309/−0
- src/Data/Aeson/Schema/Validator.hs +181/−0
- src/Data/Aeson/TH/Lift.hs +36/−0
- test/TestSuite.hs +14/−0
+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright © 2012 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-schema.cabal view
@@ -0,0 +1,78 @@+name: aeson-schema+version: 0.1.0.0+synopsis: Haskell JSON schema validator and parser generator+-- description: +homepage: https://github.com/timjb/aeson-schema+license: MIT+license-file: LICENSE+author: Tim Baumann <tim@timbaumann.info>+maintainer: Tim Baumann <tim@timbaumann.info>+category: Data+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/timjb/haskell-aeson-schema.git++library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Data.Aeson.Schema, Data.Aeson.Schema.Validator, Data.Aeson.Schema.CodeGen, Data.Aeson.Schema.Choice, Data.Aeson.Schema.Helpers, Data.Aeson.Schema.Types+ other-modules: Data.Aeson.Schema.Choice.TH, 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,+ template-haskell,+ th-lift >= 0.5.5 && < 0.6,+ mtl >= 2 && < 3,+ transformers >= 0.3.0.0,+ QuickCheck >= 2.4.2 && < 2.5,+ syb >= 0.3.6.1,+ bytestring++executable generate-aeson-schema+ ghc-options: -Wall+ main-is: generate-aeson-schema.hs+ hs-source-dirs: .+ build-depends: base == 4.5.*,+ aeson-schema,+ cmdargs,+ containers,+ text,+ aeson,+ template-haskell,+ attoparsec,+ bytestring++test-suite tests+ ghc-options: -Wall+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ extensions: OverloadedStrings+ build-depends: base == 4.5.*,+ aeson,+ text,+ vector,+ containers,+ hashable,+ unordered-containers,+ aeson-schema,+ attoparsec,+ 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,+ bytestring,+ hint,+ temporary,+ mtl
+ generate-aeson-schema.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Prelude hiding (readFile)+import Data.Version (showVersion)+import System.Console.CmdArgs+import Data.Aeson.Parser (json)+import Data.ByteString (readFile)+import Data.Attoparsec.ByteString (parse, Result, IResult (..))+import Data.Aeson.Schema.CodeGen (generateModule)+import Language.Haskell.TH.Syntax (runQ)+import Data.Aeson (fromJSON)+import qualified Data.Aeson as A+import Data.Text (Text, pack)+import qualified Data.Text.IO as TIO+import qualified Data.Map as M++import Paths_aeson_schema (version)+import Data.Aeson.Schema (Schema (..))++data GenerateArgs = GenerateArgs+ { modName :: String+ , inputSchema :: FilePath+ } deriving (Data, Show, Typeable)++generateArgs :: GenerateArgs+generateArgs = GenerateArgs+ { modName = "Schema" &= name "module-name" &= opt "Schema" &= help "Name of the generated module"+ , inputSchema = "" &= typFile &= argPos 0+ } &= summary ("generate-aeson-schema-" ++ showVersion version)++main :: IO ()+main = do+ args <- cmdArgs generateArgs+ contents <- readFile $ inputSchema args+ value <- iResultM $ parse json contents+ case fromJSON value :: A.Result (Schema Text) of+ A.Error str -> fail str+ A.Success schema -> do+ let m = M.fromList [(pack "A", schema)]+ (code, _) <- runQ $ generateModule (pack $ modName args) m+ TIO.putStrLn code+ where+ iResultM :: (Monad m) => Result a -> m a+ iResultM (Fail _ _ err) = fail err+ iResultM (Partial _) = fail "unexpected end of file"+ iResultM (Done _ r) = return r
+ src/Data/Aeson/Schema.hs view
@@ -0,0 +1,18 @@+-- | Validate all positive numbers:+-- +-- >>> :set -XQuasiQuotes+-- >>> :m +Data.Aeson Data.Aeson.Schema Data.Map Data.Text+-- >>> let positiveNumbers = [schemaQQ| { "type": "number", "minimum": 0, "exclusiveMinimum": true } |]+-- >>> validate Data.Map.empty positiveNumbers (Number $ fromInteger 1)+-- []+-- >>> validate Data.Map.empty positiveNumbers (Number $ fromInteger 0)+-- ["number must be greater than 0"]+-- >>> validate Data.Map.empty positiveNumbers (String $ pack "lorem")+-- ["type mismatch: expected NumberType but got string"]+module Data.Aeson.Schema+ ( module Data.Aeson.Schema.Types+ , module Data.Aeson.Schema.Validator+ ) where++import Data.Aeson.Schema.Types+import Data.Aeson.Schema.Validator
+ src/Data/Aeson/Schema/Choice.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}++-- | This module implements generalized sum types. In theory, you could use+-- a type representing a choice between different options by nesting the Either+-- type. In practice, however, pattern matching against such a type can quickly+-- become unwieldy. This module defines data types and functions for any number+-- of choices from 2 to 20. The naming schema is based on Data.Either.+-- For example:+-- +-- @+-- data Choice3 a b c = Choice1of3 a | Choice2of3 b | Choice3of3 c deriving (...)+-- choice3 :: (a -> x) -> (b -> x) -> (c -> x) -> Choice3 a b c -> x+-- mapChoice3 :: (a1 -> a2) -> (b1 -> b2) -> (c1 -> c2) -> Choice a1 b1 c1 -> Choice a2 b2 c2+-- choice1of3s :: [Choice3 a b c] -> [a]+-- choice2of3s :: [Choice3 a b c] -> [b]+-- choice3of3s :: [Choice3 a b c] -> [c]+-- @+module Data.Aeson.Schema.Choice where++import Data.Aeson.Schema.Choice.TH (generateChoice)+import Language.Haskell.TH (mkName)+import Language.Haskell.TH.Lift (deriveLiftMany)++$(fmap concat (mapM generateChoice [2..20]))++$(deriveLiftMany $ map (mkName . ("Choice" ++) . show) ([2..20] :: [Int]))
+ src/Data/Aeson/Schema/Choice/TH.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Schema.Choice.TH+ ( generateChoice+ ) where++import Control.Applicative (Alternative (..), (<$>))+import Control.Monad (forM)+import Data.Aeson (FromJSON (..), ToJSON (..))+import Language.Haskell.TH+import Test.QuickCheck (Arbitrary (..), oneof)++generateChoice :: Int -> Q [Dec]+generateChoice n | n < 2 = return []+generateChoice n = do+ tyName <- newName $ "Choice" ++ show n+ let tyParamNames = map (mkName . singleton) $ take n ['a'..]+ let tyParams = map varT tyParamNames+ conNames <- mapM (newName . \i -> "Choice" ++ show i ++ "of" ++ show n) [1..n]+ let cons = zipWith normalC conNames $ map ((:[]) . strictType notStrict) tyParams+ dataDec <- dataD (cxt []) tyName (map PlainTV tyParamNames) cons [''Eq, ''Ord, ''Show, ''Read]+ let tyCon = appConT tyName tyParams+ let genClassConstraints c = cxt $ map (classP c . singleton) tyParams+ instToJSON <- instanceD (genClassConstraints ''ToJSON)+ (conT ''ToJSON `appT` tyCon)+ [ funD 'toJSON $ zipWith genToJSONClause conNames tyParamNames ]+ instFromJSON <- instanceD (genClassConstraints ''FromJSON)+ (conT ''FromJSON `appT` tyCon)+ [ let v = mkName "v" in+ funD 'parseJSON [clause [varP v]+ (normalB $ foldl (\a b -> [| $a <|> $b |]) [| empty |]+ $ map (\con -> [| $(conE con) <$> parseJSON $(varE v) |]) conNames)+ []+ ]+ ]+ instArbitrary <- instanceD (genClassConstraints ''Arbitrary)+ (conT ''Arbitrary `appT` tyCon)+ [ valD (varP 'arbitrary)+ (normalB $ varE 'oneof `appE` listE (map (\con -> [| $(conE con) <$> arbitrary |]) conNames))+ []+ ]+ let choiceN = mkName $ "choice" ++ show n+ let resultT = mkName "res"+ choiceFunDec <- sigD choiceN+ $ forallT (map PlainTV $ tyParamNames ++ [resultT])+ (cxt [])+ $ functionT (map (`arrT` varT resultT) tyParams)+ $ appConT tyName tyParams `arrT` varT resultT+ choiceFun <- funD choiceN+ $ let f = mkName "f"+ v = mkName "v"+ in zipWith (\i con -> clause (replicate i wildP ++ [varP f] ++ replicate (n-i-1) wildP ++ [conP con [varP v]])+ (normalB $ varE f `appE` varE v)+ []) [0..] conNames++ let mapChoiceN = mkName $ "mapChoice" ++ show n+ let typeAs = mkNames 'a'+ let typeBs = mkNames 'b'+ mapChoiceFunDec <- sigD mapChoiceN+ $ forallT (map PlainTV $ typeAs ++ typeBs)+ (cxt [])+ $ functionT (zipWith arrT (map varT typeAs) (map varT typeBs))+ $ appConT tyName (map varT typeAs) `arrT` appConT tyName (map varT typeBs)+ mapChoiceFun <- funD mapChoiceN+ $ let f = mkName "f"+ v = mkName "v"+ in zipWith (\i con -> clause (replicate i wildP ++ [varP f] ++ replicate (n-i-1) wildP ++ [conP con [varP v]])+ (normalB $ conE con `appE` (varE f `appE` varE v))+ []) [0..] conNames+ choiceIofNFuns <- fmap concat $ forM (zip [1..n] conNames) $ \(i, con) -> do+ let choiceIofN = mkName $ "choice" ++ show i ++ "of" ++ show n ++ "s"+ typeDec <- sigD choiceIofN+ $ forallT (map PlainTV tyParamNames)+ (cxt [])+ $ appT listT (appConT tyName (map varT tyParamNames)) `arrT` appT listT (tyParams !! (i-1))+ let cs = mkName "cs"+ c = mkName "c"+ funDef <- funD choiceIofN+ [clause [varP cs] (normalB $ compE [ bindS (conP con [varP c]) (varE cs)+ , noBindS (varE c)+ ]) []]+ return [typeDec, funDef]+ return $ [dataDec, instToJSON, instFromJSON, instArbitrary, choiceFunDec, choiceFun, mapChoiceFunDec, mapChoiceFun] ++ choiceIofNFuns+ where+ singleton :: a -> [a]+ singleton = (:[])+ genToJSONClause :: Name -> Name -> ClauseQ+ genToJSONClause con param = clause [conP con [varP param]] (normalB . appE (varE 'toJSON) . varE $ param) []+ mkNames :: Char -> [Name]+ mkNames ch = map (mkName . (ch:) . show) [1..n]+ arrT :: TypeQ -> TypeQ -> TypeQ+ arrT a b = arrowT `appT` a `appT` b+ functionT :: [TypeQ] -> TypeQ -> TypeQ+ functionT ins out = foldr arrT out ins+ appConT :: Name -> [TypeQ] -> TypeQ+ appConT con = foldl appT (conT con)
+ src/Data/Aeson/Schema/CodeGen.hs view
@@ -0,0 +1,460 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Data.Aeson.Schema.CodeGen+ ( Declaration (..)+ , Code+ , generate+ , generateTH+ , generateModule+ ) where++import Control.Applicative (Applicative (..), (<$>), (<*>),+ (<|>))+import Control.Arrow (first, second)+import Control.Monad (forM_, unless, when, zipWithM)+import Control.Monad.RWS.Lazy (MonadReader (..), MonadState (..),+ MonadWriter (..), RWST (..),+ evalRWST)+import qualified Control.Monad.Trans.Class as MT+import Data.Aeson+import Data.Aeson.Types (parse)+import Data.Attoparsec.Number (Number (..))+import Data.Char (isAlphaNum, isLetter, toLower,+ toUpper)+import Data.Data (Data, Typeable)+import Data.Function (on)+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import Data.List (mapAccumL, sort, unzip4)+import qualified Data.Map as M+import Data.Maybe (catMaybes, isNothing, maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Data.Traversable (forM, traverse)+import Data.Tuple (swap)+import qualified Data.Vector as V+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Text.Regex.PCRE as PCRE+import Text.Regex.PCRE.String (Regex)++import Data.Aeson.Schema.Choice+import Data.Aeson.Schema.Helpers+import Data.Aeson.Schema.Types+import Data.Aeson.Schema.Validator+import Data.Aeson.TH.Lift ()++-- | A top-level declaration.+data Declaration = Declaration Dec (Maybe Text) -- ^ Optional textual declaration. This can be used for information (e.g. inline comments) that are not representable in TH.+ | Comment Text -- ^ Comment text+ deriving (Show, Eq, Typeable, Data)++-- | Haskell code (without module declaration and imports)+type Code = [Declaration]++type StringSet = HS.HashSet String+type SchemaTypes = M.Map Text Name++-- Code generation monad: Keeps a set of used names, writes out the code and+-- has a readonly map from schema identifiers to the names of the corresponding+-- types in the generated code.+newtype CodeGenM a = CodeGenM+ { unCodeGenM :: RWST SchemaTypes Code StringSet Q a+ } deriving (Monad, Applicative, Functor, MonadReader SchemaTypes, MonadWriter Code, MonadState StringSet)++-- | Generates a fresh name+codeGenNewName :: String -> StringSet -> (Name, StringSet)+codeGenNewName s used = (Name (mkOccName free) NameS, HS.insert free used)+ where+ free = head $ dropWhile (`HS.member` used) $ (if validName s then (s:) else id) $ map (\i -> s ++ "_" ++ show i) ([1..] :: [Int])+ -- taken from http://www.haskell.org/haskellwiki/Keywords+ haskellKeywords = HS.fromList+ [ "as", "case", "of", "class", "data", "data family", "data instance"+ , "default", "deriving", "deriving instance", "do", "forall", "foreign"+ , "hiding", "if", "then", "else", "import", "infix", "infixl", "infixr"+ , "instance", "let", "in", "mdo", "module", "newtype", "proc"+ , "qualified", "rec", "type", "type family", "type instance", "where"+ ]+ validName n = not (n `elem` ["", "_"] || n `HS.member` haskellKeywords)++instance Quasi CodeGenM where+ qNewName = state . codeGenNewName+ qReport b = CodeGenM . MT.lift . report b+ qRecover (CodeGenM handler) (CodeGenM action) = do+ graph <- ask+ currState <- get+ (a, s, w) <- CodeGenM $ MT.lift $ (recover `on` \m -> runRWST m graph currState) handler action+ put s+ tell w+ return a+ qLookupName b = CodeGenM . MT.lift . (if b then lookupTypeName else lookupValueName)+ qReify = CodeGenM . MT.lift . reify+ qReifyInstances name = CodeGenM . MT.lift . reifyInstances name+ qLocation = CodeGenM . MT.lift $ location+ qRunIO = CodeGenM . MT.lift . runIO+ qAddDependentFile = CodeGenM . MT.lift . addDependentFile++instance (Lift k, Lift v) => Lift (M.Map k v) where+ lift m = [| M.fromList $(lift $ M.toList m) |]++-- | Needed modules that are not found by "getUsedModules".+extraModules :: [String]+extraModules =+ [ "Text.Regex" -- provides RegexMaker instances+ , "Text.Regex.PCRE.String" -- provides RegexLike instances, Regex type+ , "Data.Aeson.Types" -- Parser type+ , "Data.Ratio"+ ]++-- | Extracts all TH declarations+getDecs :: Code -> [Dec]+getDecs code = [ dec | Declaration dec _ <- code ]++-- | Generate data-types and FromJSON instances for all schemas+generateTH :: Graph Schema Text -- ^ Set of schemas+ -> Q ([Dec], M.Map Text Name) -- ^ Generated code and mapping from schema identifiers to type names+generateTH = fmap (first getDecs) . generate++-- | Generated a self-contained module that parses and validates values of+-- a set of given schemas.+generateModule :: Text -- ^ Name of the generated module+ -> Graph Schema Text -- ^ Set of schemas+ -> Q (Text, M.Map Text Name) -- ^ Module code and mapping from schema identifiers to type names+generateModule modName = fmap (first $ renderCode . map rewrite) . generate+ where+ renderCode :: Code -> Text+ renderCode code = T.unlines $ [modDec] ++ imprts ++ map renderDeclaration code+ where+ mods = sort $ extraModules ++ getUsedModules (getDecs code)+ imprts = map (\m -> "import " <> pack m) mods+ modDec = "module " <> modName <> " where"+ rewrite :: Declaration -> Declaration+ rewrite (Declaration dec text) = Declaration (replaceHiddenModules $ cleanPatterns dec) text+ rewrite a = a+ renderDeclaration :: Declaration -> Text+ renderDeclaration (Declaration _ (Just text)) = text+ renderDeclaration (Declaration dec Nothing) = pack (pprint dec)+ renderDeclaration (Comment comment) = T.unlines $ map (\line -> "-- " <> line) $ T.lines comment++-- | Generate a generalized representation of the code in a Haskell module+generate :: Graph Schema Text -> Q (Code, M.Map Text Name)+generate graph = swap <$> evalRWST (unCodeGenM $ generateTopLevel graph >> return typeMap) typeMap used+ where+ (used, typeMap) = second M.fromList $ mapAccumL nameAccum HS.empty (M.keys graph)+ nameAccum usedNames schemaName = second (schemaName,) $ swap $ codeGenNewName (firstUpper $ unpack schemaName) usedNames++generateTopLevel :: Graph Schema Text -> CodeGenM ()+generateTopLevel graph = do+ typeMap <- ask+ graphN <- qNewName "graph"+ when (nameBase graphN /= "graph") $ fail "name graph is already taken"+ graphDecType <- runQ $ sigD graphN [t| Graph Schema Text |]+ graphDec <- runQ $ valD (varP graphN) (normalB $ lift graph) []+ tell [Declaration graphDecType Nothing, Declaration graphDec Nothing]+ forM_ (M.toList graph) $ \(name, schema) -> do+ let typeName = typeMap M.! name+ ((typeQ, exprQ), defNewtype) <- generateSchema (Just typeName) name schema+ when defNewtype $ do+ let newtypeCon = normalC typeName [strictType notStrict typeQ]+ newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon []+ fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` conT typeName)+ [ valD (varP $ mkName "parseJSON") (normalB [| fmap $(conE typeName) . $exprQ |]) []+ ]+ tell [Declaration newtypeDec Nothing, Declaration fromJSONInst Nothing]++generateSchema :: Maybe Name -- ^ Name to be used by type declarations+ -> Text -- ^ Describes the position in the schema+ -> Schema Text+ -> CodeGenM ((TypeQ, ExpQ), Bool) -- ^ ((type of the generated representation (a), function :: Value -> Parser a), whether a newtype wrapper is necessary)+generateSchema decName name schema = case schemaDRef schema of+ Just ref -> ask >>= \typesMap -> case M.lookup ref typesMap of+ Nothing -> fail "couldn't find referenced schema"+ Just referencedSchema -> return ((conT referencedSchema, [| parseJSON |]), True)+ Nothing -> first (second wrap) <$> case schemaType schema of+ [] -> fail "empty type"+ [Choice1of2 typ] -> generateSimpleType decName name typ+ [Choice2of2 sch] -> generateSchema decName name sch+ unionType -> do+ let l = pack . show $ length unionType+ let names = map (\i -> name <> "Choice" <> pack (show i) <> "of" <> l) ([1..] :: [Int])+ subs <- fmap (map fst) $ zipWithM (choice2 (flip $ generateSimpleType Nothing) (flip $ generateSchema Nothing)) unionType names+ (,True) <$> generateUnionType subs+ where+ generateSimpleType :: Maybe Name -> Text -> SchemaType -> CodeGenM ((TypeQ, ExpQ), Bool)+ generateSimpleType decName' name' typ = case typ of+ StringType -> (,True) <$> generateString schema+ NumberType -> (,True) <$> generateNumber schema+ IntegerType -> (,True) <$> generateInteger schema+ BooleanType -> (,True) <$> generateBoolean+ ObjectType -> case checkers of+ [] -> (,False) <$> generateObject decName' name' schema+ _ -> (,True) <$> generateObject Nothing name' schema+ ArrayType -> (,True) <$> generateArray name' schema+ NullType -> (,True) <$> generateNull+ AnyType -> (,True) <$> generateAny schema+ generateUnionType :: [(TypeQ, ExpQ)] -> CodeGenM (TypeQ, ExpQ)+ generateUnionType union = return (typ, lamE [varP val] code)+ where+ n = length union+ unionParsers = zipWith (\i parser -> [| $(choiceConE i n) <$> $parser $(varE val) |]) [1..] (map snd union)+ choiceConE :: Int -> Int -> ExpQ+ choiceConE i j = conE $ mkName $ "Data.Aeson.Schema.Choice.Choice" ++ show i ++ "of" ++ show j+ choiceT i = conT $ mkName $ "Data.Aeson.Schema.Choice.Choice" ++ show i+ typ = foldl appT (choiceT n) $ map fst union+ code = foldr (\choiceParser unionParser -> [| $choiceParser <|> $unionParser |]) [| fail "no type in union" |] unionParsers+ val = mkName "val"+ checkEnum xs = assertStmt [| $(varE val) `elem` xs |] "not one of the values in enum"+ 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 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 pat err = caseE (varE val)+ [ match pat (normalB [| fail err |])[]+ , match wildP (normalB [| return () |]) []+ ]+ disallowSchema sch =+ [| case validate $(varE $ mkName "graph") $(lift sch) $(varE val) of+ [] -> fail "disallowed"+ _ -> return ()+ |]+ checkExtends exts = noBindS $ doE $ flip map exts $ noBindS . \sch ->+ [| case validate $(varE $ mkName "graph") $(lift sch) $(varE val) of+ [] -> return ()+ es -> fail $ unlines es+ |]+ checkers = catMaybes+ [ checkEnum <$> schemaEnum schema+ , if null (schemaDisallow schema) then Nothing else Just (checkDisallow $ schemaDisallow schema)+ , if null (schemaExtends schema) then Nothing else Just (checkExtends $ schemaExtends schema)+ ]+ wrap parser = if null checkers+ then parser+ else lamE [varP val] $ doE $ checkers ++ [noBindS $ parser `appE` varE val]++assertStmt :: ExpQ -> String -> StmtQ+assertStmt expr err = noBindS [| unless $(expr) (fail err) |]++lambdaPattern :: PatQ -> ExpQ -> ExpQ -> ExpQ+lambdaPattern pat body err = lamE [varP val] $ caseE (varE val)+ [ match pat (normalB body) []+ , match wildP (normalB err) []+ ]+ where val = mkName "val"++generateString :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateString schema = return (conT ''Text, code)+ where+ str = mkName "str"+ checkMinLength l = assertStmt [| T.length $(varE str) >= l |] $ "string must have at least " ++ show l ++ " characters"+ checkMaxLength l = assertStmt [| T.length $(varE str) <= l |] $ "string must have at most " ++ show l ++ " characters"+ checkPattern (Pattern p _) = noBindS $ doE+ [ bindS (varP $ mkName "regex") [| PCRE.makeRegexM $(lift (T.unpack p)) |]+ , assertStmt [| PCRE.match ($(varE $ mkName "regex") :: Regex) (unpack $(varE str)) |] $ "string must match pattern " ++ show p+ ]+ checkFormat format = noBindS [| maybe (return ()) fail (validateFormat $(lift format) $(varE str)) |]+ checkers = catMaybes+ [ if schemaMinLength schema > 0 then Just (checkMinLength $ schemaMinLength schema) else Nothing+ , checkMaxLength <$> schemaMaxLength schema+ , checkPattern <$> schemaPattern schema+ , checkFormat <$> schemaFormat schema+ ]+ code = lambdaPattern (conP 'String [varP str])+ (doE $ checkers ++ [noBindS [| return $(varE str) |]])+ [| fail "not a string" |]++generateNumber :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateNumber schema = return (conT ''Number, code)+ where+ num = mkName "num"+ code = lambdaPattern (conP 'Number [varP num])+ (doE $ numberCheckers num schema ++ [noBindS [| return $(varE num) |]])+ [| fail "not a number" |]++generateInteger :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateInteger schema = return (conT ''Integer, code)+ where+ num = mkName "num"+ code = lambdaPattern (conP 'Number [asP num $ conP 'I [varP $ mkName "i"]])+ (doE $ numberCheckers num schema ++ [noBindS [| return $(varE $ mkName "i") |]])+ [| fail "not an integer" |]++numberCheckers :: Name -> Schema Text -> [StmtQ]+numberCheckers num schema = catMaybes+ [ checkMinimum (schemaExclusiveMinimum schema) <$> schemaMinimum schema+ , checkMaximum (schemaExclusiveMaximum schema) <$> schemaMaximum schema+ , checkDivisibleBy <$> schemaDivisibleBy schema+ ]+ where+ checkMinimum, checkMaximum :: Bool -> Number -> 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+ checkMaximum excl m = if excl+ then assertStmt [| $(varE num) < m |] $ "number must be less than " ++ show m+ else assertStmt [| $(varE num) <= m |] $ "number must be less than or equal " ++ show m+ checkDivisibleBy devisor = assertStmt [| $(varE num) `isDivisibleBy` devisor |] $ "number must be devisible by " ++ show devisor++generateBoolean :: CodeGenM (TypeQ, ExpQ)+generateBoolean = return (conT ''Bool, varE 'parseJSON)++generateNull :: CodeGenM (TypeQ, ExpQ)+generateNull = return (tupleT 0, code)+ where+ code = lambdaPattern (conP 'Null [])+ [| return () |]+ [| fail "not null" |]++cleanName :: String -> String+cleanName str = charFirst+ where+ isAllowed c = isAlphaNum c || c `elem` "'_"+ cleaned = filter isAllowed str+ charFirst = case cleaned of+ (chr:_) | not (isLetter chr || chr == '_') -> '_':cleaned+ _ -> cleaned+firstUpper, firstLower :: String -> String+firstUpper "" = ""+firstUpper (c:cs) = toUpper c : cs+firstLower "" = ""+firstLower (c:cs) = toLower c : cs++generateObject :: Maybe Name -- ^ Name to be used by data declaration+ -> Text+ -> Schema Text+ -> CodeGenM (TypeQ, ExpQ)+generateObject decName name schema = do+ let propertiesList = HM.toList $ schemaProperties schema+ (propertyNames, propertyTypes, propertyParsers, defaultParsers) <- fmap unzip4 $ forM propertiesList $ \(fieldName, propertySchema) -> do+ let cleanedFieldName = cleanName $ unpack fieldName+ propertyName <- qNewName $ firstLower cleanedFieldName+ ((typ, expr), _) <- generateSchema Nothing (name <> pack (firstUpper cleanedFieldName)) propertySchema+ let lookupProperty = [| HM.lookup $(lift fieldName) $(varE obj) |]+ case schemaDefault propertySchema of+ Just defaultValue -> do+ defaultName <- qNewName $ "default" <> firstUpper cleanedFieldName+ return (propertyName, typ, [| maybe (return $(varE defaultName)) $expr $lookupProperty |], Just $ valD (conP 'Success [varP defaultName]) (normalB [| parse $expr $(lift defaultValue) |]) [])+ Nothing -> return $ if schemaRequired propertySchema+ then (propertyName, typ, [| maybe (fail $(lift $ "required property " ++ unpack fieldName ++ " missing")) $expr $lookupProperty |], Nothing)+ else (propertyName, conT ''Maybe `appT` typ, [| traverse $expr $lookupProperty |], Nothing)+ conName <- maybe (qNewName $ firstUpper $ unpack name) return decName+ let typ = conT conName+ let dataCon = recC conName $ zipWith (\pname ptyp -> (pname,NotStrict,) <$> ptyp) propertyNames propertyTypes+ dataDec <- runQ $ dataD (cxt []) conName [] [dataCon] []+ let parser = foldl (\oparser propertyParser -> [| $oparser <*> $propertyParser |]) [| pure $(conE conName) |] propertyParsers+ fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` typ)+ [ funD (mkName "parseJSON") -- cannot use a qualified name here+ [ clause [conP 'Object [varP obj]] (normalB $ doE $ checkers ++ [noBindS parser]) (catMaybes defaultParsers)+ , clause [wildP] (normalB [| fail "not an object" |]) []+ ]+ ]+ tell [Declaration dataDec Nothing, Declaration fromJSONInst Nothing]+ return (typ, [| parseJSON |])+ where+ obj = mkName "obj"+ checkDependencies deps = noBindS+ [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, _) -> case HM.lookup pname $(lift deps) of+ Nothing -> return ()+ Just (Choice1of2 props) -> forM_ props $ \prop -> when (isNothing (HM.lookup prop $(varE obj))) $+ fail $ unpack pname ++ " requires property " ++ unpack prop+ Just (Choice2of2 depSchema) -> case validate $(varE $ mkName "graph") depSchema (Object $(varE obj)) of+ [] -> return ()+ es -> fail $ unlines es+ |]+ checkAdditionalProperties _ (Choice1of2 True) = [| return () |]+ checkAdditionalProperties _ (Choice1of2 False) = [| fail "additional properties are not allowed" |]+ checkAdditionalProperties value (Choice2of2 sch) =+ [| case validate $(varE $ mkName "graph") $(lift sch) $(value) of+ [] -> return ()+ es -> fail $ unlines es+ |]+ checkPatternAndAdditionalProperties patterns additional = noBindS+ [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, value) -> do+ let matchingPatterns = filter (flip PCRE.match (unpack pname) . patternCompiled . fst) $(lift patterns)+ forM_ matchingPatterns $ \(_, sch) -> case validate $(varE $ mkName "graph") sch value of+ [] -> return ()+ es -> fail $ unlines es+ let isAdditionalProperty = null matchingPatterns && pname `notElem` $(lift $ map fst $ HM.toList $ schemaProperties schema)+ when isAdditionalProperty $(checkAdditionalProperties [| value |] additional)+ |]+ additionalPropertiesAllowed (Choice1of2 True) = True+ additionalPropertiesAllowed _ = False+ checkers = catMaybes+ [ if HM.null (schemaDependencies schema) then Nothing else Just (checkDependencies $ schemaDependencies schema)+ , if null (schemaPatternProperties schema) && additionalPropertiesAllowed (schemaAdditionalProperties schema)+ then Nothing+ else Just (checkPatternAndAdditionalProperties (schemaPatternProperties schema) (schemaAdditionalProperties schema))+ ]++generateArray :: Text -> Schema Text -> CodeGenM (TypeQ, ExpQ)+generateArray name schema = case schemaItems schema of+ Nothing -> monomorphicArray (conT ''Value) (varE 'parseJSON)+ Just (Choice1of2 itemsSchema) -> do+ ((itemType, itemCode), _) <- generateSchema Nothing (name <> "Item") itemsSchema+ monomorphicArray itemType itemCode+ Just (Choice2of2 itemSchemas) -> do+ let names = map (\i -> name <> "Item" <> pack (show i)) ([0..] :: [Int])+ items <- fmap (map fst) $ zipWithM (generateSchema Nothing) names itemSchemas+ additionalItems <- case schemaAdditionalItems schema of+ Choice1of2 b -> return $ Choice1of2 b+ Choice2of2 sch -> Choice2of2 . fst <$> generateSchema Nothing (name <> "AdditionalItems") sch+ tupleArray items additionalItems+ where+ tupleArray :: [(TypeQ, ExpQ)] -> Choice2 Bool (TypeQ, ExpQ) -> CodeGenM (TypeQ, ExpQ)+ tupleArray items additionalItems = return (tupleType, code $ additionalCheckers ++ [noBindS tupleParser])+ where+ items' = flip map (zip [0..] items) $ \(i, (itemType, itemParser)) ->+ let simpleParser = [| $(itemParser) (V.unsafeIndex $(varE arr) i) |]+ in if i < schemaMinItems schema+ then (itemType, simpleParser)+ else (conT ''Maybe `appT` itemType, [| if V.length $(varE arr) > i then Just <$> $(simpleParser) else return Nothing|])+ (additionalCheckers, maybeAdditionalTypeAndParser) = case additionalItems of+ Choice1of2 b -> if b+ then ([], Nothing)+ else ([assertStmt [| V.length $(varE arr) <= $(lift $ length items') |] "no additional items allowed"], Nothing)+ Choice2of2 (additionalType, additionalParser) ->+ ( []+ , Just (listT `appT` additionalType, [| mapM $(additionalParser) (V.toList $ V.drop $(lift $ length items') $(varE arr)) |])+ )+ items'' = items' ++ maybeToList maybeAdditionalTypeAndParser+ (itemTypes, itemParsers) = unzip items''+ (tupleType, tupleParser) = case items'' of+ [(itemType, itemParser)] -> (itemType, itemParser)+ _ -> foldl (\(typ, parser) (itemType, itemParser) -> (typ `appT` itemType, [| $(parser) <*> $(itemParser) |]))+ (tupleT $ length items'', [| pure $(conE $ tupleDataName $ length items'') |])+ items''++ monomorphicArray :: TypeQ -> ExpQ -> CodeGenM (TypeQ, ExpQ)+ monomorphicArray itemType itemCode = return (listT `appT` itemType, code [noBindS [| mapM $(itemCode) (V.toList $(varE arr)) |]])++ arr = mkName "arr"+ code parser = lambdaPattern (conP ''Array [varP arr])+ (doE $ checkers ++ parser)+ [| fail "not an array" |]+ checkMinItems m = assertStmt [| V.length $(varE arr) >= m |] $ "array must have at least " ++ show m ++ " items"+ checkMaxItems m = assertStmt [| V.length $(varE arr) <= m |] $ "array must have at most " ++ show m ++ " items"+ checkUnique = assertStmt [| vectorUnique $(varE arr) |] "array items must be unique"+ checkers = catMaybes+ [ if schemaMinItems schema > 0 then Just (checkMinItems $ schemaMinItems schema) else Nothing+ , checkMaxItems <$> schemaMaxItems schema+ , if schemaUniqueItems schema then Just checkUnique else Nothing+ ]++generateAny :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateAny schema = return (conT ''Value, code)+ where+ code =+ [| \val -> case validate $(varE $ mkName "graph") $(lift schema) val of+ [] -> return val+ es -> fail $ unlines es+ |]
+ src/Data/Aeson/Schema/Helpers.hs view
@@ -0,0 +1,106 @@+module Data.Aeson.Schema.Helpers+ ( vectorUnique+ , formatValidators+ , validateFormat+ , isDivisibleBy+ , replaceHiddenModules+ , cleanPatterns+ , getUsedModules+ ) 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.Text (Text, unpack)+import qualified Data.Vector as V+import Language.Haskell.TH (Name, Pat (..), mkName, nameBase,+ nameModule)+import Text.Regex.PCRE (makeRegexM)+import Text.Regex.PCRE.String (Regex)++-- | Tests whether all items in a vector are different from each other.+vectorUnique :: (Eq a) => V.Vector a -> Bool+vectorUnique v = length (nub $ V.toList v) == V.length v++-- | List of format validators. Some validators haven't been implemented yet.+-- Those which are implemented take a Text value and return an error in case the+-- input is invalid.+formatValidators :: [(Text, Maybe (Text -> Maybe String))]+formatValidators =+ [ ("date-time", Nothing)+ , ("data", Nothing)+ , ("time", Nothing)+ , ("utc-millisec", Nothing)+ , ( "regex"+ , Just $ \str -> case makeRegexM (unpack str) :: Maybe Regex of+ Nothing -> Just $ "not a regex: " ++ show str+ Just _ -> Nothing+ )+ , ("color", Nothing) -- not going to implement this+ , ("style", Nothing) -- not going to implement this+ , ("phone", Nothing)+ , ("uri", Nothing)+ , ("email", Nothing)+ , ("ip-address", Nothing)+ , ("ipv6", Nothing)+ , ("host-name", Nothing)+ ]++-- | Validates a Text value against a format.+validateFormat :: Text -- ^ format+ -> Text -- ^ input+ -> Maybe String -- ^ message in case of an error+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)++-- | 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+-- Text is defined in Data.Text.Internal). This works when we use TH to insert+-- some code in a module but not when we use the TH code for pretty-printing.+replaceHiddenModules :: Data a+ => a -- ^ Dec or Exp+ -> a+replaceHiddenModules = everywhere $ mkT replaceModule+ where+ replacements =+ [ ("Data.HashMap.Base", "Data.HashMap.Lazy")+ , ("Data.Aeson.Types.Class", "Data.Aeson")+ , ("Data.Aeson.Types.Internal", "Data.Aeson.Types")+ , ("GHC.Integer.Type", "Prelude") -- "Could not find module `GHC.Integer.Type'; it is a hidden module in the package `integer-gmp'"+ , ("GHC.Types", "Prelude")+ , ("GHC.Real", "Prelude")+ , ("Data.Text.Internal", "Data.Text")+ ]+ replaceModule :: Name -> Name+ replaceModule n = case nameModule n of+ Just "Data.Aeson.Types.Internal" | nameBase n `elem` ["I", "D"] ->+ mkName $ "Data.Attoparsec.Number." ++ nameBase n+ Just "GHC.Tuple" -> mkName $ nameBase n+ Just m -> case lookup m replacements of+ Just r -> mkName $ r ++ ('.' : nameBase n)+ Nothing -> n+ _ -> n++-- | Workaround for a bug in Template Haskell: TH parses the empty list+-- constructor in patterns as @ConP (mkName \"Prelude.[]\") []@ instead of @ListP []@+cleanPatterns :: Data a => a -> a+cleanPatterns = everywhere $ mkT replacePattern+ where+ replacePattern (ConP n []) | nameBase n == "[]" = ListP []+ replacePattern p = p++-- | Extracts a list of used modules from a TH code tree.+getUsedModules :: Data a => a -> [String]+getUsedModules = nub . everything (++) ([] `mkQ` extractModule)+ where+ extractModule :: Name -> [String]+ extractModule = maybeToList . nameModule
+ src/Data/Aeson/Schema/Types.hs view
@@ -0,0 +1,309 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Data.Aeson.Schema.Types+ ( Pattern (..)+ , mkPattern+ , SchemaType (..)+ , Schema (..)+ , Graph+ , empty+ , schemaQQ+ ) where++import Control.Applicative ((<*>), (*>), (<*))+import Control.Arrow (second)+import Control.Monad (liftM)+import Data.Aeson (FromJSON (..), Value (..), (.!=),+ (.:?))+import Data.Aeson.Parser (value')+import Data.Aeson.Schema.Choice+import Data.Aeson.Types (Parser, emptyArray, emptyObject,+ parseEither)+import Data.Attoparsec.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)+import Data.Functor ((<$>))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import qualified Data.Map as M+import Data.Maybe (catMaybes)+import Data.Text (Text, unpack)+import Data.Traversable (traverse)+import qualified Data.Vector as V+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH (varE, recUpdE)+import Language.Haskell.TH.Syntax (Lift (..))+import Prelude hiding (foldr, length)+import Text.Regex.PCRE (makeRegexM)+import Text.Regex.PCRE.String (Regex)+import Data.Aeson.TH.Lift ()++-- | Compiled regex and its source+data Pattern = Pattern { patternSource :: Text, patternCompiled :: Regex }++instance Eq Pattern where+ (==) = (==) `on` patternSource++instance Show Pattern where+ show pattern = "let Right p = mkPattern (" ++ show (patternSource pattern) ++ ") in p"++instance FromJSON Pattern where+ parseJSON (String s) = mkPattern s+ parseJSON _ = fail "only strings can be parsed as patterns"++instance Lift Pattern where+ lift (Pattern src _) = [| let Right p = mkPattern src in p |]++-- | Compile a regex to a pattern, reporting errors with fail+mkPattern :: (Monad m) => Text -> m Pattern+mkPattern t = liftM (Pattern t) $ makeRegexM (unpack t)++-- | Primitive JSON types+data SchemaType = StringType+ | NumberType+ | IntegerType+ | BooleanType+ | ObjectType+ | ArrayType+ | NullType+ | AnyType -- ^ any of the above+ deriving (Eq, Ord, Enum, Bounded, Show, Read)++instance FromJSON SchemaType where+ parseJSON (String t) = case t of+ "string" -> return StringType+ "number" -> return NumberType+ "integer" -> return IntegerType+ "boolean" -> return BooleanType+ "object" -> return ObjectType+ "array" -> return ArrayType+ "null" -> return NullType+ "any" -> return AnyType+ _ -> fail $ "not a valid type: " ++ unpack t+ parseJSON _ = fail "not a string"++instance Lift SchemaType where+ lift StringType = [| StringType |]+ lift NumberType = [| NumberType |]+ lift IntegerType = [| IntegerType |]+ lift BooleanType = [| BooleanType |]+ lift ObjectType = [| ObjectType |]+ lift ArrayType = [| ArrayType |]+ lift NullType = [| NullType |]+ lift AnyType = [| AnyType |]++-- | JSON Schema (Draft 3) Core Schema Definition+data Schema ref = Schema+ { schemaType :: [Choice2 SchemaType (Schema ref)] -- ^ List of allowed schema types+ , schemaProperties :: HashMap Text (Schema ref) -- ^ Subschemas for properties+ , schemaPatternProperties :: [(Pattern, Schema ref)] -- ^ All properties that match one of the regexes must validate against the associated schema+ , schemaAdditionalProperties :: Choice2 Bool (Schema ref) -- ^ Whether additional properties are allowed when the instance is an object, and if so, a schema that they have to validate against+ , schemaItems :: Maybe (Choice2 (Schema ref) [Schema ref]) -- ^ Either a schema for all array items or a different schema for each position in the array+ , 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+ , 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+ , schemaMaxItems :: Maybe Int -- ^ Maximum length for arrays+ , schemaUniqueItems :: Bool -- ^ Whether all array items must be distinct from each other+ , schemaPattern :: Maybe Pattern -- ^ Regex for validating strings+ , schemaMinLength :: Int -- ^ Minimum length for strings+ , schemaMaxLength :: Maybe Int -- ^ Maximum length for strings+ , schemaEnum :: Maybe [Value] -- ^ Allowed values for this schema+ , schemaEnumDescriptions :: Maybe [Text] -- ^ Extension by Google: description for the values in schemaEnum+ , schemaDefault :: Maybe Value -- ^ Default value if this schema is used in a property of another schema and the value is undefined+ , 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+ , 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+ , schemaDRef :: Maybe ref -- ^ $ref: reference to another schema+ , schemaDSchema :: Maybe Text -- ^ $schema: URI of a schema that defines the format of the current schema+ } deriving (Eq, Show)++-- | Set of potentially mutually recursive schemas+type Graph f ref = M.Map ref (f ref)++instance Functor Schema where+ fmap f s = s+ { schemaType = mapChoice2 id (fmap f) <$> schemaType s+ , schemaProperties = fmap f <$> schemaProperties s+ , schemaPatternProperties = second (fmap f) <$> schemaPatternProperties s+ , schemaAdditionalProperties = mapChoice2 id (fmap f) (schemaAdditionalProperties s)+ , schemaItems = mapChoice2 (fmap f) (fmap $ fmap f) <$> schemaItems s+ , schemaAdditionalItems = mapChoice2 id (fmap f) (schemaAdditionalItems s)+ , schemaDependencies = mapChoice2 id (fmap f) <$> schemaDependencies s+ , schemaDisallow = mapChoice2 id (fmap f) <$> schemaDisallow s+ , schemaExtends = fmap f <$> schemaExtends s+ , schemaDRef = f <$> schemaDRef s+ }++instance Foldable Schema where+ foldr f start s = ffoldr (ffoldr f) (choice2of2s $ schemaType s)+ . ffoldr (ffoldr f) (schemaProperties s)+ . ffoldr (ffoldr f) (map snd $ schemaPatternProperties s)+ . foldChoice2of2 (ffoldr f) (schemaAdditionalProperties s)+ . ffoldr (\items -> foldChoice1of2 (ffoldr f) items . foldChoice2of2 (ffoldr $ ffoldr f) items) (schemaItems s)+ . foldChoice2of2 (ffoldr f) (schemaAdditionalItems s)+ . ffoldr (ffoldr f) (choice2of2s $ toList $ schemaDependencies s)+ . ffoldr (ffoldr f) (choice2of2s $ schemaDisallow s)+ . ffoldr (ffoldr f) (schemaExtends s)+ . ffoldr f (schemaDRef s)+ $ start+ where+ ffoldr :: (Foldable t) => (a -> b -> b) -> t a -> b -> b+ ffoldr g = flip $ foldr g+ foldChoice1of2 :: (a -> b -> b) -> Choice2 a x -> b -> b+ foldChoice1of2 g (Choice1of2 c) = g c+ foldChoice1of2 _ _ = id+ foldChoice2of2 :: (a -> b -> b) -> Choice2 x a -> b -> b+ foldChoice2of2 g (Choice2of2 c) = g c+ foldChoice2of2 _ _ = id++instance FromJSON ref => FromJSON (Schema ref) where+ parseJSON (Object o) = Schema+ <$> (parseSingleOrArray =<< parseFieldDefault "type" "any")+ <*> parseFieldDefault "properties" emptyObject+ <*> (parseFieldDefault "patternProperties" emptyObject >>= mapM (\(k, v) -> fmap (,v) (mkPattern k)) . H.toList)+ <*> (parseField "additionalProperties" .!= Choice1of2 True)+ <*> parseField "items"+ <*> (parseField "additionalItems" .!= Choice1of2 True)+ <*> parseFieldDefault "required" (Bool False)+ <*> (traverse parseDependency =<< parseFieldDefault "dependencies" emptyObject)+ <*> parseField "minimum"+ <*> parseField "maximum"+ <*> parseFieldDefault "exclusiveMinimum" (Bool False)+ <*> parseFieldDefault "exclusiveMaximum" (Bool False)+ <*> parseFieldDefault "minItems" (Number 0)+ <*> parseField "maxItems"+ <*> parseFieldDefault "uniqueItems" (Bool False)+ <*> parseField "pattern"+ <*> parseFieldDefault "minLength" (Number 0)+ <*> parseField "maxLength"+ <*> parseField "enum"+ <*> parseField "enumDescriptions"+ <*> parseField "default"+ <*> parseField "title"+ <*> parseField "description"+ <*> parseField "format"+ <*> parseField "divisibleBy"+ <*> (parseSingleOrArray =<< parseFieldDefault "disallow" emptyArray)+ <*> ((maybe (return Nothing) (fmap Just . parseSingleOrArray) =<< parseField "extends") .!= [])+ <*> parseField "id"+ <*> parseField "$ref"+ <*> parseField "$schema"+ where+ parseField :: (FromJSON a) => Text -> Parser (Maybe a)+ parseField name = o .:? name++ parseFieldDefault :: (FromJSON a) => Text -> Value -> Parser a+ parseFieldDefault name value = parseJSON =<< parseField name .!= value++ singleOrArray :: (Value -> Parser a) -> Value -> Parser [a]+ singleOrArray p (Array a) = mapM p (V.toList a)+ singleOrArray p v = (:[]) <$> p v++ parseSingleOrArray :: (FromJSON a) => Value -> Parser [a]+ parseSingleOrArray = singleOrArray parseJSON++ parseDependency :: FromJSON ref => Value -> Parser (Choice2 [Text] (Schema ref))+ parseDependency (String s) = return $ Choice1of2 [s]+ parseDependency val = parseJSON val+ parseJSON _ = fail "a schema must be a JSON object"++instance (Eq ref, Lift ref) => Lift (Schema ref) where+ lift schema = case updates of+ [] -> varE 'empty+ _ -> recUpdE (varE 'empty) updates+ where+ updates = catMaybes+ [ field 'schemaType schemaType+ , field 'schemaProperties schemaProperties+ , field 'schemaPatternProperties schemaPatternProperties+ , field 'schemaAdditionalProperties schemaAdditionalProperties+ , field 'schemaItems schemaItems+ , field 'schemaAdditionalItems schemaAdditionalItems+ , field 'schemaRequired schemaRequired+ , field 'schemaDependencies schemaDependencies+ , field 'schemaMinimum schemaMinimum+ , field 'schemaMaximum schemaMaximum+ , field 'schemaExclusiveMinimum schemaExclusiveMinimum+ , field 'schemaExclusiveMaximum schemaExclusiveMaximum+ , field 'schemaMinItems schemaMinItems+ , field 'schemaMaxItems schemaMaxItems+ , field 'schemaUniqueItems schemaUniqueItems+ , field 'schemaPattern schemaPattern+ , field 'schemaMinLength schemaMinLength+ , field 'schemaMaxLength schemaMaxLength+ , field 'schemaEnum schemaEnum+ , field 'schemaEnumDescriptions schemaEnumDescriptions+ , field 'schemaDefault schemaDefault+ , field 'schemaTitle schemaTitle+ , field 'schemaDescription schemaDescription+ , field 'schemaFormat schemaFormat+ , field 'schemaDivisibleBy schemaDivisibleBy+ , field 'schemaDisallow schemaDisallow+ , field 'schemaExtends schemaExtends+ , field 'schemaId schemaId+ , fmap ('schemaDRef,) . lift . Just <$> schemaDRef schema+ , field 'schemaDSchema schemaDSchema+ ]+ field name accessor = if accessor schema == accessor empty+ then Nothing+ else Just $ (name,) <$> lift (accessor schema)++-- | The empty schema accepts any JSON value.+empty :: Schema ref+empty = Schema+ { schemaType = [Choice1of2 AnyType]+ , schemaProperties = H.empty+ , schemaPatternProperties = []+ , schemaAdditionalProperties = Choice1of2 True+ , schemaItems = Nothing+ , schemaAdditionalItems = Choice1of2 True+ , schemaRequired = False+ , schemaDependencies = H.empty+ , schemaMinimum = Nothing+ , schemaMaximum = Nothing+ , schemaExclusiveMinimum = False+ , schemaExclusiveMaximum = False+ , schemaMinItems = 0+ , schemaMaxItems = Nothing+ , schemaUniqueItems = False+ , schemaPattern = Nothing+ , schemaMinLength = 0+ , schemaMaxLength = Nothing+ , schemaEnum = Nothing+ , schemaEnumDescriptions = Nothing+ , schemaDefault = Nothing+ , schemaTitle = Nothing+ , schemaDescription = Nothing+ , schemaFormat = Nothing+ , schemaDivisibleBy = Nothing+ , schemaDisallow = []+ , schemaExtends = []+ , schemaId = Nothing+ , schemaDRef = Nothing+ , schemaDSchema = Nothing+ }++-- | QuasiQuoter for schemas in JSON (e.g. @[schemaQQ| { \"type\": \"number\", \"minimum\": 0 } |]@)+schemaQQ :: QuasiQuoter+schemaQQ = QuasiQuoter { quoteExp = quote }+ where+ quote jsonStr = case parse (skipSpace *> value' <* skipSpace) (pack jsonStr) of+ Done _ json -> case parseEither parseJSON json :: Either String (Schema Text) of+ Left e -> fail e+ Right s -> lift s+ _ -> fail "not a valid JSON value"
+ src/Data/Aeson/Schema/Validator.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RankNTypes #-}++module Data.Aeson.Schema.Validator+ ( ValidationError+ , validate+ ) where++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.Text (Text, length, unpack)+import qualified Data.Vector as V+import Prelude hiding (foldr, length)+import Text.Regex.PCRE (match)++import Data.Aeson.Schema.Types+import Data.Aeson.Schema.Choice+import Data.Aeson.Schema.Helpers++-- | Errors encountered during validation+type ValidationError = String++validationError :: ValidationError -> [ValidationError]+validationError e = [e]++valid :: [ValidationError]+valid = []++-- | Validates a JSON value against a schema.+validate :: Ord ref+ => Graph Schema ref -- ^ referenced schemas+ -> Schema ref+ -> Value+ -> [ValidationError]+validate graph schema val = case schemaDRef schema of+ Just ref -> case M.lookup ref graph of+ Nothing -> validationError "referenced schema is not in map"+ Just referencedSchema -> validate graph referencedSchema val+ Nothing -> L.concat+ [ case schemaType schema of+ [t] -> validateType t+ ts -> if L.any L.null (map validateType ts) then [] else validationError "no type matched"+ , maybeCheck checkEnum $ schemaEnum schema+ , concatMap validateTypeDisallowed (schemaDisallow schema)+ , concatMap (flip (validate graph) val) (schemaExtends schema)+ ]+ where+ 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+ (BooleanType, Bool _) -> valid+ (ObjectType, Object obj) -> validateObject graph schema obj+ (ArrayType, Array arr) -> validateArray graph schema arr+ (NullType, Null) -> valid+ (AnyType, _) -> case val of+ String str -> validateString schema str+ Number num -> validateNumber schema num+ Object obj -> validateObject graph schema obj+ Array arr -> validateArray graph schema arr+ _ -> valid+ (typ, _) -> validationError $ "type mismatch: expected " ++ show typ ++ " but got " ++ getType val+ validateType (Choice2of2 s) = validate graph s val++ getType :: A.Value -> String+ getType (String _) = "string"+ getType (Number _) = "number"+ getType (Bool _) = "boolean"+ getType (Object _) = "object"+ getType (Array _) = "array"+ getType Null = "null"++ checkEnum e = assert (val `elem` e) "value has to be one of the values in enum"++ isType :: Value -> SchemaType -> Bool+ isType (String _) StringType = True+ isType (Number (I _)) IntegerType = True+ isType (Number _) NumberType = True+ isType (Bool _) BooleanType = True+ isType (Object _) ObjectType = True+ isType (Array _) ArrayType = True+ isType _ AnyType = True+ isType _ _ = False++ validateTypeDisallowed (Choice1of2 t) = if isType val t+ then validationError $ "values of type " ++ show t ++ " are not allowed here"+ else valid+ validateTypeDisallowed (Choice2of2 s) = assert (not . L.null $ validate graph s val) "value disallowed"++assert :: Bool -> String -> [ValidationError]+assert True _ = valid+assert False e = validationError e++maybeCheck :: (a -> [ValidationError]) -> Maybe a -> [ValidationError]+maybeCheck p (Just a) = p a+maybeCheck _ _ = valid++validateString :: Schema ref -> Text -> [ValidationError]+validateString schema str = L.concat+ [ checkMinLength $ schemaMinLength schema+ , maybeCheck checkMaxLength (schemaMaxLength schema)+ , maybeCheck checkPattern $ schemaPattern schema+ , maybeCheck checkFormat $ schemaFormat schema+ ]+ where+ checkMinLength l = assert (length str >= l) $ "length of string must be at least " ++ show l+ checkMaxLength l = assert (length str <= l) $ "length of string must be at most " ++ show l+ 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 num = L.concat+ [ maybeCheck (checkMinimum $ schemaExclusiveMinimum schema) $ schemaMinimum schema+ , maybeCheck (checkMaximum $ schemaExclusiveMaximum schema) $ schemaMaximum schema+ , maybeCheck checkDivisibleBy $ schemaDivisibleBy schema+ ]+ where+ checkMinimum excl m = if excl+ then assert (num > m) $ "number must be greater than " ++ show m+ else assert (num >= m) $ "number must be greater than or equal " ++ show m+ checkMaximum excl m = if excl+ 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++validateObject :: Ord ref => Graph Schema ref -> Schema ref -> A.Object -> [ValidationError]+validateObject graph schema obj =+ concatMap (uncurry checkKeyValue) (H.toList obj) +++ concatMap checkRequiredProperty requiredProperties+ where+ checkKeyValue k v = L.concat+ [ maybeCheck (flip (validate graph) v) property+ , concatMap (flip (validate graph) v . snd) matchingPatternsProperties+ , if isNothing property && L.null matchingPatternsProperties+ then checkAdditionalProperties (schemaAdditionalProperties schema)+ else valid+ , maybeCheck checkDependencies $ H.lookup k (schemaDependencies schema)+ ]+ where+ property = H.lookup k (schemaProperties schema)+ matchingPatternsProperties = filter (flip match (unpack k) . patternCompiled . fst) $ schemaPatternProperties schema+ checkAdditionalProperties ap = case ap of+ Choice1of2 b -> assert b $ "additional property " ++ unpack k ++ " is not allowed"+ Choice2of2 s -> validate graph s v+ checkDependencies deps = case deps of+ Choice1of2 props -> L.concat $ flip map props $ \prop -> case H.lookup prop obj of+ Nothing -> validationError $ "property " ++ unpack k ++ " depends on property " ++ show prop+ Just _ -> valid+ Choice2of2 depSchema -> validate graph depSchema (Object obj)+ requiredProperties = map fst . filter (schemaRequired . snd) . H.toList $ schemaProperties schema+ checkRequiredProperty key = case H.lookup key obj of+ Nothing -> validationError $ "required property " ++ unpack key ++ " is missing"+ Just _ -> valid++validateArray :: Ord ref => Graph Schema ref -> Schema ref -> A.Array -> [ValidationError]+validateArray graph schema arr = L.concat+ [ checkMinItems $ schemaMinItems schema+ , maybeCheck checkMaxItems $ schemaMaxItems schema+ , if schemaUniqueItems schema then checkUnique else valid+ , maybeCheck checkItems $ schemaItems schema+ ]+ where+ len = V.length arr+ list = V.toList arr+ checkMinItems m = assert (len >= m) $ "array must have at least " ++ show m ++ " items"+ checkMaxItems m = assert (len <= m) $ "array must have at most " ++ show m ++ " items"+ checkUnique = assert (vectorUnique arr) "all array items must be unique"+ checkItems items = case items of+ Choice1of2 s -> assert (V.all (L.null . validate graph s) arr) "all items in the array must validate against the schema given in 'items'"+ Choice2of2 ss ->+ let additionalItems = drop (L.length ss) list+ checkAdditionalItems ai = case ai of+ Choice1of2 b -> assert (b || L.null additionalItems) "no additional items allowed"+ Choice2of2 additionalSchema -> concatMap (validate graph additionalSchema) additionalItems+ in L.concat (zipWith (validate graph) ss list) +++ checkAdditionalItems (schemaAdditionalItems schema)+
+ src/Data/Aeson/TH/Lift.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Aeson.TH.Lift () where++import Data.Aeson (Value (..))+import Data.Attoparsec.Number (Number (..))+import qualified Data.HashMap.Lazy as HM+import Data.Text (Text, pack, unpack)+import qualified Data.Vector as V+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift (..))++instance Lift Text where+ lift txt = [| pack $(lift (unpack txt)) |]++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 Value where+ lift (Object o) = [| Object o |]+ lift (Array a) = [| Array a |]+ lift (String t) = [| String t |]+ lift (Number n) = [| Number n |]+ lift (Bool b) = [| Bool b |]+ lift Null = [| Null |]
+ test/TestSuite.hs view
@@ -0,0 +1,14 @@+import Test.Framework++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++main :: IO ()+main = defaultMain+ [ testGroup "Data.Aeson.Schema.Types" Data.Aeson.Schema.Types.Tests.tests+ , testGroup "Data.Aeson.Schema.Validator" Data.Aeson.Schema.Validator.Tests.tests+ , buildTest $ fmap (testGroup "Data.Aeson.Schema.CodeGen") Data.Aeson.Schema.CodeGen.Tests.tests+ , testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests+ ]