git.iko.soy/schematic
on master help sign in
add json ast validation
commit5943faa9b867ab4c1832366a3086d2caf9335cc4 authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 17 May 2017, 18:13 (9 years ago) parentca48274
5 files changed+196−23
compare with master
unifiedsplit
schematic.cabal+8−1 src/Data/Aeson/Validation.hs+85 src/Data/Schematic/Schema.hs+19−20 src/Data/Schematic/Validation.hs+80 stack.yaml+4−2
schematic.cabal+8−1
@@ -16,7 +16,8 @@ extra-source-files: ChangeLog.md
1616cabal-version: >=1.10
1717
1818library
19− exposed-modules: Data.Schematic
19+ exposed-modules: Data.Aeson.Validation
20+ , Data.Schematic
2021 , Data.Schematic.Schema
2122 , Data.Schematic.Validation
2223 -- ghc-options:
@@ -51,11 +52,14 @@ library
5152 , TypeSynonymInstances
5253 , UndecidableInstances
5354 build-depends: base >=4.9 && <4.10
55+ , aeson >= 1
5456 , deriving-compat
5557 , recursion-schemes
5658 , regex-compat
5759 , singletons
5860 , text
61+ , unordered-containers
62+ , validationt >= 0.1.0.1
5963 , vinyl
6064 hs-source-dirs: src
6165 default-language: Haskell2010
@@ -90,6 +94,7 @@ test-suite spec
9094 , TypeOperators
9195 , TypeSynonymInstances
9296 build-depends: HUnit
97+ , aeson >= 1
9398 , base >=4.9 && <4.10
9499 , hspec >= 2.2.0
95100 , hspec-core
@@ -98,5 +103,7 @@ test-suite spec
98103 , regex-compat
99104 , schematic
100105 , text
106+ , unordered-containers
107+ , validationt >= 0.1.0.1
101108 , vinyl
102109 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
1515import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
1616
1717
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+
1825class Constrained (ty :: JType) c where
1926 cRep :: Proxy ty -> Proxy c -> CRepr ty
2027
@@ -90,40 +97,33 @@ instance SchemaConstructor 'JObject where
9097 constructor _ = Fix . SchemaObject
9198
9299class Schematic ty where
93− type JT (ty :: k) :: JType
94100 build :: Proxy ty -> Schema
95101
96102data SText cs
97103
98104instance (Verifiable 'JText cs) => Schematic (SText cs) where
99− type JT (SText cs) = 'JText
100105 build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
101106
102107data SNumber cs
103108
104109instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
105− type JT (SNumber cs) = 'JNumber
106110 build _ = constructor (Proxy @(JT (SNumber cs)))
107111 $ schema (Proxy @'JNumber) (Proxy @cs)
108112
109113instance
110114 ( Verifiable (JT ty) cs
111− , SchemaConstructor (JT ty) )
115+ , SchemaConstructor (JT ty))
112116 => Schematic (Field field ty cs) where
113− type JT (Field field ty cs) = JT ty
114117 build _ = constructor (Proxy @(JT (Field field ty cs)))
115118 $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
116119
117−data SObject typeName els
120+data SObject els
118121
119122instance
120− ( Verifiable 'JObject els
121− , KnownSymbol typeName )
122− => Schematic (SObject typeName els) where
123− type JT (SObject typeName els) = 'JObject
123+ ( Verifiable 'JObject els )
124+ => Schematic (SObject els) where
124125 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)
127127
128128data SArray cs s
129129
@@ -131,22 +131,21 @@ instance
131131 ( Schematic s
132132 , Verifiable 'JArray cs )
133133 => Schematic (SArray cs s) where
134− type JT (SArray cs s) = 'JArray
135134 build _ =
136135 Fix $ SchemaArray
137136 (schema (Proxy @'JArray) (Proxy @cs))
138137 (build (Proxy @s))
139138
140139-- | Shows it's top-level definition according to the json-schema
141−class TopLevel spec
140+class Schematic spec => TopLevel spec
142141
143−instance Schematic (SObject els) => TopLevel (SObject els)
142+instance (Schematic (SObject els)) => TopLevel (SObject els)
144143
145144instance Schematic (SArray cs s) => TopLevel (SArray cs s)
146145
147146-- | TODO: abstract over objects and arrays
148−-- toSchema
149−-- :: forall els (e :: [k]). (e ~ '[], Verifiable (JT (SObject els)) e, Schematic (SObject els))
150−-- => Proxy (SObject els)
151−-- -> Schema
152−-- toSchema p = constructor p $ schema (Proxy @(JT (SObject els))) (Proxy @els)
147+toSchema
148+ :: forall spec. TopLevel spec
149+ => Proxy spec
150+ -> Schema
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
3636# non-dependency (i.e. a user package), and its test suites and benchmarks
3737# will not be run. This is useful for tweaking upstream packages.
3838packages:
39+- location:
40+ git: https://github.com/typeable/validationt.git
41+ commit: 24578c9fd408179358c641ee1fff0eb182591f4b
3942- '.'
40−# Dependency packages to be pulled from upstream that are not in the resolver
41−# (e.g., acme-missiles-0.3)
43+
4244extra-deps: []
4345
4446# Override default flag values for local packages and extra-deps