9accf73 · typeable/schematic

git.iko.soy/typeable/schematic

on master help sign in

an attempt WIP

9accf73Denis Redozubov9 years ago

schematic.cabal+1

compare with master

unifiedsplit

@@ -71,6 +71,7 @@ library

71 , smallcheck

72 , tagged

73 , text

74+ , union

74 , unordered-containers

75 , unordered-containers

75 , validationt >= 0.1.0.1

76 , validationt >= 0.1.0.1

76 , vector

77 , vector

src/Data/Schematic/JsonSchema.hs+33−20

@@ -16,6 +16,7 @@ import Data.List.NonEmpty as NE

16import Data.Schematic.Schema as S

17import Data.Singletons

18import Data.Text

19+import Data.Traversable

19import JSONSchema.Draft4.Schema as D4

20import JSONSchema.Draft4.Schema as D4

20import JSONSchema.Validator.Draft4 as D4

21import JSONSchema.Validator.Draft4 as D4

@@ -62,31 +63,43 @@ toJsonSchema

62 :: forall proxy schema

63 :: forall proxy schema

63 . SingI schema

64 . SingI schema

64 => proxy (schema :: S.Schema)

65 => proxy (schema :: S.Schema)

65− -> D4.Schema

66+ -> Maybe D4.Schema

67+toJsonSchema _ = do

66−toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))

68+ js <- toJsonSchema' $ fromSing (sing :: Sing schema)

67− { _schemaVersion = pure draft4 }

69+ pure $ js { _schemaVersion = pure draft4 }

69toJsonSchema'

71toJsonSchema'

70 :: DemotedSchema

72 :: DemotedSchema

71− -> D4.Schema

73+ -> Maybe D4.Schema

72toJsonSchema' = \case

74toJsonSchema' = \case

73 DSchemaText tcs ->

75 DSchemaText tcs ->

74− execState (traverse_ textConstraint tcs) $ emptySchema

76+ pure $ execState (traverse_ textConstraint tcs) $ emptySchema

75 { _schemaType = pure $ TypeValidatorString D4.SchemaString }

77 { _schemaType = pure $ TypeValidatorString D4.SchemaString }

76 DSchemaNumber ncs ->

78 DSchemaNumber ncs ->

77− execState (traverse_ numberConstraint ncs) $ emptySchema

79+ pure $ execState (traverse_ numberConstraint ncs) $ emptySchema

78 { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }

80 { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }

79− DSchemaBoolean -> emptySchema

81+ DSchemaBoolean -> pure $ emptySchema

80− { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }

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

81− DSchemaObject objs -> emptySchema

83+ DSchemaObject objs -> do

84+ res <- for objs $ \(n,s) -> do

85+ s' <- toJsonSchema' s

86+ pure (n, s')

87+ pure $ emptySchema

82− { _schemaType = pure $ TypeValidatorString D4.SchemaObject

88+ { _schemaType = pure $ TypeValidatorString D4.SchemaObject

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

89+ , _schemaProperties = pure $ H.fromList res }

84− <$> objs }

85− DSchemaArray acs sch ->

90+ DSchemaArray acs sch -> do

91+ res <- toJsonSchema' sch

86− execState (traverse_ arrayConstraint acs) $ emptySchema

92+ pure $ execState (traverse_ arrayConstraint acs) $ emptySchema

87− { _schemaType = pure $ TypeValidatorString D4.SchemaArray

93+ { _schemaType = pure $ TypeValidatorString D4.SchemaArray

88− , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }

94+ , _schemaItems = pure $ ItemsArray [res] }

89− DSchemaNull -> emptySchema

95+ DSchemaNull -> pure $ emptySchema

90− { _schemaType = pure $ TypeValidatorString D4.SchemaNull }

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

91− DSchemaOptional sch -> emptySchema

97+ DSchemaOptional sch -> do

92− { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }

98+ snull <- toJsonSchema' DSchemaNull

99+ sres <- toJsonSchema' sch

100+ pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }

101+ DSchemaUnion sch -> do

102+ schemaUnion <- traverse toJsonSchema' sch >>= \case

103+ [] -> Nothing

104+ x -> Just x

105+ pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }

src/Data/Schematic/Schema.hs+46−8

@@ -5,7 +5,7 @@

6module Data.Schematic.Schema where

8−import Control.Applicative ()

8+import Control.Applicative ((<|>))

9import Control.Monad

10import Data.Aeson as J

11import Data.Aeson.Types as J

@@ -14,10 +14,11 @@ import Data.Kind

14import Data.Maybe

15import Data.Schematic.Instances ()

16import Data.Scientific

17−import Data.Singletons.Prelude.List hiding (All)

17+import Data.Singletons.Prelude.List hiding (All, Union)

18import Data.Singletons.TH

19import Data.Singletons.TypeLits

20import Data.Text as T

21+import Data.Union

21import Data.Vector as V

22import Data.Vector as V

22import Data.Vinyl hiding (Dict)

23import Data.Vinyl hiding (Dict)

23import qualified Data.Vinyl.TypeLevel as V

24import qualified Data.Vinyl.TypeLevel as V

@@ -205,6 +206,7 @@ data Schema

205 | SchemaArray [ArrayConstraint] Schema

206 | SchemaArray [ArrayConstraint] Schema

206 | SchemaNull

207 | SchemaNull

207 | SchemaOptional Schema

208 | SchemaOptional Schema

209+ | SchemaUnion [Schema]

208 deriving (Generic)

210 deriving (Generic)

209

211

210data DemotedSchema

212data DemotedSchema

@@ -215,6 +217,7 @@ data DemotedSchema

215 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

217 | DSchemaArray [DemotedArrayConstraint] DemotedSchema

216 | DSchemaNull

218 | DSchemaNull

217 | DSchemaOptional DemotedSchema

219 | DSchemaOptional DemotedSchema

220+ | DSchemaUnion [DemotedSchema]

218 deriving (Generic)

221 deriving (Generic)

219

222

220data instance Sing (schema :: Schema) where

223data instance Sing (schema :: Schema) where

@@ -225,6 +228,7 @@ data instance Sing (schema :: Schema) where

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

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

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

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

227 SSchemaNull :: Sing 'SchemaNull

230 SSchemaNull :: Sing 'SchemaNull

231+ SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)

228

232

