git.iko.soy/typeable/schematic
on master help sign in
add json ast validation
5943faaDenis Redozubov
schematic.cabal+8−1
compare with master
unifiedsplit
@@ -16,7 +16,8 @@ extra-source-files: ChangeLog.md
16cabal-version: >=1.10
16cabal-version: >=1.10
17
17
18library
18library
19− exposed-modules: Data.Schematic
19+ exposed-modules: Data.Aeson.Validation
20+ , Data.Schematic
20 , Data.Schematic.Schema
21 , Data.Schematic.Schema
21 , Data.Schematic.Validation
22 , Data.Schematic.Validation
22 -- ghc-options:
23 -- ghc-options:
@@ -51,11 +52,14 @@ library
51 , TypeSynonymInstances
52 , TypeSynonymInstances
52 , UndecidableInstances
53 , UndecidableInstances
53 build-depends: base >=4.9 && <4.10
54 build-depends: base >=4.9 && <4.10
55+ , aeson >= 1
54 , deriving-compat
56 , deriving-compat
55 , recursion-schemes
57 , recursion-schemes
56 , regex-compat
58 , regex-compat
57 , singletons
59 , singletons
58 , text
60 , text
61+ , unordered-containers
62+ , validationt >= 0.1.0.1
59 , vinyl
63 , vinyl
60 hs-source-dirs: src
64 hs-source-dirs: src
61 default-language: Haskell2010
65 default-language: Haskell2010
@@ -90,6 +94,7 @@ test-suite spec
90 , TypeOperators
94 , TypeOperators
91 , TypeSynonymInstances
95 , TypeSynonymInstances
92 build-depends: HUnit
96 build-depends: HUnit
97+ , aeson >= 1
93 , base >=4.9 && <4.10
98 , base >=4.9 && <4.10
94 , hspec >= 2.2.0
99 , hspec >= 2.2.0
95 , hspec-core
100 , hspec-core
@@ -98,5 +103,7 @@ test-suite spec
98 , regex-compat
103 , regex-compat
99 , schematic
104 , schematic
100 , text
105 , text
106+ , unordered-containers
107+ , validationt >= 0.1.0.1
101 , vinyl
108 , vinyl
102 other-modules: SchemaSpec
109 other-modules: SchemaSpec
src/Data/Aeson/Validation.hsnew file+85
@@ -0,0 +1,85 @@
1+module Data.Aeson.Validation where
2+
3+
4+import Control.Applicative
5+import Control.Monad
6+import Data.Aeson.Types as J
7+import Data.Foldable as F
8+import Data.Functor.Foldable
9+import Data.HashMap.Strict as H
10+import Data.Maybe
11+import Data.Proxy
12+import Data.Schematic.Schema (TopLevel, toSchema, JT, Schematic)
13+import Data.Schematic.Validation
14+import Data.Singletons
15+import Data.Singletons.Decide
16+import Data.Text as T
17+import Data.Traversable
18+
19+
20+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
21+(<&&>) = liftA2 (&&)
22+
23+infixl 3 <&&>
24+
25+validateConstraint
26+ :: SDecide JType
27+ => Sing jtype
28+ -> CRepr jtype
29+ -> Value
30+ -> Maybe Bool
31+validateConstraint s c = \case
32+ J.String t -> case s %~ SJText of
33+ Proved Refl -> pure $ case c of
34+ LengthEq n -> (== n) . fromIntegral . T.length $ t
35+ LengthLe n -> (<= n) . fromIntegral . T.length $ t
36+ LengthGt n -> (> n) . fromIntegral . T.length $ t
37+ Disproved _ -> mzero
38+ J.Number i -> case s %~ SJNumber of
39+ Proved Refl -> pure $ case c of
40+ Eq n -> i == fromIntegral n
41+ Le n -> i <= fromIntegral n
42+ Gt n -> i > fromIntegral n
43+ Disproved _ -> mzero
44+ J.Array v -> case s %~ SJArray of
45+ Proved Refl -> case c of
46+ LengthArrEq n -> pure . (== fromIntegral n) . F.length $ v
47+ Disproved _ -> Nothing
48+ J.Null -> Just True
49+ _ -> Just False
50+
51+validateConstraints
52+ :: SDecide JType
53+ => Sing jtype
54+ -> [CRepr jtype]
55+ -> Value
56+ -> Maybe Bool
57+validateConstraints s cs v = and <$> traverse alg cs
58+ where
59+ alg c = validateConstraint s c v
60+
61+validateJson
62+ :: (SDecide JType, TopLevel spec)
63+ => Proxy spec
64+ -> Value
65+ -> Maybe Bool
66+validateJson ps v = let s = toSchema ps in validateBySchema s v
67+
68+validateBySchema
69+ :: SDecide JType
70+ => Schema
71+ -> Value
72+ -> Maybe Bool
73+validateBySchema s v = case (unfix s, v) of
74+ (SchemaArray cs ss, jv@(J.Array v)) -> do
75+ itself <- validateConstraints SJArray cs jv
76+ content <- traverse (validateBySchema ss) v
77+ pure $ itself && and content
78+ (SchemaObject ocs, J.Object o) -> do
79+ fmap and $ for ocs $ \(fieldName, s) -> do
80+ val <- H.lookup (T.pack fieldName) o
81+ validateBySchema s val
82+ (SchemaText cs, js@(J.String _)) -> validateConstraints SJText cs js
83+ (SchemaNumber cs, jn@(J.Number _)) -> validateConstraints SJNumber cs jn
84+ (SchemaNull, J.Null) -> Just True
85+ _ -> Nothing
src/Data/Schematic/Schema.hs+19−20
@@ -15,6 +15,13 @@ import GHC.Generics
15import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
16
16
17
17
18+type family JT (s :: k) :: JType where
19+ JT (SNumber cs) = 'JNumber
20+ JT (SText cs) = 'JText
21+ JT (SObject els) = 'JObject
22+ JT (SArray cs s) = 'JArray
23+ JT (Field field ty cs) = JT ty
24+
18class Constrained (ty :: JType) c where
25class Constrained (ty :: JType) c where
19 cRep :: Proxy ty -> Proxy c -> CRepr ty
26 cRep :: Proxy ty -> Proxy c -> CRepr ty
20
27
@@ -90,40 +97,33 @@ instance SchemaConstructor 'JObject where
90 constructor _ = Fix . SchemaObject
97 constructor _ = Fix . SchemaObject
91
98
92class Schematic ty where
99class Schematic ty where
93− type JT (ty :: k) :: JType
94 build :: Proxy ty -> Schema
100 build :: Proxy ty -> Schema
95
101
96data SText cs
102data SText cs
97
103
98instance (Verifiable 'JText cs) => Schematic (SText cs) where
104instance (Verifiable 'JText cs) => Schematic (SText cs) where
99− type JT (SText cs) = 'JText
100 build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
105 build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
101
106
102data SNumber cs
107data SNumber cs
103
108
104instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
109instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
105− type JT (SNumber cs) = 'JNumber
106 build _ = constructor (Proxy @(JT (SNumber cs)))
110 build _ = constructor (Proxy @(JT (SNumber cs)))
107 $ schema (Proxy @'JNumber) (Proxy @cs)
111 $ schema (Proxy @'JNumber) (Proxy @cs)
108
112
109instance
113instance
110 ( Verifiable (JT ty) cs
114 ( Verifiable (JT ty) cs
111− , SchemaConstructor (JT ty) )
115+ , SchemaConstructor (JT ty))
112 => Schematic (Field field ty cs) where
116 => Schematic (Field field ty cs) where
113− type JT (Field field ty cs) = JT ty
114 build _ = constructor (Proxy @(JT (Field field ty cs)))
117 build _ = constructor (Proxy @(JT (Field field ty cs)))
115 $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
118 $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
116
119
117−data SObject typeName els
120+data SObject els
118
121
119instance
122instance
120− ( Verifiable 'JObject els
123+ ( Verifiable 'JObject els )
121− , KnownSymbol typeName )
122− => Schematic (SObject typeName els) where
124+ => Schematic (SObject els) where
123− type JT (SObject typeName els) = 'JObject
124 build _ =
125 build _ =
125− constructor (Proxy @(JT (SObject typeName els)))
126− $ schema (Proxy @(JT (SObject typeName els))) (Proxy @els)
126+ constructor (Proxy @'JObject) $ schema (Proxy @(JT (SObject els))) (Proxy @els)
127
127
128data SArray cs s
128data SArray cs s
129
129
@@ -131,22 +131,21 @@ instance
131 ( Schematic s
131 ( Schematic s
132 , Verifiable 'JArray cs )
132 , Verifiable 'JArray cs )
133 => Schematic (SArray cs s) where
133 => Schematic (SArray cs s) where
134− type JT (SArray cs s) = 'JArray
135 build _ =
134 build _ =
136 Fix $ SchemaArray
135 Fix $ SchemaArray
137 (schema (Proxy @'JArray) (Proxy @cs))
136 (schema (Proxy @'JArray) (Proxy @cs))
138 (build (Proxy @s))
137 (build (Proxy @s))
139
138
140-- | Shows it's top-level definition according to the json-schema
139-- | Shows it's top-level definition according to the json-schema
141−class TopLevel spec
140+class Schematic spec => TopLevel spec
142
141
143−instance Schematic (SObject els) => TopLevel (SObject els)
142+instance (Schematic (SObject els)) => TopLevel (SObject els)
144
143
145instance Schematic (SArray cs s) => TopLevel (SArray cs s)
144instance Schematic (SArray cs s) => TopLevel (SArray cs s)
146
145
147-- | TODO: abstract over objects and arrays
146-- | TODO: abstract over objects and arrays
148−-- toSchema
147+toSchema
149−-- :: forall els (e :: [k]). (e ~ '[], Verifiable (JT (SObject els)) e, Schematic (SObject els))
148+ :: forall spec. TopLevel spec
150−-- => Proxy (SObject els)
149+ => Proxy spec
151−-- -> Schema
150+ -> Schema
152−-- toSchema p = constructor p $ schema (Proxy @(JT (SObject els))) (Proxy @els)
151+toSchema = build
src/Data/Schematic/Validation.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Validation where
4+
5+import Control.Applicative
6+import Control.Category ((<<<), (>>>))
7+import Data.Eq.Deriving (deriveEq1)
8+import Data.Foldable as F
9+import Data.Functor.Classes
10+import Data.Functor.Foldable
11+import Data.Kind
12+import Data.Maybe
13+import Data.Singletons.Decide
14+import Data.Singletons.TH
15+import Data.Text as T
16+import Data.Vinyl hiding (Dict)
17+import Data.Vinyl.Functor
18+import Text.Show.Deriving (deriveShow1)
19+
20+
21+-- | Type Tags
22+data JType
23+ = JText
24+ | JNumber
25+ | JArray
26+ | JObject
27+ | JNull
28+ deriving (Show, Eq)
29+
30+genSingletons [ ''JType ]
31+
32+instance Show (Sing JText) where showsPrec 4 _ = showString "SJText"
33+instance Show (Sing JNumber) where showsPrec 4 _ = showString "SJNumber"
34+instance Show (Sing JArray) where showsPrec 4 _ = showString "SJArray"
35+instance Show (Sing JObject) where showsPrec 4 _ = showString "SJObject"
36+instance Show (Sing JNull) where showsPrec 4 _ = showString "SJNull"
37+
38+instance Eq (Sing JText) where (==) _ _ = True
39+instance Eq (Sing JNumber) where (==) _ _ = True
40+instance Eq (Sing JArray) where (==) _ _ = True
41+instance Eq (Sing JObject) where (==) _ _ = True
42+instance Eq (Sing JNull) where (==) _ _ = True
43+
44+type family CRepr (jty :: JType) :: Type where
45+ CRepr JText = TextConstraint
46+ CRepr JNumber = NumberConstraint
47+ CRepr JObject = (String, Schema)
48+ CRepr JArray = ArrayConstraint
49+
50+data TextConstraint
51+ = LengthEq Integer
52+ | LengthLe Integer
53+ | LengthGt Integer
54+ deriving (Show, Eq)
55+
56+data NumberConstraint
57+ = Le Integer
58+ | Gt Integer
59+ | Eq Integer
60+ deriving (Show, Eq)
61+
62+data ArrayConstraint
63+ = LengthArrEq Integer
64+ deriving (Show, Eq)
65+
66+type ObjectConstraint s = [(String, s)]
67+
68+data SchemaF s
69+ = SchemaText [TextConstraint]
70+ | SchemaNumber [NumberConstraint]
71+ | SchemaObject (ObjectConstraint s)
72+ | SchemaArray [ArrayConstraint] s
73+ | SchemaNull
74+ deriving (Functor)
75+
76+type Schema = Fix SchemaF
77+
78+deriveEq1 ''SchemaF
79+
80+deriveShow1 ''SchemaF
stack.yaml+4−2
@@ -36,9 +36,11 @@ resolver: lts-8.12
36# non-dependency (i.e. a user package), and its test suites and benchmarks
36# non-dependency (i.e. a user package), and its test suites and benchmarks
37# will not be run. This is useful for tweaking upstream packages.
37# will not be run. This is useful for tweaking upstream packages.
38packages:
38packages:
39+- location:
40+ git: https://github.com/typeable/validationt.git
41+ commit: 24578c9fd408179358c641ee1fff0eb182591f4b
39- '.'
42- '.'
40−# Dependency packages to be pulled from upstream that are not in the resolver
43+
41−# (e.g., acme-missiles-0.3)
42extra-deps: []
44extra-deps: []
43
45
44# Override default flag values for local packages and extra-deps
46# Override default flag values for local packages and extra-deps