e01354d · schematic · git.iko.soy

git.iko.soy/schematic

Basic json-schema export

commite01354dea03ff06759a105fda5ad2c6c0b5299bd authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 30 Aug 2017, 19:11 (9 years ago) parent79f8af1

5 files changed+85−53

compare with master

unifiedsplit

schematic.cabal+1 src/Data/Schematic.hs+3−1 src/Data/Schematic/JsonSchema.hs+66−52 src/Data/Schematic/Schema.hs+14 src/Data/Schematic/Validation.hs+1

schematic.cabal+1

@@ -64,6 +64,7 @@ library

6464 , aeson >= 1

6565 , containers

6666 , hjsonschema

67+ , mtl

6768 , regex-compat

6869 , scientific

6970 , singletons >= 2.2

src/Data/Schematic.hs+3−1

@@ -2,7 +2,8 @@

22{-# LANGUAGE AllowAmbiguousTypes #-}

44module Data.Schematic

5− ( module Data.Schematic.Schema

5+ ( module Data.Schematic.JsonSchema

6+ , module Data.Schematic.Schema

67 , module Data.Schematic.Lens

78 , module Data.Schematic.Migration

89 , module Data.Schematic.Utils

@@ -26,6 +27,7 @@ import Data.Aeson as J

2627import Data.Aeson.Types as J

2728import Data.ByteString.Lazy as BL

2829import Data.Functor.Identity

30+import Data.Schematic.JsonSchema

2931import Data.Schematic.Lens

3032import Data.Schematic.Migration

3133import Data.Schematic.Schema

src/Data/Schematic/JsonSchema.hs+66−52

@@ -2,59 +2,73 @@

22{-# LANGUAGE RecordWildCards #-}

33{-# LANGUAGE OverloadedLabels #-}

5−module Data.Schematic.JsonSchema where

5+module Data.Schematic.JsonSchema

6+ ( toJsonSchema

7+ ) where

7−import Data.Aeson

8−import qualified Data.Map as M

9−import Data.Schematic.Schema

10−import Data.Singletons

11−import Data.Text

12−import qualified JSONSchema.Draft4.Schema as D4

9+import Control.Monad.State.Strict

10+import Data.Foldable

11+import Data.HashMap.Strict as H

12+import Data.List.NonEmpty

13+import Data.Schematic.Schema as S

14+import Data.Singletons

15+import Data.Text

16+import JSONSchema.Draft4.Schema as D4

17+import JSONSchema.Validator.Draft4 as D4

1318

1419

1520draft4 :: Text

16−draft4 = "http://json-schema.org/draft-04/schema#"

17−

18−-- toJsonSchema :: JsonRepr schema -> D4.Schema

19−-- toJsonSchema (ReprText t) = D4.emptySchema

20−-- { D4._schemaVersion = pure draft4

21−-- }

22−

23−-- toJsonSchema

24−-- :: forall schema. (SingI schema)

25−-- => Sing (schema :: Schema)

26−-- -> D4.Schema

27−-- toJsonSchema _ = case fromSing (sing :: Sing schema) of

28−-- SchemaText tcs -> D4.emptySchema

29−-- SchemaNumber ncs -> D4.emptySchema

30−-- SchemaObject ocs -> D4.emptySchema

31−-- SchemaArray acs sch -> D4.emptySchema

32−-- SchemaNull -> D4.emptySchema

33−-- SchemaOptional sch -> D4.emptySchema

34−

35−-- jsonObject :: M.Map Text JsonSchema -> JsonSchema

36−-- jsonObject m = JsonObject

37−-- { type_ = JObject

38−-- , properties = m

39−-- , additionalProperties = False

40−-- , required = M.keys $ M.filter

41−-- (\case; JsonOptional _ -> False; _ -> True) m

42−-- , schemaDraft = draft6 }

43−

44−-- Root schema:

45−--

46−-- {

47−-- "title": "root",

48−-- "items": {

49−-- "title": "array item"

50−-- }

51−-- }

52−

53−-- toSchema :: JsonRepr a -> JsonSchema

54−-- toSchema = \case

55−-- ReprText t ->

56−-- ReprNumber n ->

57−-- ReprNull ->

58−-- ReprArray arr ->

59−-- ReprObject obj ->

60−-- ReprOptional mv ->

21+draft4 = "http://Jason-schema.org/draft-04/schema#"

22+

23+-- FIXME: implement all this later

24+textConstraint :: DemotedTextConstraint -> State D4.Schema ()

25+textConstraint (DTEq _) = pure ()

26+textConstraint (DTLt _) = pure ()

27+textConstraint (DTLe _) = pure ()

28+textConstraint (DTGt _) = pure ()

29+textConstraint (DTGe _) = pure ()

30+textConstraint (DTRegex _) = pure ()

31+textConstraint (DTEnum _) = pure ()

32+

33+numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()

34+numberConstraint (DNLe _) = pure ()

35+numberConstraint (DNLt _) = pure ()

36+numberConstraint (DNGt _) = pure ()

37+numberConstraint (DNGe _) = pure ()

38+numberConstraint (DNEq _) = pure ()

39+

40+arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()

41+arrayConstraint (DAEq _) = pure ()

42+

43+toJsonSchema

44+ :: forall proxy schema

45+ . SingI schema

46+ => proxy (schema :: S.Schema)

47+ -> D4.Schema

48+toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))

49+ { _schemaVersion = pure draft4 }

50+

51+toJsonSchema'

52+ :: DemotedSchema

53+ -> D4.Schema

54+toJsonSchema' = \case

55+ DSchemaText tcs ->

56+ execState (traverse_ textConstraint tcs) $ emptySchema

57+ { _schemaType = pure $ TypeValidatorString D4.SchemaString }

58+ DSchemaNumber ncs ->

59+ execState (traverse_ numberConstraint ncs) $ emptySchema

60+ { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }

61+ DSchemaBoolean -> emptySchema

62+ { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }

63+ DSchemaObject objs -> emptySchema

64+ { _schemaType = pure $ TypeValidatorString D4.SchemaObject

65+ , _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s))

66+ <$> objs }

67+ DSchemaArray acs sch ->

68+ execState (traverse_ arrayConstraint acs) $ emptySchema

69+ { _schemaType = pure $ TypeValidatorString D4.SchemaArray

70+ , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }

71+ DSchemaNull -> emptySchema

72+ { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

73+ DSchemaOptional sch -> emptySchema

74+ { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }

src/Data/Schematic/Schema.hs+14

@@ -199,6 +199,7 @@ instance SingKind ArrayConstraint where

199199

200200data Schema

201201 = SchemaText [TextConstraint]

202+ | SchemaBoolean

202203 | SchemaNumber [NumberConstraint]

203204 | SchemaObject [(Symbol, Schema)]

204205 | SchemaArray [ArrayConstraint] Schema

@@ -209,6 +210,7 @@ data Schema

209210data DemotedSchema

210211 = DSchemaText [DemotedTextConstraint]

211212 | DSchemaNumber [DemotedNumberConstraint]

213+ | DSchemaBoolean

212214 | DSchemaObject [(Text, DemotedSchema)]

213215 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

214216 | DSchemaNull

@@ -218,6 +220,7 @@ data DemotedSchema

218220data instance Sing (schema :: Schema) where

219221 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)

220222 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)

