master..280ea5d · typeable/schematic

ChangeLog.md−11

since splitsnapshots

unifiedsplit

@@ -1,16 +1,5 @@

1# Revision history for schematic

2

3−## 0.6.0.0 -- 2021-01-15

4−

5−Added compatability with aeson-1.4.3.0. Since version 1.4.3 the module `Data.Aeson` started exporting `JSONPath`, which was conflicting with our own `JSONPath`. Furthermore, started using `JSONPathElement` from `aeson` instead of `DemotedPathSegment`.

6−

7−## 0.5.1.0 -- 2021-01-15

8−

9−Fix the generation of json schema for numbers.

10−Add array constraints.

11−Fix the generation of text and number constraints.

12−Remove jsonpath from the error message.

13−

14## 0.5.0.0 -- 2019-02-20

3## 0.5.0.0 -- 2019-02-20

15

4

16GHC 8.6, json generation by schema definition, validation bug fixes, better

5GHC 8.6, json generation by schema definition, validation bug fixes, better

schematic.cabal+4−8

@@ -1,5 +1,5 @@

1name: schematic

2−version: 0.6.0.0

2+version: 0.5.0.0

3synopsis: JSON-biased spec and validation tool

4description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support.

5license: BSD3

@@ -10,7 +10,7 @@ homepage: http://github.com/typeable/schematic

10Bug-reports: http://github.com/typeable/schematic/issues/

11category: Data

12build-type: Simple

13−extra-source-files: ChangeLog.md, README.md

13+extra-source-files: ChangeLog.md

14cabal-version: >=1.10

15

16library

@@ -65,9 +65,9 @@ library

65 , TypeOperators

66 , TypeSynonymInstances

67 , UndecidableInstances

68− build-depends: base >=4.11 && <5

68+ build-depends: base >=4.11 && <4.13

69 , bytestring

70− , aeson >= 1.4.3.0 && < 1.6

70+ , aeson >= 1

71 , containers

72 , hjsonschema

73 , mtl

@@ -118,7 +118,3 @@ test-suite spec

118 , HelpersSpec

119 , LensSpec

120 , JsonSchemaSpec

121−

122−source-repository head

123− type: git

124− location: https://github.com/typeable/schematic

src/Data/Schematic/JsonSchema.hs+4−5

@@ -47,12 +47,11 @@ textConstraint (DTEnum ss) =

47numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()

48numberConstraint (DNLe n) = modify $ \s -> s

49 { _schemaMaximum = pure . fromIntegral $ n }

50−numberConstraint (DNLt n) = modify $ \s -> s

50+numberConstraint (DNLt n) =

51+ let n' = if n == 0 then 0 else n - 1

51− { _schemaMaximum = pure . fromIntegral $ n

52+ in modify $ \s -> s { _schemaMaximum = pure . fromIntegral $ n' }

52− , _schemaExclusiveMaximum = pure True }

53numberConstraint (DNGt n) = modify $ \s -> s

54− { _schemaMinimum = pure . fromIntegral $ n

54+ { _schemaMinimum = pure . fromIntegral $ n + 1 }

55− , _schemaExclusiveMinimum = pure True }

56numberConstraint (DNGe n) = modify $ \s -> s

55numberConstraint (DNGe n) = modify $ \s -> s

57 { _schemaMinimum = pure . fromIntegral $ n }

56 { _schemaMinimum = pure . fromIntegral $ n }

58numberConstraint (DNEq n) = modify $ \s -> s

57numberConstraint (DNEq n) = modify $ \s -> s

src/Data/Schematic/Path.hs+20−17

@@ -4,33 +4,36 @@ import Data.Foldable as F

4import Data.Singletons.Prelude

5import Data.Singletons.TypeLits

6import Data.Text as T

7−import Data.Aeson.Internal

8

7

9

8

10−newtype JSONPathText = JSONPathText Text

11− deriving (Show)

12−

13−data PathSegment = PathKey Symbol | PathIx Nat

9+data PathSegment = Key Symbol | Ix Nat

14

10

15data instance Sing (jp :: PathSegment) where

11data instance Sing (jp :: PathSegment) where

16− SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('PathKey k)

12+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)

17− SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('PathIx n)

13+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)

14+

15+data DemotedPathSegment = DKey Text | DIx Integer

16+ deriving (Show)

17+

18+-- | Textual representation of json path.

19+newtype JSONPath = JSONPath Text

20+ deriving (Show)

18

21

19−demotePath :: Sing (ps :: [PathSegment]) -> JSONPath

22+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]

