e01354d · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

Basic json-schema export

e01354dDenis Redozubov9 years ago

schematic.cabal+1

compare with master

unifiedsplit

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

64 , aeson >= 1

65 , containers

66 , hjsonschema

67+ , mtl

67 , regex-compat

68 , regex-compat

68 , scientific

69 , scientific

69 , singletons >= 2.2

70 , singletons >= 2.2

src/Data/Schematic.hs+3−1

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

2{-# LANGUAGE AllowAmbiguousTypes #-}

4module Data.Schematic

5− ( module Data.Schematic.Schema

5+ ( module Data.Schematic.JsonSchema

6+ , module Data.Schematic.Schema

6 , module Data.Schematic.Lens

7 , module Data.Schematic.Lens

7 , module Data.Schematic.Migration

8 , module Data.Schematic.Migration

8 , module Data.Schematic.Utils

9 , module Data.Schematic.Utils

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

26import Data.Aeson.Types as J

27import Data.Aeson.Types as J

27import Data.ByteString.Lazy as BL

28import Data.ByteString.Lazy as BL

28import Data.Functor.Identity

29import Data.Functor.Identity

30+import Data.Schematic.JsonSchema

29import Data.Schematic.Lens

31import Data.Schematic.Lens

30import Data.Schematic.Migration

32import Data.Schematic.Migration

31import Data.Schematic.Schema

33import Data.Schematic.Schema

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

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

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE OverloadedLabels #-}

5−module Data.Schematic.JsonSchema where

5+module Data.Schematic.JsonSchema

6+ ( toJsonSchema

7+ ) where

7−import Data.Aeson

9+import Control.Monad.State.Strict

10+import Data.Foldable

8−import qualified Data.Map as M

11+import Data.HashMap.Strict as H

12+import Data.List.NonEmpty

9−import Data.Schematic.Schema

13+import Data.Schematic.Schema as S

10−import Data.Singletons

14+import Data.Singletons

11−import Data.Text

15+import Data.Text

12−import qualified JSONSchema.Draft4.Schema as D4

16+import JSONSchema.Draft4.Schema as D4

17+import JSONSchema.Validator.Draft4 as D4

15draft4 :: Text

20draft4 :: Text

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

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

17−

22+

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

23+-- FIXME: implement all this later

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

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

20−-- { D4._schemaVersion = pure draft4

25+textConstraint (DTEq _) = pure ()

21−-- }

26+textConstraint (DTLt _) = pure ()

22−

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+

23−-- toJsonSchema

43+toJsonSchema

44+ :: forall proxy schema

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

45+ . SingI schema

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

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

26−-- -> D4.Schema

47+ -> D4.Schema

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

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

28−-- SchemaText tcs -> D4.emptySchema

49+ { _schemaVersion = pure draft4 }

29−-- SchemaNumber ncs -> D4.emptySchema

50+

30−-- SchemaObject ocs -> D4.emptySchema

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] }

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

71+ DSchemaNull -> emptySchema

32−-- SchemaNull -> D4.emptySchema

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

33−-- SchemaOptional sch -> D4.emptySchema

73+ DSchemaOptional sch -> emptySchema

34−

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

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 ->

src/Data/Schematic/Schema.hs+14

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

199

200data Schema

201 = SchemaText [TextConstraint]

202+ | SchemaBoolean

202 | SchemaNumber [NumberConstraint]

203 | SchemaNumber [NumberConstraint]

203 | SchemaObject [(Symbol, Schema)]

204 | SchemaObject [(Symbol, Schema)]

204 | SchemaArray [ArrayConstraint] Schema

205 | SchemaArray [ArrayConstraint] Schema

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

209data DemotedSchema

210data DemotedSchema

210 = DSchemaText [DemotedTextConstraint]

211 = DSchemaText [DemotedTextConstraint]

211 | DSchemaNumber [DemotedNumberConstraint]

212 | DSchemaNumber [DemotedNumberConstraint]

213+ | DSchemaBoolean

212 | DSchemaObject [(Text, DemotedSchema)]

214 | DSchemaObject [(Text, DemotedSchema)]

213 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

215 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

214 | DSchemaNull

216 | DSchemaNull

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

218data instance Sing (schema :: Schema) where

220data instance Sing (schema :: Schema) where

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

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

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

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

223+ SSchemaBoolean :: Sing 'SchemaBoolean

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

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

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

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

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

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

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

229 sing = SSchemaNumber sing

232 sing = SSchemaNumber sing

230instance SingI 'SchemaNull where

233instance SingI 'SchemaNull where

231 sing = SSchemaNull

234 sing = SSchemaNull

235+instance SingI 'SchemaBoolean where

236+ sing = SSchemaBoolean

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

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

233 sing = SSchemaArray sing sing

238 sing = SSchemaArray sing sing

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

248 fromSing = \case

254 fromSing = \case

249 SSchemaText cs -> DSchemaText $ fromSing cs

255 SSchemaText cs -> DSchemaText $ fromSing cs

250 SSchemaNumber cs -> DSchemaNumber $ fromSing cs

256 SSchemaNumber cs -> DSchemaNumber $ fromSing cs

257+ SSchemaBoolean -> DSchemaBoolean

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

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

252 SSchemaOptional s -> DSchemaOptional $ fromSing s

259 SSchemaOptional s -> DSchemaOptional $ fromSing s

253 SSchemaNull -> DSchemaNull

260 SSchemaNull -> DSchemaNull

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

262 SomeSing scs -> SomeSing $ SSchemaText scs

269 SomeSing scs -> SomeSing $ SSchemaText scs

263 DSchemaNumber cs -> case toSing cs of

270 DSchemaNumber cs -> case toSing cs of

264 SomeSing scs -> SomeSing $ SSchemaNumber scs

271 SomeSing scs -> SomeSing $ SSchemaNumber scs

272+ DSchemaBoolean -> SomeSing $ SSchemaBoolean

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

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

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

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

267 DSchemaOptional sch -> case toSing sch of

275 DSchemaOptional sch -> case toSing sch of

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

309data JsonRepr :: Schema -> Type where

317data JsonRepr :: Schema -> Type where

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

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

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

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

320+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean

312 ReprNull :: JsonRepr 'SchemaNull

321 ReprNull :: JsonRepr 'SchemaNull

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

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

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

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

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

383 parseJSON value = case sing :: Sing schema of

392 parseJSON value = case sing :: Sing schema of

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

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

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

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

395+ SSchemaBoolean -> ReprBoolean <$> parseJSON value

386 SSchemaNull -> case value of

396 SSchemaNull -> case value of

387 J.Null -> pure ReprNull

397 J.Null -> pure ReprNull

388 _ -> typeMismatch "Null" value

398 _ -> typeMismatch "Null" value

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

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

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

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

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

404 Nothing -> fail "schemanumber"

414 Nothing -> fail "schemanumber"

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

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

417+ Nothing -> fail "schemaboolean"

405 SSchemaNull -> case H.lookup fieldName h of

418 SSchemaNull -> case H.lookup fieldName h of

406 Just v -> FieldRepr <$> parseJSON v

419 Just v -> FieldRepr <$> parseJSON v

407 Nothing -> fail "schemanull"

420 Nothing -> fail "schemanull"

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

419

432

420instance J.ToJSON (JsonRepr a) where

433instance J.ToJSON (JsonRepr a) where

421 toJSON ReprNull = J.Null

434 toJSON ReprNull = J.Null

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

422 toJSON (ReprText t) = J.String t

436 toJSON (ReprText t) = J.String t

423 toJSON (ReprNumber n) = J.Number n

437 toJSON (ReprNumber n) = J.Number n

424 toJSON (ReprOptional s) = case s of

438 toJSON (ReprOptional s) = case s of

src/Data/Schematic/Validation.hs+1

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

178 process cs

179 process scs

180 ReprNull -> pure ()

181+ ReprBoolean _ -> pure ()

181 ReprArray v -> case sschema of

182 ReprArray v -> case sschema of

182 SSchemaArray acs s -> do

183 SSchemaArray acs s -> do

183 let

184 let