223+ SSchemaBoolean :: Sing 'SchemaBoolean

221224 SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

222225 SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)

223226 SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)

@@ -229,6 +232,8 @@ instance SingI sl => SingI ('SchemaNumber sl) where

229232 sing = SSchemaNumber sing

230233instance SingI 'SchemaNull where

231234 sing = SSchemaNull

235+instance SingI 'SchemaBoolean where

236+ sing = SSchemaBoolean

232237instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where

233238 sing = SSchemaArray sing sing

234239instance SingI stl => SingI ('SchemaObject stl) where

@@ -239,6 +244,7 @@ instance SingI s => SingI ('SchemaOptional s) where

239244instance Eq (Sing ('SchemaText cs)) where _ == _ = True

240245instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True

241246instance Eq (Sing 'SchemaNull) where _ == _ = True

247+instance Eq (Sing 'SchemaBoolean) where _ == _ = True

242248instance Eq (Sing ('SchemaArray as s)) where _ == _ = True

243249instance Eq (Sing ('SchemaObject cs)) where _ == _ = True

244250instance Eq (Sing ('SchemaOptional s)) where _ == _ = True

@@ -248,6 +254,7 @@ instance SingKind Schema where

248254 fromSing = \case

249255 SSchemaText cs -> DSchemaText $ fromSing cs

250256 SSchemaNumber cs -> DSchemaNumber $ fromSing cs

257+ SSchemaBoolean -> DSchemaBoolean

251258 SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)

252259 SSchemaOptional s -> DSchemaOptional $ fromSing s

253260 SSchemaNull -> DSchemaNull

@@ -262,6 +269,7 @@ instance SingKind Schema where

262269 SomeSing scs -> SomeSing $ SSchemaText scs

263270 DSchemaNumber cs -> case toSing cs of

264271 SomeSing scs -> SomeSing $ SSchemaNumber scs

272+ DSchemaBoolean -> SomeSing $ SSchemaBoolean

265273 DSchemaArray cs sch -> case (toSing cs, toSing sch) of

266274 (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch

267275 DSchemaOptional sch -> case toSing sch of

@@ -309,6 +317,7 @@ instance

309317data JsonRepr :: Schema -> Type where

310318 ReprText :: Text -> JsonRepr ('SchemaText cs)

311319 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

320+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

312321 ReprNull :: JsonRepr 'SchemaNull

313322 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

314323 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

@@ -383,6 +392,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

383392 parseJSON value = case sing :: Sing schema of

384393 SSchemaText _ -> withText "String" (pure . ReprText) value

385394 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value

395+ SSchemaBoolean -> ReprBoolean <$> parseJSON value

386396 SSchemaNull -> case value of

387397 J.Null -> pure ReprNull

388398 _ -> typeMismatch "Null" value

@@ -402,6 +412,9 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

402412 SSchemaNumber so -> case H.lookup fieldName h of

403413 Just v -> withSingI so $ FieldRepr <$> parseJSON v

404414 Nothing -> fail "schemanumber"

415+ SSchemaBoolean -> case H.lookup fieldName h of

416+ Just v -> FieldRepr <$> parseJSON v

417+ Nothing -> fail "schemaboolean"

405418 SSchemaNull -> case H.lookup fieldName h of

406419 Just v -> FieldRepr <$> parseJSON v

407420 Nothing -> fail "schemanull"

@@ -419,6 +432,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

419432

420433instance J.ToJSON (JsonRepr a) where

421434 toJSON ReprNull = J.Null

435+ toJSON (ReprBoolean b) = J.Bool b

422436 toJSON (ReprText t) = J.String t

423437 toJSON (ReprNumber n) = J.Number n

424438 toJSON (ReprOptional s) = case s of

src/Data/Schematic/Validation.hs+1

@@ -178,6 +178,7 @@ validateJsonRepr sschema dpath jr = case jr of

178178 process cs

179179 process scs

180180 ReprNull -> pure ()

181+ ReprBoolean _ -> pure ()

181182 ReprArray v -> case sschema of

182183 SSchemaArray acs s -> do

183184 let