229instance SingI sl => SingI ('SchemaText sl) where

233instance SingI sl => SingI ('SchemaText sl) where

230 sing = SSchemaText sing

234 sing = SSchemaText sing

@@ -240,6 +244,8 @@ instance SingI stl => SingI ('SchemaObject stl) where

240 sing = SSchemaObject sing

244 sing = SSchemaObject sing

241instance SingI s => SingI ('SchemaOptional s) where

245instance SingI s => SingI ('SchemaOptional s) where

242 sing = SSchemaOptional sing

246 sing = SSchemaOptional sing

247+instance SingI s => SingI ('SchemaUnion s) where

248+ sing = SSchemaUnion sing

243

249

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

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

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

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

@@ -248,6 +254,7 @@ instance Eq (Sing 'SchemaBoolean) where _ == _ = True

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

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

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

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

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

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

257+instance Eq (Sing ('SchemaUnion s)) where _ == _ = True

251

258

252instance SingKind Schema where

259instance SingKind Schema where

253 type Demote Schema = DemotedSchema

260 type Demote Schema = DemotedSchema

@@ -258,12 +265,8 @@ instance SingKind Schema where

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

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

259 SSchemaOptional s -> DSchemaOptional $ fromSing s

266 SSchemaOptional s -> DSchemaOptional $ fromSing s

260 SSchemaNull -> DSchemaNull

267 SSchemaNull -> DSchemaNull

261− SSchemaObject cs -> let

268+ SSchemaObject cs -> DSchemaObject $ fromSing cs

262− dem :: Sing (s :: [(Symbol, Schema)]) -> [(Text, DemotedSchema)]

269+ SSchemaUnion ss -> DSchemaUnion $ fromSing ss

263− dem SNil = []

264− dem (SCons (STuple2 ss ssch) fs) = withKnownSymbol ss

265− $ (T.pack (symbolVal ss), fromSing ssch) : dem fs

266− in DSchemaObject $ dem cs

267 toSing = \case

270 toSing = \case

268 DSchemaText cs -> case toSing cs of

271 DSchemaText cs -> case toSing cs of

269 SomeSing scs -> SomeSing $ SSchemaText scs

272 SomeSing scs -> SomeSing $ SSchemaText scs

@@ -277,6 +280,8 @@ instance SingKind Schema where

277 DSchemaNull -> SomeSing SSchemaNull

280 DSchemaNull -> SomeSing SSchemaNull

278 DSchemaObject cs -> case toSing cs of

281 DSchemaObject cs -> case toSing cs of

279 SomeSing scs -> SomeSing $ SSchemaObject scs

282 SomeSing scs -> SomeSing $ SSchemaObject scs

283+ DSchemaUnion ss -> case toSing ss of

284+ SomeSing sss -> SomeSing $ SSchemaUnion sss

280

285

281data FieldRepr :: (Symbol, Schema) -> Type where

286data FieldRepr :: (Symbol, Schema) -> Type where

282 FieldRepr

287 FieldRepr

@@ -322,6 +327,16 @@ data JsonRepr :: Schema -> Type where

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

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

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

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

324 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

329 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

330+ ReprUnion :: Union JsonRepr s -> JsonRepr ('SchemaUnion ss)

331+

332+-- | Move to the different package

333+type family UnionAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where

334+ UnionAll f '[] c = ()

335+ UnionAll f (r ': rs) c = (c (f r), UnionAll f rs c)

336+

337+-- instance (UnionAll f as Show) => Show (Union f as) where

338+-- show (This fa) = "This " P.++ show fa

339+-- show (That u) = "That " P.++ show u

325

340

326instance Show (JsonRepr ('SchemaText cs)) where

341instance Show (JsonRepr ('SchemaText cs)) where

327 show (ReprText t) = "ReprText " P.++ show t

342 show (ReprText t) = "ReprText " P.++ show t

@@ -340,6 +355,8 @@ instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

340instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

355instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

341 show (ReprOptional s) = "ReprOptional " P.++ show s

356 show (ReprOptional s) = "ReprOptional " P.++ show s

342

357

358+deriving instance UnionAll f as Show => Show (Union f as)

359+

343instance (Monad m, Serial m Text)

360instance (Monad m, Serial m Text)

344 => Serial m (JsonRepr ('SchemaText cs)) where

361 => Serial m (JsonRepr ('SchemaText cs)) where

345 series = cons1 ReprText

362 series = cons1 ReprText

@@ -388,6 +405,24 @@ fromOptional

388 -> Parser (Maybe (JsonRepr s))

405 -> Parser (Maybe (JsonRepr s))

389fromOptional _ = parseJSON

406fromOptional _ = parseJSON

390

407

408+parseUnion

409+ :: FromJSON (JsonRepr ('SchemaUnion ss))

410+ => sing (ss :: [Schema])

411+ -> Value

412+ -> Parser (JsonRepr ('SchemaUnion ss))

413+parseUnion _ val = parseJSON val

414+

415+instance FromJSON (Union JsonRepr '[]) where

416+ parseJSON = fail "empty union"

417+

418+instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where

419+ parseJSON val = (This <$> parseJSON val)

420+ <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))

421+

422+instance ToJSON (Union JsonRepr as) where

423+ toJSON (This fa) = toJSON fa

424+ toJSON (That u) = toJSON u

425+

391instance SingI schema => J.FromJSON (JsonRepr schema) where

426instance SingI schema => J.FromJSON (JsonRepr schema) where

392 parseJSON value = case sing :: Sing schema of

427 parseJSON value = case sing :: Sing schema of

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

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

@@ -427,8 +462,10 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

427 SSchemaOptional so -> case H.lookup fieldName h of

462 SSchemaOptional so -> case H.lookup fieldName h of

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

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

429 Nothing -> fail "schemaoptional"

464 Nothing -> fail "schemaoptional"

465+ SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value

430 (fieldRepr :&) <$> demoteFields tl h

466 (fieldRepr :&) <$> demoteFields tl h

431 ReprObject <$> withObject "Object" (demoteFields fs) value

467 ReprObject <$> withObject "Object" (demoteFields fs) value

468+ SSchemaUnion ss -> parseUnion ss value

432

469

433instance J.ToJSON (JsonRepr a) where

470instance J.ToJSON (JsonRepr a) where

434 toJSON ReprNull = J.Null

471 toJSON ReprNull = J.Null

@@ -449,6 +486,7 @@ instance J.ToJSON (JsonRepr a) where

449 fold = \case

486 fold = \case

450 RNil -> []

487 RNil -> []

451 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

488 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

489+ toJSON (ReprUnion u) = toJSON u

452

490

453class FalseConstraint a

491class FalseConstraint a

454

492

src/Data/Schematic/Validation.hs+9−1

@@ -13,6 +13,7 @@ import Data.Singletons.Prelude

13import Data.Singletons.TypeLits

14import Data.Text as T

15import Data.Traversable

16+import Data.Union

16import Data.Vector as V

17import Data.Vector as V

17import Data.Vinyl

18import Data.Vinyl

18import Prelude as P

19import Prelude as P

@@ -199,9 +200,16 @@ validateJsonRepr sschema dpath jr = case jr of

199 ReprObject fs -> case sschema of

200 ReprObject fs -> case sschema of

200 SSchemaObject _ -> go fs

201 SSchemaObject _ -> go fs

201 where

202 where

202− go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()

203+ go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()

203 go RNil = pure ()

204 go RNil = pure ()

204 go (f@(FieldRepr d) :& ftl) = do

205 go (f@(FieldRepr d) :& ftl) = do

205 let newPath = dpath <> [DKey (knownFieldName f)]

206 let newPath = dpath <> [DKey (knownFieldName f)]

206 validateJsonRepr (knownFieldSchema f) newPath d

207 validateJsonRepr (knownFieldSchema f) newPath d

207 go ftl

208 go ftl

209+ ReprUnion u -> case sschema of

210+ SSchemaUnion ss -> case ss of

211+ SNil -> vWarning $ mmSingleton (demotedPathToText dpath)

212+ $ pure "union handling error, please report this as bug"

213+ SCons s stl -> case u of

214+ This x -> validateJsonRepr s dpath x

215+ That u' -> validateJsonRepr (SSchemaUnion ss) dpath (ReprUnion u')

test/JsonSchemaSpec.hs+2−1

@@ -1,6 +1,7 @@

1module JsonSchemaSpec (spec, main) where

3import Data.Aeson as J

4+import Data.Maybe

4import Data.Proxy

5import Data.Proxy

5import Data.Schematic

6import Data.Schematic

6import Data.Vinyl

7import Data.Vinyl

@@ -34,7 +35,7 @@ exampleData = ReprObject objectData

34spec :: Spec

35spec :: Spec

35spec = do

36spec = do

36 it "validates simple schema" $ do

37 it "validates simple schema" $ do

37− let schema = D4.SchemaWithURI (toJsonSchema (Proxy @SchemaExample)) Nothing

38+ let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing

38 fetchHTTPAndValidate schema (toJSON exampleData) >>= \case

39 fetchHTTPAndValidate schema (toJSON exampleData) >>= \case

39 Left _ -> fail "failed to validate test example"

40 Left _ -> fail "failed to validate test example"

40 Right _ -> pure ()

41 Right _ -> pure ()