master..7c6b2ec · typeable/schematic

git.iko.soy/typeable/schematic

9 files changed+50−67

unifiedsplit

ChangeLog.md−11 schematic.cabal+4−8 src/Data/Schematic/JsonSchema.hs+4−5 src/Data/Schematic/Path.hs+20−17 src/Data/Schematic/Validation.hs+10−11 stack-13.21.yaml−7 stack-13.7.yaml+5 stack.yaml+4−5 test/JsonSchemaSpec.hs+3−3

ChangeLog.md−11

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

11# Revision history for schematic

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−

143## 0.5.0.0 -- 2019-02-20

154

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

schematic.cabal+4−8

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

11name: schematic

2−version: 0.6.0.0

2+version: 0.5.0.0

33synopsis: JSON-biased spec and validation tool

44description: 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.

55license: BSD3

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

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

1111category: Data

1212build-type: Simple

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

13+extra-source-files: ChangeLog.md

1414cabal-version: >=1.10

1515

1616library

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

6565 , TypeOperators

6666 , TypeSynonymInstances

6767 , UndecidableInstances

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

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

6969 , bytestring

70− , aeson >= 1.4.3.0 && < 1.6

70+ , aeson >= 1

7171 , containers

7272 , hjsonschema

7373 , mtl

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

118118 , HelpersSpec

119119 , LensSpec

120120 , 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) =

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

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

4949 { _schemaMaximum = pure . fromIntegral $ n }

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

51− { _schemaMaximum = pure . fromIntegral $ n

52− , _schemaExclusiveMaximum = pure True }

50+numberConstraint (DNLt n) =

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

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

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

54− { _schemaMinimum = pure . fromIntegral $ n

55− , _schemaExclusiveMinimum = pure True }

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

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

5756 { _schemaMinimum = pure . fromIntegral $ n }

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

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

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

44import Data.Singletons.Prelude

55import Data.Singletons.TypeLits

66import Data.Text as T

7−import Data.Aeson.Internal

10−newtype JSONPathText = JSONPathText Text

11− deriving (Show)

12−

13−data PathSegment = PathKey Symbol | PathIx Nat

9+data PathSegment = Key Symbol | Ix Nat

1410

1511data instance Sing (jp :: PathSegment) where

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

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

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

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)

1821

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

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

2023demotePath = go []

2124 where

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

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

2326 go acc SNil = acc

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

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

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

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

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

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

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

2831

29−demotedPathToText :: JSONPath -> JSONPathText

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

32+demotedPathToText :: [DemotedPathSegment] -> JSONPath

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

3134 where

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

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

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

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

3437

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

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

3639pathToText = demotedPathToText . demotePath

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

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

33import Control.Monad

44import Control.Monad.Validation

55import Data.Aeson

6−import Data.Aeson.Internal

76import Data.Aeson.Types

87import Data.Foldable

98import Data.Functor.Identity

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

5049isValidationError _ = False

5150

5251validateTextConstraint

53− :: JSONPathText

52+ :: JSONPath

5453 -> Text

5554 -> Sing (tcs :: TextConstraint)

5655 -> Validation ()

57−validateTextConstraint (JSONPathText path) t = \case

56+validateTextConstraint (JSONPath path) t = \case

5857 STEq n -> do

5958 let

6059 nlen = withKnownNat n $ natVal n

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

107106 unless (matching ss) warn

108107

109108validateNumberConstraint

110− :: JSONPathText

109+ :: JSONPath

111110 -> Scientific

112111 -> Sing (tcs :: NumberConstraint)

113112 -> Validation ()

114−validateNumberConstraint (JSONPathText path) num = \case

113+validateNumberConstraint (JSONPath path) num = \case

115114 SNEq n -> do

116115 let

117116 nlen = withKnownNat n $ natVal n

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

149148 unless predicate warn

150149

151150validateArrayConstraint

152− :: JSONPathText

151+ :: JSONPath

153152 -> V.Vector a

154153 -> Sing (tcs :: ArrayConstraint)

155154 -> Validation ()

156−validateArrayConstraint (JSONPathText path) v = \case

155+validateArrayConstraint (JSONPath path) v = \case

157156 SAEq n -> do

158157 let

159158 nlen = withKnownNat n $ natVal n

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

192191

193192validateJsonRepr

194193 :: Sing schema

195− -> JSONPath

194+ -> [DemotedPathSegment]

196195 -> JsonRepr schema

197196 -> Validation ()

198197validateJsonRepr sschema dpath jr = case jr of

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

226225 process cs

227226 process acs

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

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

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

230229 validateJsonRepr s newPath jr'

231230 ReprOptional d -> case sschema of

232231 SSchemaOptional ss -> case d of

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

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

239238 go RNil = pure ()

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

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

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

242241 validateJsonRepr (knownFieldSchema f) newPath d

243242 go ftl

244243 ReprUnion _ -> pure () -- FIXME

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

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

251250 -- Just x -> do

252251 -- let

253− -- JSONPathText path = demotedPathToText dpath

252+ -- JSONPath path = demotedPathToText dpath

254253 -- case stl of

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

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

22extra-deps:

3−- hjsonpointer-1.4.0@rev:0

4−- hjsonschema-1.9.0@rev:0

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

6− commit: 97fea97c4015ab5e99f3efb2c73e1fef4b8857d8

3+ - hjsonpointer-1.4.0@rev:0

4+ - hjsonschema-1.9.0@rev:0

5+ - validationt-0.2.1.0

test/JsonSchemaSpec.hs+3−3

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

7676 let

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

7878 obj = withRepr @SchemaNumberExample $

79− field @"n1" 1.1

79+ field @"n1" 2

8080 :& field @"n2" 1

81− :& field @"n3" 0.9

82− :& field @"n4" 1.0

81+ :& field @"n3" 0

82+ :& field @"n4" 1

8383 :& RNil

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

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