diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Shohei Murayama + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Shohei Murayama nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jsonschema-gen.cabal b/jsonschema-gen.cabal new file mode 100644 --- /dev/null +++ b/jsonschema-gen.cabal @@ -0,0 +1,68 @@ +name: jsonschema-gen +version: 0.1.0.0 +synopsis: JSON Schema generator from Algebraic data type +description: This library contains a JSON Scheam generator. +homepage: https://github.com/yuga/jsonschema-gen +license: BSD3 +license-file: LICENSE +author: Shohei Murayama +maintainer: shohei.murayama@gmail.com +copyright: (c) 2015 Shohei Murayama +category: Text, Data, JSON +build-type: Simple +cabal-version: >=1.10 +-- extra-source-files: + +flag safe-aeson + description: To avoid the issue of prior to aeson-0.7.0.6, set this flag True. + default: False + +library + exposed-modules: Data.JSON.Schema.Generator + Data.JSON.Schema.Generator.Class + Data.JSON.Schema.Generator.Convert + Data.JSON.Schema.Generator.Generic + Data.JSON.Schema.Generator.Types + + build-depends: base >=4.6 && <4.9 + , bytestring + , containers + , tagged + , text + , time + , unordered-containers + , vector + + if flag(safe-aeson) + build-depends: + aeson >=0.7.0.6 + , scientific >=0.3.2.0 + else + build-depends: + aeson + , scientific + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/yuga/jsonschema-gen + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Types + build-depends: base >=4.6 && <4.9 + , aeson + , bytestring + , containers + , jsonschema-gen + , process + , tagged + , text + , transformers + hs-source-dirs: tests + default-language: Haskell2010 + diff --git a/src/Data/JSON/Schema/Generator.hs b/src/Data/JSON/Schema/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema/Generator.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module: Data.JSON.Schema.Generator +-- Copyright: (c) 2015 Shohei Murayama +-- License: BSD3 +-- Maintainer: Shohei Murayama +-- Stability: experimental +-- +-- A generator for JSON Schemas from ADT. +-- +module Data.JSON.Schema.Generator + ( + -- * How to use this library + -- $use + + -- * Genenerating JSON Schema + Options(..), PropType(..), defaultOptions + , generate, generate' + + -- * Type conversion + , JSONSchemaGen(toSchema) + , JSONSchemaPrim(toSchemaPrim) + , convert + + -- * Generic Schema class + , GJSONSchemaGen(gToSchema) + , genericToSchema + ) where + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.JSON.Schema.Generator.Class (JSONSchemaGen(toSchema), JSONSchemaPrim(toSchemaPrim) + , GJSONSchemaGen(gToSchema), Options(..), PropType(..), defaultOptions, genericToSchema) +import Data.JSON.Schema.Generator.Convert (convert) +import Data.JSON.Schema.Generator.Generic () +import Data.Proxy (Proxy) + +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A + +-- | Generate a JSON Schema from a proxy value of a type. +-- This uses the default options to generate schema in json format. +-- +generate :: JSONSchemaGen a + => Proxy a -- ^ A proxy value of the type from which a schema will be generated. + -> ByteString +generate = A.encode . convert A.defaultOptions . toSchema defaultOptions + +-- | Generate a JSON Schema from a proxy vaulue of a type. +-- This uses the specified options to generate schema in json format. +-- +generate' :: JSONSchemaGen a + => Options -- ^ Schema generation 'Options'. + -> A.Options -- ^ Encoding 'A.Options' of aeson. + -> Proxy a -- ^ A proxy value of the type from which a schema will be generated. + -> ByteString +generate' opts aopts = A.encode . convert aopts . toSchema opts + +-- $use +-- Example: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import qualified Data.ByteString.Lazy.Char8 as BL +-- > import Data.JSON.Schema.Generator +-- > import Data.Proxy +-- > import GHC.Generics +-- > +-- > data User = User +-- > { name :: String +-- > , age :: Int +-- > , email :: Maybe String +-- > } deriving Generic +-- > +-- > instance JSONSchemaGen User +-- > +-- > main :: IO () +-- > main = BL.putStrLn $ generate (Proxy :: Proxy User) +-- +-- Let's run the above script, we can get on stdout (the following json is formatted with jq): +-- +-- @ +-- { +-- \"required\": [ +-- \"name\", +-- \"age\", +-- \"email\" +-- ], +-- \"$schema\": \"http://json-schema.org\/draft-04\/schema#\", +-- \"id\": \"Main.User\", +-- \"title\": \"Main.User\", +-- \"type\": \"object\", +-- \"properties\": { +-- \"email\": { +-- \"type\": [ +-- \"string\", +-- \"null\" +-- ] +-- }, +-- \"age\": { +-- \"type\": \"integer\" +-- }, +-- \"name\": { +-- \"type\": \"string\" +-- } +-- } +-- } +-- @ + diff --git a/src/Data/JSON/Schema/Generator/Class.hs b/src/Data/JSON/Schema/Generator/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema/Generator/Class.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.JSON.Schema.Generator.Class where + +import Data.JSON.Schema.Generator.Types (Schema) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy (Proxy) +import Data.Typeable (TypeRep) +import GHC.Generics (Generic(from), Rep) + +-------------------------------------------------------------------------------- + +class JSONSchemaGen a where + toSchema :: Options -> Proxy a -> Schema + + default toSchema :: (Generic a, GJSONSchemaGen (Rep a)) => Options -> Proxy a -> Schema + toSchema = genericToSchema + +class JSONSchemaPrim a where + toSchemaPrim :: Options -> Proxy a -> Schema + +-------------------------------------------------------------------------------- + +class GJSONSchemaGen f where + gToSchema :: Options -> Proxy (f a) -> Schema + +genericToSchema :: (Generic a, GJSONSchemaGen (Rep a)) => Options -> Proxy a -> Schema +genericToSchema opts = gToSchema opts . fmap from + +-------------------------------------------------------------------------------- + +-- | Options that specify how to generate schema definition automatically +-- from your datatype. +-- +data Options = Options + { baseUri :: String -- ^ shcema id prefix. + , schemaIdSuffix :: String -- ^ schema id suffix. File extension for example. + , typeRefMap :: Map TypeRep String -- ^ a mapping from datatypes to referenced schema ids. + , fieldTypeMap :: Map String PropType -- ^ a mapping to assign a preffered type to a field. + } + +data PropType = forall a. (JSONSchemaPrim a) => PropType (Proxy a) + +instance Show Options where + showsPrec p opts = + showParen (p > 10) + $ showString "Options { baseUri = " + . showsPrec 11 (baseUri opts) + . showString ", schemaIdSuffix = " + . showsPrec 11 (schemaIdSuffix opts) + . showString ", typeRefMap = " + . showsPrec 11 (typeRefMap opts) + . showString ", fieldTypeMap = {..} }" + +-- | Default geerating 'Options': +-- +-- @ +-- 'Options' +-- { 'baseUri' = "" +-- , 'schemaIdSuffix' = "" +-- , 'refSchemaMap' = Map.empty +-- } +-- @ +-- +defaultOptions :: Options +defaultOptions = Options + { baseUri = "" + , schemaIdSuffix = "" + , typeRefMap = Map.empty + , fieldTypeMap = Map.empty + } + diff --git a/src/Data/JSON/Schema/Generator/Convert.hs b/src/Data/JSON/Schema/Generator/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema/Generator/Convert.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.JSON.Schema.Generator.Convert + ( convert + ) where + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative ((<*>)) +import Data.Monoid (mappend) +#endif + +import Data.JSON.Schema.Generator.Types (Schema(..), SchemaChoice(..)) +import Data.Text (Text, pack) + +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector + +-------------------------------------------------------------------------------- + +convert :: A.Options -> Schema -> A.Value +convert = convert' False + +convert' :: Bool -> A.Options -> Schema -> A.Value +convert' = (((A.Object . HashMap.fromList) .) .) . convertToList + +convertToList :: Bool -> A.Options -> Schema -> [(Text,A.Value)] +convertToList inArray opts s = foldr1 (++) $ + [ jsId + , jsSchema + , jsSchemaType opts + , jsTitle + , jsDescription + , jsReference + , jsType inArray opts + , jsFormat + , jsLowerBound + , jsUpperBound + , jsValue + , jsItems opts + , jsProperties opts + , jsPatternProps opts + , jsOneOf opts + , jsRequired opts + , jsDefinitions opts + ] <*> [s] + +-------------------------------------------------------------------------------- + +jsId :: Schema -> [(Text,A.Value)] +jsId (SCSchema {scId = i}) = [("id", string i)] +jsId _ = [] + +jsSchema :: Schema -> [(Text,A.Value)] +jsSchema SCSchema {scUsedSchema = s} = [("$schema", string s)] +jsSchema _ = [] + +jsSchemaType :: A.Options -> Schema -> [(Text,A.Value)] +jsSchemaType opts SCSchema {scSchemaType = s} = convertToList False opts s +jsSchemaType _ _ = [] + +jsTitle :: Schema -> [(Text,A.Value)] +jsTitle SCConst {scTitle = "" } = [] +jsTitle SCConst {scTitle = t } = [("title", string t)] +jsTitle SCObject {scTitle = "" } = [] +jsTitle SCObject {scTitle = t } = [("title", string t)] +jsTitle SCArray {scTitle = "" } = [] +jsTitle SCArray {scTitle = t } = [("title", string t)] +jsTitle SCOneOf {scTitle = "" } = [] +jsTitle SCOneOf {scTitle = t } = [("title", string t)] +jsTitle _ = [] + +jsDescription :: Schema -> [(Text,A.Value)] +jsDescription SCString {scDescription = (Just d) } = [("description", string d)] +jsDescription SCInteger {scDescription = (Just d) } = [("description", string d)] +jsDescription SCNumber {scDescription = (Just d) } = [("description", string d)] +jsDescription SCBoolean {scDescription = (Just d) } = [("description", string d)] +jsDescription SCConst {scDescription = (Just d) } = [("description", string d)] +jsDescription SCObject {scDescription = (Just d) } = [("description", string d)] +jsDescription SCArray {scDescription = (Just d) } = [("description", string d)] +jsDescription SCOneOf {scDescription = (Just d) } = [("description", string d)] +jsDescription _ = [] + +jsReference :: Schema -> [(Text,A.Value)] +jsReference SCRef {scReference = r} = [("$ref", string r)] +jsReference _ = [] + +jsType :: Bool -> A.Options -> Schema -> [(Text,A.Value)] +jsType (needsNull -> f) (f -> True) SCString {scNullable = True } = [("type", array ["string", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCString {scNullable = _ } = [("type", string "string")] +jsType (needsNull -> f) (f -> True) SCInteger {scNullable = True } = [("type", array ["integer", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCInteger {scNullable = _ } = [("type", string "integer")] +jsType (needsNull -> f) (f -> True) SCNumber {scNullable = True } = [("type", array ["number", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCNumber {scNullable = _ } = [("type", string "number")] +jsType (needsNull -> f) (f -> True) SCBoolean {scNullable = True } = [("type", array ["boolean", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCBoolean {scNullable = _ } = [("type", string "boolean")] +jsType (needsNull -> f) (f -> True) SCObject {scNullable = True } = [("type", array ["object", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCObject {scNullable = _ } = [("type", string "object")] +jsType (needsNull -> f) (f -> True) SCArray {scNullable = True } = [("type", array ["array", "null" :: Text])] +jsType (needsNull -> f) (f -> _ ) SCArray {scNullable = _ } = [("type", string "array")] +jsType _ _ _ = [] + +needsNull :: Bool -> A.Options -> Bool +needsNull True _ = True +needsNull False opts = not (A.omitNothingFields opts) + +jsFormat :: Schema -> [(Text,A.Value)] +jsFormat SCString {scFormat = Just f} = [("format", string f)] +jsFormat _ = [] + +jsLowerBound :: Schema -> [(Text,A.Value)] +jsLowerBound SCString {scLowerBound = (Just n)} = [("minLength", number n)] +jsLowerBound SCNumber {scLowerBound = (Just n)} = [("mininum", number n)] +jsLowerBound SCArray {scLowerBound = (Just n)} = [("minItems", number n)] +jsLowerBound _ = [] + +jsUpperBound :: Schema -> [(Text,A.Value)] +jsUpperBound SCString {scUpperBound = (Just n)} = [("maxLength", number n)] +jsUpperBound SCNumber {scUpperBound = (Just n)} = [("maximum", number n)] +jsUpperBound SCArray {scUpperBound = (Just n)} = [("maxItems", number n)] +jsUpperBound _ = [] + +jsValue :: Schema -> [(Text,A.Value)] +jsValue SCConst {scValue = v} = [("enum", array [v])] +jsValue _ = [] + +jsItems :: A.Options -> Schema -> [(Text,A.Value)] +jsItems opts SCArray {scItems = items} = [("items", array . map (convert' True opts) $ items)] +jsItems _ _ = [] + +jsProperties :: A.Options -> Schema -> [(Text,A.Value)] +jsProperties opts SCObject {scProperties = p} = [("properties", object $ toMap opts p)] +jsProperties _ _ = [] + +jsPatternProps :: A.Options -> Schema -> [(Text,A.Value)] +jsPatternProps _ SCObject {scPatternProps = []} = [] +jsPatternProps opts SCObject {scPatternProps = p } = [("patternProperties", object $ toMap opts p)] +jsPatternProps _ _ = [] + +jsOneOf :: A.Options -> Schema -> [(Text,A.Value)] +jsOneOf opts SCOneOf {scChoices = cs, scNullable = nullable} = choices opts nullable cs +jsOneOf _ _ = [] + +jsRequired :: A.Options -> Schema -> [(Text,A.Value)] +jsRequired A.Options {A.omitNothingFields = True} SCObject {scRequired = r } = [("required", array r)] +jsRequired opts@(A.Options {A.omitNothingFields = _ }) SCObject {scProperties = p} = [("required", array . map fst $ toMap opts p)] +jsRequired _ _ = [] + +jsDefinitions :: A.Options -> Schema -> [(Text,A.Value)] +jsDefinitions _ SCSchema {scDefinitions = []} = [] +jsDefinitions opts SCSchema {scDefinitions = d } = [("definitions", object $ toMap opts d)] +jsDefinitions _ _ = [] + +-------------------------------------------------------------------------------- + +array :: A.ToJSON a => [a] -> A.Value +array = A.Array . Vector.fromList . map A.toJSON + +string :: Text -> A.Value +string = A.String + +number :: Integer -> A.Value +number = A.Number . fromInteger + +object :: [A.Pair] -> A.Value +object = A.object + +false :: A.Value +false = A.Bool False + +-------------------------------------------------------------------------------- + +choices :: A.Options -> Bool -> [SchemaChoice] -> [(Text,A.Value)] +choices opts nullable cs + | isEnum && nullable = [ ("oneOf", array $ [object [("enum", array $ map consAsEnum cs)], object [("type", string "null")]]) ] + | isEnum = [ ("enum", array $ map consAsEnum cs) ] + | isUnit && nullable = [ ("type", array $ map string ["object", "null"]) + , ("properties", head $ map (conAsObject opts) cs) + ] + | isUnit = [ ("type", array $ map string ["object"]) + , ("properties", head $ map (conAsObject opts) cs) + ] + | nullable = [ ("oneOf", array $ object [("type", string "null")] : map (conAsObject opts) cs) ] + | otherwise = [ ("oneOf", array $ map (conAsObject opts) cs) ] + where + isEnum = A.allNullaryToStringTag opts && all enumerable cs + isUnit = length cs == 1 + +enumerable :: SchemaChoice -> Bool +enumerable (SCChoiceEnum _ _) = True +enumerable _ = False + +consAsEnum :: SchemaChoice -> Text +consAsEnum (SCChoiceEnum tag _) = tag +consAsEnum s = error ("conAsEnum could not handle: " ++ show s) + +conAsObject :: A.Options -> SchemaChoice -> A.Value +conAsObject opts sc + | isArray opts = object $ + if sctTitle sc == "" then [] else [ ("title", string $ sctTitle sc) ] + `mappend` + [ ("type", "array") + , ("items" , conAsObject' opts sc) + , ("minItems", number 2) + , ("maxItems", number 2) + , ("additionalItems", false) + ] + | otherwise = object $ + if sctTitle sc == "" then [] else [ ("title", string $ sctTitle sc) ] + `mappend` + [ ("type", "object") + , ("properties", conAsObject' opts sc) + , ("additionalProperties", false) + ] + +isArray :: A.Options -> Bool +isArray (A.sumEncoding -> A.TwoElemArray) = True +isArray _ = False + +conAsObject' :: A.Options -> SchemaChoice -> A.Value +conAsObject' opts@(A.Options {A.sumEncoding = A.TaggedObject tFld cFld}) sc = conAsTag opts (pack tFld) (pack cFld) sc +conAsObject' opts@(A.Options {A.sumEncoding = A.TwoElemArray }) sc = conAsArray opts sc +conAsObject' opts@(A.Options {A.sumEncoding = A.ObjectWithSingleField }) sc = conAsMap opts sc + +conAsTag :: A.Options -> Text -> Text -> SchemaChoice -> A.Value +conAsTag opts tFld cFld (SCChoiceEnum tag _) = object [(tFld, object [("enum", array [tag])]), (cFld, conToArray opts [])] +conAsTag opts tFld cFld (SCChoiceArray tag _ ar) = object [(tFld, object [("enum", array [tag])]), (cFld, conToArray opts ar)] +conAsTag opts tFld _ (SCChoiceMap tag _ mp _) = object ((tFld, object [("enum", array [tag])]) : toMap opts mp) + +conAsArray :: A.Options -> SchemaChoice -> A.Value +conAsArray opts (SCChoiceEnum tag _) = array [object [("enum", array [tag])], conToArray opts []] +conAsArray opts (SCChoiceArray tag _ ar) = array [object [("enum", array [tag])], conToArray opts ar] +conAsArray opts (SCChoiceMap tag _ mp rq) = array [object [("enum", array [tag])], conToObject opts mp rq] + +conAsMap :: A.Options -> SchemaChoice -> A.Value +conAsMap opts (SCChoiceEnum tag _) = object [(tag, conToArray opts [])] +conAsMap opts (SCChoiceArray tag _ ar) = object [(tag, conToArray opts ar)] +conAsMap opts (SCChoiceMap tag _ mp rq) = object [(tag, conToObject opts mp rq)] + +conToArray :: A.Options -> [Schema] -> A.Value +conToArray opts ar = object + [ ("type", "array") + , ("items", array . map (convert' True opts) $ ar) + , ("minItems", A.toJSON $ length ar) + , ("maxItems", A.toJSON $ length ar) + , ("additionalItems", false) + ] + +conToObject :: A.Options -> [(Text,Schema)] -> [Text] -> A.Value +conToObject opts mp rq = object + [ ("type", "object") + , ("properties", object $ toMap opts mp) + , ("required", required opts) + , ("additionalProperties", false) + ] + where + required A.Options {A.omitNothingFields = True} = array rq + required A.Options {A.omitNothingFields = _ } = array . map fst $ toMap opts mp + +toMap :: A.Options -> [(Text,Schema)] -> [(Text,A.Value)] +toMap opts mp = map (\(n,v) -> (n,convert' False opts v)) mp -- ++ [("additionalProperties", false)] + diff --git a/src/Data/JSON/Schema/Generator/Generic.hs b/src/Data/JSON/Schema/Generator/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema/Generator/Generic.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.JSON.Schema.Generator.Generic () where + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative (pure) +import Data.Monoid (mappend, mempty) +#endif + +import Data.JSON.Schema.Generator.Class (JSONSchemaGen(..), JSONSchemaPrim(..) + , GJSONSchemaGen(..), Options(..), PropType(..)) +import Data.JSON.Schema.Generator.Types (Schema(..), SchemaChoice(..) + , scBoolean, scInteger, scNumber, scString) +import Data.HashMap.Strict (HashMap) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy (Proxy(Proxy)) +import Data.Tagged (Tagged(Tagged, unTagged)) +import qualified Data.Text as Text +import Data.Typeable (Typeable, typeOf) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics ( + Datatype(datatypeName, moduleName), Constructor(conName), Selector(selName) + , NoSelector + , C1, D1, K1, M1(unM1), S1, U1, (:+:), (:*:) + , S) + +-------------------------------------------------------------------------------- + +data Env = Env + { envModuleName :: !String + , envDatatypeName :: !String + , envConName :: !String + , envSelname :: !(Maybe String) + } + +initEnv :: Env +initEnv = Env "" "" "" Nothing + +instance (Datatype d, SchemaType f) => GJSONSchemaGen (D1 d f) where + gToSchema opts pd = SCSchema + { scId = Text.pack $ baseUri opts ++ modName ++ "." ++ typName ++ schemaIdSuffix opts + , scUsedSchema = "http://json-schema.org/draft-04/schema#" + , scSchemaType = (simpleType opts env . fmap unM1 $ pd) + { scTitle = Text.pack $ modName ++ "." ++ typName + } + , scDefinitions = mempty + } + where + modName = moduleName (undefined :: D1 d f p) + typName = datatypeName (undefined :: D1 d f p) + env = initEnv { envModuleName = modName + , envDatatypeName = typName + } + +-------------------------------------------------------------------------------- + +class SchemaType f where + simpleType :: Options -> Env -> Proxy (f a) -> Schema + +instance (Constructor c) => SchemaType (C1 c U1) where + simpleType _ env _ = SCConst + { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ conname + , scDescription = Nothing + , scValue = Text.pack conname + } + where + conname = conName (undefined :: C1 c U1 p) + +instance (IsRecord f isRecord, SchemaTypeS f isRecord, Constructor c) => SchemaType (C1 c f) where + simpleType opts env _ = (unTagged :: Tagged isRecord Schema -> Schema) . simpleTypeS opts env' $ (Proxy :: Proxy (f p)) + where + env' = env { envConName = conName (undefined :: C1 c f p) } + +-- there are multiple constructors +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} (AllNullary f allNullary, SchemaTypeM f allNullary) => SchemaType f where + simpleType opts env _ = (unTagged :: Tagged allNullary Schema -> Schema) . simpleTypeM opts env $ (Proxy :: Proxy (f p)) +#else +instance (AllNullary f allNullary, SchemaTypeM f allNullary) => SchemaType f where + simpleType opts env _ = (unTagged :: Tagged allNullary Schema -> Schema) . simpleTypeM opts env $ (Proxy :: Proxy (f p)) +#endif + +class SchemaTypeS f isRecord where + simpleTypeS :: Options -> Env -> Proxy (f a) -> Tagged isRecord Schema + +-- Record +instance (RecordToPairs f) => SchemaTypeS f True where + simpleTypeS opts env _ = Tagged SCObject + { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env + , scDescription = Nothing + , scNullable = False + , scProperties = recordToPairs opts env False (Proxy :: Proxy (f p)) + , scPatternProps = [] + , scRequired = map fst $ recordToPairs opts env True (Proxy :: Proxy (f p)) + } + +-- Product +instance (ProductToList f) => SchemaTypeS f False where + simpleTypeS opts env _ = Tagged SCArray + { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env + , scDescription = Nothing + , scNullable = False + , scItems = productToList opts env (Proxy :: Proxy (f p)) + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +class SchemaTypeM f allNullary where + simpleTypeM :: Options -> Env -> Proxy (f a) -> Tagged allNullary Schema + +-- allNullary +instance (SumToEnum f) => SchemaTypeM f True where + simpleTypeM _ env _ = Tagged SCOneOf + { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env + , scDescription = Nothing + , scNullable = False + , scChoices = sumToEnum env (Proxy :: Proxy (f p)) + } + +-- not allNullary +instance (SumToArrayOrMap f) => SchemaTypeM f False where + simpleTypeM opts env _ = Tagged SCOneOf + { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env + , scDescription = Nothing + , scNullable = False + , scChoices = sumToArrayOrMap opts env (Proxy :: Proxy (f p)) + } + +-------------------------------------------------------------------------------- + +class SumToEnum f where + sumToEnum :: Env -> Proxy (f a) -> [SchemaChoice] + +instance (Constructor c) => SumToEnum (C1 c U1) where + sumToEnum env _ = pure SCChoiceEnum + { sctName = Text.pack $ conName (undefined :: C1 c U1 p) + , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." + ++ conName (undefined :: C1 c U1 p) + } + +instance (SumToEnum a, SumToEnum b) => SumToEnum (a :+: b) where + sumToEnum env _ = sumToEnum env a `mappend` sumToEnum env b + where + a = Proxy :: Proxy (a p) + b = Proxy :: Proxy (b p) + +class SumToArrayOrMap f where + sumToArrayOrMap :: Options -> Env -> Proxy (f a) -> [SchemaChoice] + +instance (Constructor c, IsRecord f isRecord, ConToArrayOrMap f isRecord) + => SumToArrayOrMap (C1 c f) where + sumToArrayOrMap opts env _ = + pure . (unTagged :: Tagged isRecord SchemaChoice -> SchemaChoice) . conToArrayOrMap opts env' $ (Proxy :: Proxy (f p)) + where + env' = env { envConName = conName (undefined :: C1 c f p) } + +instance (SumToArrayOrMap a, SumToArrayOrMap b) => SumToArrayOrMap (a :+: b) where + sumToArrayOrMap opts env _ = sumToArrayOrMap opts env a `mappend` sumToArrayOrMap opts env b + where + a = Proxy :: Proxy (a p) + b = Proxy :: Proxy (b p) + +class ConToArrayOrMap f isRecord where + conToArrayOrMap :: Options -> Env -> Proxy (f a) -> Tagged isRecord SchemaChoice + +instance (RecordToPairs f) => ConToArrayOrMap f True where + conToArrayOrMap opts env _ = Tagged SCChoiceMap + { sctName = Text.pack $ envConName env + , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env + , sctMap = recordToPairs opts env False (Proxy :: Proxy (f p)) + , sctRequired = map fst $ recordToPairs opts env True (Proxy :: Proxy (f p)) + } + +instance (RecordToPairs f) => ConToArrayOrMap f False where + conToArrayOrMap opts env _ = Tagged SCChoiceArray + { sctName = Text.pack $ envConName env + , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env + , sctArray = map snd $ recordToPairs opts env False (Proxy :: Proxy (f p)) + } + +-------------------------------------------------------------------------------- + +class RecordToPairs f where + recordToPairs :: Options -> Env -> Bool -> Proxy (f a) -> [(Text, Schema)] + +instance RecordToPairs U1 where + recordToPairs _ _ _ _ = mempty + +instance (Selector s, IsNullable a, ToJSONSchemaDef a) => RecordToPairs (S1 s a) where + recordToPairs opts env notMaybe _ + | isEmpty = mempty + | otherwise = pure ( Text.pack selname + , (toJSONSchemaDef opts env' field) { scNullable = isNullable field }) + where + isEmpty = notMaybe && isNullable field + field = Proxy :: Proxy (a p) + selector = undefined :: S1 s a p + selname = selName selector + env' = env { envSelname = Just selname } + +instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where + recordToPairs opts env notMaybe _ = + recordToPairs opts env notMaybe a `mappend` recordToPairs opts env notMaybe b + where + a = Proxy :: Proxy (a p) + b = Proxy :: Proxy (b p) + +class ProductToList f where + productToList :: Options -> Env -> Proxy (f a) -> [Schema] + +instance (IsNullable a, ToJSONSchemaDef a) => ProductToList (S1 s a) where + productToList opts env _ = pure (toJSONSchemaDef opts env prod) {scNullable = isNullable prod} + where + prod = Proxy :: Proxy (a p) + +instance (ProductToList a, ProductToList b) => ProductToList (a :*: b) where + productToList opts env _ = productToList opts env a `mappend` productToList opts env b + where + a = Proxy :: Proxy (a p) + b = Proxy :: Proxy (b p) + +-------------------------------------------------------------------------------- + +class ToJSONSchemaDef f where + toJSONSchemaDef :: Options -> Env -> Proxy (f a) -> Schema + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i (Maybe a)) where + toJSONSchemaDef opts env _ = case propType opts env of + Just (PropType p) -> toSchemaPrim opts p + Nothing -> toSchemaPrim opts (Proxy :: Proxy a) + +instance {-# OVERLAPPABLE #-} (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i a) where + toJSONSchemaDef opts env _ = case propType opts env of + Just (PropType p) -> toSchemaPrim opts p + Nothing -> toSchemaPrim opts (Proxy :: Proxy a) +#else +instance (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i (Maybe a)) where + toJSONSchemaDef opts env _ = case propType opts env of + Just (PropType p) -> toSchemaPrim opts p + Nothing -> toSchemaPrim opts (Proxy :: Proxy a) + +instance (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i a) where + toJSONSchemaDef opts env _ = case propType opts env of + Just (PropType p) -> toSchemaPrim opts p + Nothing -> toSchemaPrim opts (Proxy :: Proxy a) +#endif + +propType :: Options -> Env -> Maybe PropType +propType opts env = do + selname <- envSelname env + Map.lookup selname $ fieldTypeMap opts + +-------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} JSONSchemaPrim String where + toSchemaPrim _ _ = scString + +instance {-# OVERLAPPING #-} JSONSchemaPrim Text where + toSchemaPrim _ _ = scString + +instance {-# OVERLAPPING #-} JSONSchemaPrim UTCTime where + toSchemaPrim _ _ = scString { scFormat = Just "date-time" } + +instance {-# OVERLAPPING #-} JSONSchemaPrim Int where + toSchemaPrim _ _ = scInteger + +instance {-# OVERLAPPING #-} JSONSchemaPrim Integer where + toSchemaPrim _ _ = scInteger + +instance {-# OVERLAPPING #-} JSONSchemaPrim Float where + toSchemaPrim _ _ = scNumber + +instance {-# OVERLAPPING #-} JSONSchemaPrim Double where + toSchemaPrim _ _ = scNumber + +instance {-# OVERLAPPING #-} JSONSchemaPrim Bool where + toSchemaPrim _ _ = scBoolean + +instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim [a] where + toSchemaPrim opts _ = SCArray + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scItems = [toSchemaPrim opts (Proxy :: Proxy a)] + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim (Map String a) where + toSchemaPrim opts _ = SCObject + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scProperties = [] + , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))] + , scRequired = [] + } + +instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim (HashMap String a) where + toSchemaPrim opts _ = SCObject + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scProperties = [] + , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))] + , scRequired = [] + } + +instance {-# OVERLAPPABLE #-} (Typeable a, JSONSchemaGen a) => JSONSchemaPrim a where + toSchemaPrim opts a = SCRef + { scReference = maybe (scId $ toSchema opts a) Text.pack $ Map.lookup (typeOf (undefined :: a)) (typeRefMap opts) + , scNullable = False + } +#else +instance JSONSchemaPrim String where + toSchemaPrim _ _ = scString + +instance JSONSchemaPrim Text where + toSchemaPrim _ _ = scString + +instance JSONSchemaPrim UTCTime where + toSchemaPrim _ _ = scString { scFormat = Just "date-time" } + +instance JSONSchemaPrim Int where + toSchemaPrim _ _ = scInteger + +instance JSONSchemaPrim Integer where + toSchemaPrim _ _ = scInteger + +instance JSONSchemaPrim Float where + toSchemaPrim _ _ = scNumber + +instance JSONSchemaPrim Double where + toSchemaPrim _ _ = scNumber + +instance JSONSchemaPrim Bool where + toSchemaPrim _ _ = scBoolean + +instance (JSONSchemaPrim a) => JSONSchemaPrim [a] where + toSchemaPrim opts _ = SCArray + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scItems = [toSchemaPrim opts (Proxy :: Proxy a)] + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +instance (JSONSchemaPrim a) => JSONSchemaPrim (Map String a) where + toSchemaPrim opts _ = SCObject + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scProperties = [] + , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))] + , scRequired = [] + } + +instance (JSONSchemaPrim a) => JSONSchemaPrim (HashMap String a) where + toSchemaPrim opts _ = SCObject + { scTitle = "" + , scDescription = Nothing + , scNullable = False + , scProperties = [] + , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))] + , scRequired = [] + } + +instance (Typeable a, JSONSchemaGen a) => JSONSchemaPrim a where + toSchemaPrim opts a = SCRef + { scReference = maybe (scId $ toSchema opts a) Text.pack $ Map.lookup (typeOf (undefined :: a)) (typeRefMap opts) + , scNullable = False + } +#endif + +-------------------------------------------------------------------------------- + +class IsNullable f where + isNullable :: Proxy (f a) -> Bool + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} IsNullable (K1 i (Maybe a)) where + isNullable _ = True + +instance {-# OVERLAPPABLE #-} IsNullable (K1 i a) where + isNullable _ = False +#else +instance IsNullable (K1 i (Maybe a)) where + isNullable _ = True + +instance IsNullable (K1 i a) where + isNullable _ = False +#endif + +-------------------------------------------------------------------------------- + +class IsRecord (f :: * -> *) isRecord | f -> isRecord + +#if __GLASGOW_HASKELL__ >= 710 +instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord +instance {-# OVERLAPPING #-} IsRecord (M1 S NoSelector f) False +instance {-# OVERLAPPABLE #-} (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord +instance IsRecord (K1 i c) True +instance IsRecord U1 False +#else +instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord +instance IsRecord (M1 S NoSelector f) False +instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord +instance IsRecord (K1 i c) True +instance IsRecord U1 False +#endif + +-------------------------------------------------------------------------------- + +class AllNullary (f :: * -> *) allNullary | f -> allNullary + +instance ( AllNullary a allNullaryL + , AllNullary b allNullaryR + , And allNullaryL allNullaryR allNullary + ) => AllNullary (a :+: b) allNullary +instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary +instance AllNullary (a :*: b) False +instance AllNullary (K1 i c) False +instance AllNullary U1 True + +-------------------------------------------------------------------------------- + +data True +data False + +class And bool1 bool2 bool3 | bool1 bool2 -> bool3 + +instance And True True True +instance And False False False +instance And False True False +instance And True False False + +-------------------------------------------------------------------------------- + diff --git a/src/Data/JSON/Schema/Generator/Types.hs b/src/Data/JSON/Schema/Generator/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema/Generator/Types.hs @@ -0,0 +1,144 @@ +module Data.JSON.Schema.Generator.Types + ( Schema (..) + , SchemaChoice (..) + , scString + , scInteger + , scNumber + , scBoolean + ) where + +import Data.Text (Text) + +-------------------------------------------------------------------------------- + +-- | A schema for a JSON value. +-- +data Schema = + SCSchema + { scId :: !Text + , scUsedSchema :: !Text + , scSchemaType :: !Schema + , scDefinitions :: ![(Text, Schema)] + } + | SCString + { scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scFormat :: !(Maybe Text) + , scLowerBound :: !(Maybe Integer) + , scUpperBound :: !(Maybe Integer) + } + | SCInteger + { scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scLowerBound :: !(Maybe Integer) + , scUpperBound :: !(Maybe Integer) + } + | SCNumber + { scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scLowerBound :: !(Maybe Integer) + , scUpperBound :: !(Maybe Integer) + } + | SCBoolean + { scDescription :: !(Maybe Text) + , scNullable :: !Bool + } + | SCConst + { scTitle :: !Text + , scDescription :: !(Maybe Text) + , scValue :: !Text + } + | SCObject + { scTitle :: !Text + , scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scProperties :: ![(Text, Schema)] + , scPatternProps :: ![(Text, Schema)] + , scRequired :: ![Text] + } + | SCArray + { scTitle :: !Text + , scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scItems :: ![Schema] + , scLowerBound :: !(Maybe Integer) + , scUpperBound :: !(Maybe Integer) + } + | SCOneOf + { scTitle :: !Text + , scDescription :: !(Maybe Text) + , scNullable :: !Bool + , scChoices :: ![SchemaChoice] + } + | SCRef + { scReference :: !Text + , scNullable :: !Bool + } + | SCNull + deriving (Show) + +-- | A sum encoding for ADT. +-- +data SchemaChoice = + SCChoiceEnum + { sctName :: !Text -- constructor name. + , sctTitle :: !Text -- an arbitrary text. e.g. Types.UnitType1.UnitData11. + } + -- ^ Encoding for constructors that are all unit type. + -- e.g. "test": {"enum": ["xxx", "yyy", "zzz"]} + | SCChoiceArray + { sctName :: !Text -- constructor name. + , sctTitle :: !Text -- an arbitrary text. e.g. Types.ProductType1.ProductData11. + , sctArray :: ![Schema] -- parametes of constructor. + } + -- ^ Encoding for constructors that are non record type. + -- e.g. "test": [{"tag": "xxx", "contents": []},...] or "test": [{"xxx": [],},...] + | SCChoiceMap + { sctName :: !Text -- constructor name. + , sctTitle :: !Text -- an arbitrary text. e.g. Types.RecordType1.RecordData11. + , sctMap :: ![(Text, Schema)] -- list of record field name and schema in this constructor. + , sctRequired :: ![Text] -- required field names. + } + -- ^ Encoding for constructos that are record type. + -- e.g. "test": [{"tag": "xxx", "contents": {"aaa": "yyy",...}},...] or "test": [{"xxx": []},...] + deriving (Show) + +-- ^ A smart consturctor for String. +-- +scString :: Schema +scString = SCString + { scDescription = Nothing + , scNullable = False + , scFormat = Nothing + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +-- ^ A smart consturctor for Integer. +-- +scInteger :: Schema +scInteger = SCInteger + { scDescription = Nothing + , scNullable = False + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +-- ^ A smart consturctor for Number. +-- +scNumber :: Schema +scNumber = SCNumber + { scDescription = Nothing + , scNullable = False + , scLowerBound = Nothing + , scUpperBound = Nothing + } + +-- ^ A smart consturctor for Boolean. +-- +scBoolean :: Schema +scBoolean = SCBoolean + { scDescription = Nothing + , scNullable = False + } + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +import Control.Applicative ((<*>), pure) +import Control.Arrow ((&&&)) +import Control.Monad (forM, forM_) +import Control.Monad.Trans.State +import qualified Data.Aeson as A +import qualified Data.Aeson.TH as A +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.JSON.Schema.Generator as G +import qualified Data.List as List +import Data.Map (fromList) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(Proxy)) +import Data.Typeable (typeOf) +import GHC.Generics +import System.Exit (ExitCode(ExitSuccess), exitWith) +import System.IO (Handle, IOMode(WriteMode), hClose, hPutStr, hPutStrLn, withFile) +import System.Process (CreateProcess(..), CmdSpec(RawCommand), StdStream(CreatePipe, Inherit) + , createProcess, system, waitForProcess) + +import Types +import Values + +-- +-- Instances +-- + +instance G.JSONSchemaGen RecordType1 +instance G.JSONSchemaGen RecordType2 +instance G.JSONSchemaGen ProductType1 +instance G.JSONSchemaGen ProductType2 +instance G.JSONSchemaGen UnitType1 +instance G.JSONSchemaGen UnitType2 +instance G.JSONSchemaGen MixType1 + +--instance G.JSONSchemaPrim UnitType2 where +-- toSchemaPrim opts _ = G.scSchemaType . G.toSchema opts $ (Proxy :: Proxy UnitType2) + +-- +-- TestData +-- + +data TestDatum = + forall a. (Generic a, A.GToJSON (Rep a), SchemaName (Rep a)) + => TestDatum { tdName :: String + , tdValue :: a + } + +testDatum :: (Generic a, A.GToJSON (Rep a), SchemaName (Rep a)) => String -> a -> TestDatum +testDatum name p = TestDatum name p + +testData :: [TestDatum] +testData = + [ TestDatum "recordData11" recordType11 + , testDatum "recordData12" recordType22 + , testDatum "productData11" productData11 + , testDatum "productData12" productData12 + , testDatum "unitData1" unitData1 + , testDatum "unitData2" unitData2 + , testDatum "unitData3" unitData3 + , testDatum "mixData11" mixData11 + , testDatum "mixData12" mixData12 + , testDatum "mixData13" mixData13 + ] + +-- +-- Encoder +-- + +aesonOptions :: Bool -> Bool -> A.SumEncoding -> A.Options +aesonOptions allNullary omitNothing sumEncoding = A.defaultOptions + { A.allNullaryToStringTag = allNullary + , A.omitNothingFields = omitNothing + , A.sumEncoding = sumEncoding + } + +optPatterns :: [A.Options] +optPatterns = + [ aesonOptions True True + , aesonOptions True False + , aesonOptions False True + , aesonOptions False False + ] + <*> + [ A.defaultTaggedObject + , A.ObjectWithSingleField + , A.TwoElemArray + ] + +encode :: (Generic a, A.GToJSON (Rep a)) => A.Options -> a -> BL.ByteString +encode opt a = A.encode (A.genericToJSON opt a) + +-- +-- Print values as json in python +-- + +optToStr :: String -> A.Options -> String +optToStr symbol A.Options { A.allNullaryToStringTag = a, A.omitNothingFields = b, A.sumEncoding = c } = + "# " ++ symbol ++ " (allNullaryToStringTag: " ++ show a + ++ ", omitNothingFields: " ++ show b + ++ ", sumEncoding: " ++ showC c ++ ")" + +showC :: A.SumEncoding -> String +showC A.TwoElemArray = "array" +showC A.ObjectWithSingleField = "object" +showC _ = "tag" + +pairsOptSymbol :: [A.Options] -> String -> [(A.Options, String)] +pairsOptSymbol opts name = + fst . flip runState (0 :: Int) $ forM opts $ \opt -> do + n <- fmap (+ 1) get + put $! n + return (opt, name ++ "_" ++ show n) + +printValueAsJson :: (Generic a, A.GToJSON (Rep a)) => Handle -> [A.Options] -> String -> a -> IO () +printValueAsJson h opts name value = + forM_ (pairsOptSymbol opts name) . uncurry $ \opt symbol -> do + hPutStrLn h $ optToStr symbol opt + hPutStr h $ symbol ++ " = json.loads('" + BL.hPutStr h $ Main.encode opt value + hPutStrLn h "')" + hPutStrLn h "" + +printValueAsJsonInPython :: FilePath -> IO () +printValueAsJsonInPython path = do + withFile path WriteMode $ \h -> do + hPutStrLn h "# -*- coding: utf-8 -*-" + hPutStrLn h "import json" + hPutStrLn h "" + forM_ testData $ \(TestDatum name value) -> + printValueAsJson h optPatterns name value + +-- +-- Print type definitions as schema in individualy json files +-- + +printTypeAsSchema :: (Generic a, G.JSONSchemaGen a, SchemaName (Rep a)) + => FilePath -> G.Options -> [A.Options] -> Proxy a -> IO () +printTypeAsSchema dir opts aoptss a = do + forM_ aoptss $ \aopts -> do + let fa = fmap from a + let filename = schemaName opts aopts fa + let suffix = "." ++ schemaSuffix opts aopts fa + let path = dir ++ "/" ++ filename + let opts' = opts { G.schemaIdSuffix = suffix } + withFile path WriteMode $ \h -> do + BL.hPutStrLn h $ G.generate' opts' aopts a + +class SchemaName f where + schemaName :: G.Options -> A.Options -> Proxy (f a) -> FilePath + schemaSuffix :: G.Options -> A.Options -> Proxy (f a) -> String + +instance (Datatype d) => SchemaName (D1 d f) where + schemaName opts aopts p = modName ++ "." ++ typName ++ "." ++ schemaSuffix opts aopts p + where + modName = moduleName (undefined :: D1 d f p) + typName = datatypeName (undefined :: D1 d f p) + schemaSuffix opts A.Options { A.allNullaryToStringTag = a, A.omitNothingFields = b, A.sumEncoding = c } _ = + show a ++ "." ++ show b ++ "." ++ showC c ++ G.schemaIdSuffix opts + +schemaOptions :: G.Options +schemaOptions = G.defaultOptions + { G.baseUri = "https://github.com/yuga/jsonschema-gen/tests/" + , G.schemaIdSuffix = ".json" + , G.typeRefMap = fromList + [ (typeOf (undefined :: RecordType2), "https://github.com/yuga/jsonschema-gen/tests/Types.RecordType2.True.False.tag.json") + , (typeOf (undefined :: ProductType2), "https://github.com/yuga/jsonschema-gen/tests/Types.ProductType2.True.False.tag.json") + ] + } + +schemaOptions' :: G.Options +schemaOptions'= schemaOptions + { G.typeRefMap = fromList + [ (typeOf (undefined :: RecordType2), "https://github.com/yuga/jsonschema-gen/tests/Types.RecordType2.True.False.tag.json") + , (typeOf (undefined :: ProductType2), "https://github.com/yuga/jsonschema-gen/tests/Types.ProductType2.True.False.tag.json") + , (typeOf (undefined :: UnitType2), "https://github.com/yuga/jsonschema-gen/tests/Types.UnitType2.True.False.tag.json") + ] + , G.fieldTypeMap = fromList [("recordField1A", G.PropType (Proxy :: Proxy UnitType2))] + } + +printTypeAsSchemaInJson :: FilePath -> IO () +printTypeAsSchemaInJson dir = do + printTypeAsSchema dir schemaOptions' optPatterns (Proxy :: Proxy RecordType1) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy RecordType2) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy ProductType1) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy ProductType2) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy UnitType1) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy UnitType2) + printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy MixType1) + +-- +-- Print jsonschema validator in python +-- + +convertToPythonLoadingSchema :: (Generic a, SchemaName (Rep a)) => G.Options -> [A.Options] -> Proxy a -> ([String], [String]) +convertToPythonLoadingSchema opts aoptss a = + let fa = fmap from a + toLoader aopts = + let filename = schemaName opts aopts fa + symbol = "schema_" ++ map dotToLowline filename + in (symbol ++ " = json.load(codecs.open(schemaPath + '" ++ filename ++ "', 'r', 'utf-8'))") + toStore aopts = + let filename = schemaName opts aopts fa + symbol = "schema_" ++ map dotToLowline filename + in ("'" ++ G.baseUri opts ++ filename ++ "' : " ++ symbol) + in (map toLoader &&& map toStore) aoptss + +dotToLowline :: Char -> Char +dotToLowline '.' = '_' +dotToLowline c = c + +printLoadSchemas :: Handle -> IO () +printLoadSchemas h = do + let (loader, store) = convertToPythonLoadingSchema schemaOptions' optPatterns (Proxy :: Proxy RecordType1) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy RecordType2) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy ProductType1) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy ProductType2) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy UnitType1) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy UnitType2) + <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy MixType1) + hPutStrLn h "schemaPath = os.path.dirname(os.path.realpath(__file__)) + '/'" + mapM_ (hPutStrLn h) loader + hPutStrLn h "" + mapM_ (hPutStrLn h . concat) . chunk 2 $ beginmap : (List.intersperse comma store) ++ [endofmap] + where + chunk n = takeWhile (not . null) . map (take n) . iterate (drop n) + beginmap = "selfStore = { " + comma = " , " + endofmap = " }" + +printValidate :: Handle -> [A.Options] -> IO () +printValidate h aoptss = do + hPutStrLn h "def mkValidator(schema):" + hPutStrLn h " resolver = jsonschema.RefResolver(schema[u'id'], schema, store=selfStore)" + hPutStrLn h " validator = jsonschema.Draft4Validator(schema, resolver=resolver)" + hPutStrLn h " return validator" + hPutStrLn h "" + forM_ testData $ \(TestDatum name value) -> + forM_ (pairsOptSymbol aoptss name) . uncurry $ \aopts dataSymbol -> do + let schemaFilename = schemaName schemaOptions aopts (fmap from . pure $ value) + let schemaSymbol = map dotToLowline schemaFilename + hPutStrLn h $ "mkValidator(" ++ "schema_" ++ schemaSymbol ++ ").validate(jsondata." ++ dataSymbol ++ ")" + +printValidatorInPython :: FilePath -> IO () +printValidatorInPython path = do + withFile path WriteMode $ \h -> do + hPutStrLn h "# -*- coding: utf-8 -*-" + hPutStrLn h "import codecs" + hPutStrLn h "import json" + hPutStrLn h "import jsondata" + hPutStrLn h "import jsonschema" + hPutStrLn h "import os" + hPutStrLn h "" + printLoadSchemas h + hPutStrLn h "" + printValidate h optPatterns + +-- +-- Run Test +-- + +pythonProcess :: FilePath -> CreateProcess +pythonProcess dir = + CreateProcess + { cmdspec = RawCommand "python" [dir ++ "/jsonvalidator.py"] + , cwd = Nothing + , env = Nothing + , std_in = CreatePipe + , std_out = Inherit + , std_err = Inherit + , close_fds = False + , create_group = False +#if MIN_VERSION_process(1,2,0) + , delegate_ctlc = True +#endif + } + +runTest :: FilePath -> IO () +runTest dir = do + handles <- createProcess $ pythonProcess dir + case handles of + (Just hIn, _, _, hP) -> do + hClose hIn + ec <- waitForProcess hP + exitWith ec + _ -> fail $ "Failed to launch python" + +-- +-- Main +-- + +main :: IO () +main = do + let dir = "tests" + printValueAsJsonInPython (dir ++ "/jsondata.py") + printTypeAsSchemaInJson (dir) + printValidatorInPython (dir ++ "/jsonvalidator.py") + ec <- system "python --version" + case ec of + ExitSuccess -> runTest dir + _ -> putStrLn "If you have 'python' in your PATH, this test runs jsonvalidator.py" + diff --git a/tests/Types.hs b/tests/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Types where + +import Data.Typeable +import GHC.Generics + +data RecordType1 = + RecordData11 + { recordField11 :: String + , recordField12 :: Int + , recordField13 :: Double + , recordField14 :: Maybe String + , recordField15 :: RecordType2 + , recordField16 :: [String] + , recordField17 :: [Int] + , recordField18 :: [Int] + , recordField19 :: Maybe Int + , recordField1A :: String + } + deriving (Show, Generic) + +data RecordType2 = + RecordData21 + { recordField21 :: String + , recordField22 :: Maybe String + } + | RecordData22 + { recordField21 :: String + , recordField22 :: Maybe String + , recordField23 :: Int + } + deriving (Show, Generic, Typeable) + +data ProductType1 = ProductData11 String Int Double (Maybe String) ProductType2 + deriving (Show, Generic) + +data ProductType2 = ProductData21 String (Maybe String) + | ProductData22 String (Maybe String) Int + deriving (Show, Generic, Typeable) + +data UnitType1 = UnitData1 | UnitData2 | UnitData3 + deriving (Show, Generic, Typeable) + +data UnitType2 = UnitData21 | UnitData22 | UnitData23 + deriving (Show, Generic, Typeable) + +data MixType1 = + MixData11 + | MixData12 String (Maybe String) + | MixData13 + { recordField31 :: String + , recordField32 :: Maybe String + , recordField33 :: Int + } + deriving (Show, Generic) +