20demotePath = go []

23demotePath = go []

21 where

24 where

22− go :: JSONPath -> Sing (ps :: [PathSegment]) -> JSONPath

25+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]

23 go acc SNil = acc

26 go acc SNil = acc

24 go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps

27 go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps

25− demotePathSeg :: Sing (ps :: PathSegment) -> JSONPathElement

28+ demotePathSeg :: Sing (ps :: PathSegment) -> DemotedPathSegment

26− demotePathSeg (SKey s) = Key $ T.pack $ withKnownSymbol s $ symbolVal s

29+ demotePathSeg (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s

27− demotePathSeg (SIx n) = Index $ withKnownNat n $ fromIntegral $ natVal n

30+ demotePathSeg (SIx n) = DIx $ withKnownNat n $ fromIntegral $ natVal n

28

31

29−demotedPathToText :: JSONPath -> JSONPathText

32+demotedPathToText :: [DemotedPathSegment] -> JSONPath

30−demotedPathToText = JSONPathText . F.foldl' renderPathSegment ""

33+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""

31 where

34 where

32− renderPathSegment acc (Key t) = acc <> "." <> t

35+ renderPathSegment acc (DKey t) = acc <> "." <> t

33− renderPathSegment acc (Index n) = acc <> "[" <> T.pack (show n) <> "]"

36+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"

34

37

35−pathToText :: Sing (ps :: [PathSegment]) -> JSONPathText

38+pathToText :: Sing (ps :: [PathSegment]) -> JSONPath

36pathToText = demotedPathToText . demotePath

39pathToText = demotedPathToText . demotePath

src/Data/Schematic/Validation.hs+10−11

@@ -3,7 +3,6 @@ module Data.Schematic.Validation where

3import Control.Monad

4import Control.Monad.Validation

5import Data.Aeson

6−import Data.Aeson.Internal

7import Data.Aeson.Types

6import Data.Aeson.Types

8import Data.Foldable

7import Data.Foldable

9import Data.Functor.Identity

8import Data.Functor.Identity

@@ -50,11 +49,11 @@ isValidationError (ValidationError _) = True

50isValidationError _ = False

49isValidationError _ = False

51

50

52validateTextConstraint

51validateTextConstraint

53− :: JSONPathText

52+ :: JSONPath

54 -> Text

53 -> Text

55 -> Sing (tcs :: TextConstraint)

54 -> Sing (tcs :: TextConstraint)

56 -> Validation ()

55 -> Validation ()

57−validateTextConstraint (JSONPathText path) t = \case

56+validateTextConstraint (JSONPath path) t = \case

58 STEq n -> do

57 STEq n -> do

59 let

58 let

60 nlen = withKnownNat n $ natVal n

59 nlen = withKnownNat n $ natVal n

@@ -107,11 +106,11 @@ validateTextConstraint (JSONPathText path) t = \case

107 unless (matching ss) warn

106 unless (matching ss) warn

108

107

109validateNumberConstraint

108validateNumberConstraint

110− :: JSONPathText

109+ :: JSONPath

111 -> Scientific

110 -> Scientific

112 -> Sing (tcs :: NumberConstraint)

111 -> Sing (tcs :: NumberConstraint)

113 -> Validation ()

112 -> Validation ()

114−validateNumberConstraint (JSONPathText path) num = \case

113+validateNumberConstraint (JSONPath path) num = \case

115 SNEq n -> do

114 SNEq n -> do

116 let

115 let

117 nlen = withKnownNat n $ natVal n

116 nlen = withKnownNat n $ natVal n

@@ -149,11 +148,11 @@ validateNumberConstraint (JSONPathText path) num = \case

149 unless predicate warn

148 unless predicate warn

150

149

151validateArrayConstraint

150validateArrayConstraint

152− :: JSONPathText

151+ :: JSONPath

153 -> V.Vector a

152 -> V.Vector a

154 -> Sing (tcs :: ArrayConstraint)

153 -> Sing (tcs :: ArrayConstraint)

155 -> Validation ()

154 -> Validation ()

156−validateArrayConstraint (JSONPathText path) v = \case

155+validateArrayConstraint (JSONPath path) v = \case

157 SAEq n -> do

156 SAEq n -> do

158 let

157 let

159 nlen = withKnownNat n $ natVal n

158 nlen = withKnownNat n $ natVal n

@@ -192,7 +191,7 @@ validateArrayConstraint (JSONPathText path) v = \case

192

191

193validateJsonRepr

192validateJsonRepr

194 :: Sing schema

193 :: Sing schema

195− -> JSONPath

194+ -> [DemotedPathSegment]

196 -> JsonRepr schema

195 -> JsonRepr schema

197 -> Validation ()

196 -> Validation ()

198validateJsonRepr sschema dpath jr = case jr of

197validateJsonRepr sschema dpath jr = case jr of

@@ -226,7 +225,7 @@ validateJsonRepr sschema dpath jr = case jr of

226 process cs

225 process cs

227 process acs

226 process acs

228 for_ (V.indexed v) $ \(ix, jr') -> do

227 for_ (V.indexed v) $ \(ix, jr') -> do

229− let newPath = dpath <> pure (Index $ fromIntegral ix)

228+ let newPath = dpath <> pure (DIx $ fromIntegral ix)

230 validateJsonRepr s newPath jr'

229 validateJsonRepr s newPath jr'

231 ReprOptional d -> case sschema of

230 ReprOptional d -> case sschema of

232 SSchemaOptional ss -> case d of

231 SSchemaOptional ss -> case d of

@@ -238,7 +237,7 @@ validateJsonRepr sschema dpath jr = case jr of

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

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

239 go RNil = pure ()

238 go RNil = pure ()

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

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

241− let newPath = dpath <> [Key (knownFieldName f)]

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

242 validateJsonRepr (knownFieldSchema f) newPath d

241 validateJsonRepr (knownFieldSchema f) newPath d

243 go ftl

242 go ftl

244 ReprUnion _ -> pure () -- FIXME

243 ReprUnion _ -> pure () -- FIXME

@@ -250,7 +249,7 @@ validateJsonRepr sschema dpath jr = case jr of

250 -- fail "impossible to produce subUnion, please report this as a bug"

249 -- fail "impossible to produce subUnion, please report this as a bug"

251 -- Just x -> do

250 -- Just x -> do

252 -- let

251 -- let

253− -- JSONPathText path = demotedPathToText dpath

252+ -- JSONPath path = demotedPathToText dpath

254 -- case stl of

253 -- case stl of

255 -- SNil -> void $ vWarning $ mmSingleton path

254 -- SNil -> void $ vWarning $ mmSingleton path

256 -- $ pure "union handling error, please report this as bug"

255 -- $ pure "union handling error, please report this as bug"

stack-13.21.yamldeleted−7

@@ -1,7 +0,0 @@

1−resolver: lts-13.21

2−extra-deps:

3− - hjsonpointer-1.4.0@rev:0

4− - hjsonschema-1.9.0@rev:0

5− - validationt-0.3.0

6−nix:

7− packages: [pcre, pkg-config, zlib]

stack-13.7.yamlnew file+5

@@ -0,0 +1,5 @@

1+resolver: lts-13.7

2+extra-deps:

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.2.1.0

stack.yaml+4−5

@@ -1,6 +1,5 @@

1−resolver: lts-14.22

1+resolver: lts-12.0

2extra-deps:

3−- hjsonpointer-1.4.0@rev:0

3+ - hjsonpointer-1.4.0@rev:0

4−- hjsonschema-1.9.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5−- git: https://github.com/typeable/validationt.git

5+ - validationt-0.2.1.0

6− commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8

test/JsonSchemaSpec.hs+3−3

@@ -76,10 +76,10 @@ spec = do

76 let

77 schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaNumberExample)) Nothing

78 obj = withRepr @SchemaNumberExample $

79− field @"n1" 1.1

79+ field @"n1" 2

80 :& field @"n2" 1

81− :& field @"n3" 0.9

81+ :& field @"n3" 0

82− :& field @"n4" 1.0

82+ :& field @"n4" 1

83 :& RNil

84 fetchHTTPAndValidate schema (toJSON obj) >>= \case

85 Left e -> fail "failed to validate test example"