git.iko.soy/schematic
on master help sign in
Runtime validations
commita619dab44a43e2574042c626134ec95326cbfe35 authorDenis Redozubov <denis.redozubov@gmail.com> dateTue 23 May 2017, 17:27 (9 years ago) parent252e752
4 files changed+267−35
compare with master
unifiedsplit
src/Data/Schematic.hs+24 src/Data/Schematic/Path.hs+27−7 src/Data/Schematic/Schema.hs+51−28 src/Data/Schematic/Validation.hs+165
src/Data/Schematic.hs+24
@@ -1,7 +1,31 @@
11module Data.Schematic
22 ( module Data.Schematic.Schema
33 , module Data.Schematic.Utils
4+ , parseAndValidateJson
45 ) where
56
7+import Control.Monad.Validation
8+import Data.Aeson as J
9+import Data.Aeson.Types as J
10+import Data.Functor.Identity
611import Data.Schematic.Schema
712import Data.Schematic.Utils
13+import Data.Schematic.Validation
14+import Data.Text as T
15+
16+
17+parseAndValidateJson
18+ :: forall schema
19+ . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema))
20+ => J.Value
21+ -> ParseResult (JsonRepr schema)
22+parseAndValidateJson v =
23+ case parseEither parseJSON v of
24+ Left s -> DecodingError $ T.pack s
25+ Right jsonRepr ->
26+ let
27+ validate = validateJsonRepr (known :: Sing schema) [] jsonRepr
28+ res = runIdentity . runValidationTEither $ validate
29+ in case res of
30+ Left em -> ValidationError em
31+ Right () -> Valid jsonRepr
src/Data/Schematic/Path.hs+27−7
@@ -1,9 +1,11 @@
11module Data.Schematic.Path where
22
3−import Data.Singletons
4−import Data.Singletons.TypeLits
3+import Data.Foldable as F
4+import Data.Monoid
55import Data.Schematic.Utils
6+import Data.Singletons
67import Data.Singletons.Prelude
8+import Data.Singletons.TypeLits
79import Data.Text as T
810
911
@@ -21,10 +23,28 @@ instance (KnownNat n, Known (Sing n))
2123 => Known (Sing ('Ix n)) where
2224 known = SIx known
2325
24−pathToText :: Sing (ps :: [PathSegment]) -> Text
25−pathToText = T.pack . go ""
26+data DemotedPathSegment = DKey Text | DIx Integer
27+ deriving (Show)
28+
29+-- | Textual representation of json path.
30+newtype JSONPath = JSONPath Text
31+ deriving (Show)
32+
33+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
34+demotePath = go []
2635 where
27− go :: String -> Sing (ps :: [PathSegment]) -> String
36+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
2837 go acc SNil = acc
29− go acc (SCons (SKey k) tl) = go (acc ++ "." ++ symbolVal k) tl
30− go acc (SCons (SIx n) tl) = go (acc ++ "[" ++ show (natVal n) ++ "]") tl
38+ go acc (SCons p ps) = go (acc ++ [demote p]) ps
39+ demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
40+ demote (SKey s) = DKey $ T.pack $ symbolVal s
41+ demote (SIx n) = DIx $ natVal n
42+
43+demotedPathToText :: [DemotedPathSegment] -> JSONPath
44+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
45+ where
46+ renderPathSegment acc (DKey t) = acc <> "." <> t
47+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"
48+
49+pathToText :: Sing (ps :: [PathSegment]) -> JSONPath
50+pathToText = demotedPathToText . demotePath
src/Data/Schematic/Schema.hs+51−28
@@ -15,7 +15,7 @@ import Data.Maybe
1515import Data.Schematic.Instances ()
1616import Data.Schematic.Utils
1717import Data.Scientific
18−import Data.Singletons.Prelude.List
18+import Data.Singletons.Prelude.List hiding (All)
1919import Data.Singletons.TH
2020import Data.Singletons.TypeLits
2121import Data.Text as T
@@ -27,6 +27,10 @@ import Prelude as P
2727import Test.SmallCheck.Series
2828
2929
30+type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
31+ All c '[] = ()
32+ All c (a ': as) = (c a, All c as)
33+
3034type family CRepr (s :: Schema) :: Type where
3135 CRepr ('SchemaText cs) = TextConstraint
3236 CRepr ('SchemaNumber cs) = NumberConstraint
@@ -38,22 +42,27 @@ data TextConstraint
3842 | TLe Nat
3943 | TGt Nat
4044 | TRegex Symbol
45+ | TEnum [Symbol]
4146 deriving (Generic)
4247
4348data instance Sing (tc :: TextConstraint) where
44− STEq :: Sing n -> Sing ('TEq n)
45− STLe :: Sing n -> Sing ('TLe n)
46− STGt :: Sing n -> Sing ('TGt n)
47− STRegex :: Sing s -> Sing ('TRegex s)
48−
49−instance Known (Sing n) => Known (Sing ('TEq n)) where known = STEq known
50−instance Known (Sing n) => Known (Sing ('TGt n)) where known = STGt known
51−instance Known (Sing n) => Known (Sing ('TLe n)) where known = STLe known
52−instance Known (Sing s) => Known (Sing ('TRegex s)) where known = STRegex known
49+ STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)
50+ STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)
51+ STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)
52+ STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s)
53+ STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)
54+
55+instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known
56+instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known
57+instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known
58+instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known
59+instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known
5360
5461instance Eq (Sing ('TEq n)) where _ == _ = True
5562instance Eq (Sing ('TLe n)) where _ == _ = True
5663instance Eq (Sing ('TGt n)) where _ == _ = True
64+instance Eq (Sing ('TRegex t)) where _ == _ = True
65+instance Eq (Sing ('TEnum ss)) where _ == _ = True
5766
5867data NumberConstraint
5968 = NLe Nat
@@ -62,13 +71,13 @@ data NumberConstraint
6271 deriving (Generic)
6372
6473data instance Sing (nc :: NumberConstraint) where
65− SNEq :: Sing n -> Sing ('NEq n)
66− SNGt :: Sing n -> Sing ('NGt n)
67− SNLe :: Sing n -> Sing ('NLe n)
74+ SNEq :: KnownNat n => Sing n -> Sing ('NEq n)
75+ SNGt :: KnownNat n => Sing n -> Sing ('NGt n)
76+ SNLe :: KnownNat n => Sing n -> Sing ('NLe n)
6877
69−instance Known (Sing n) => Known (Sing ('NEq n)) where known = SNEq known
70−instance Known (Sing n) => Known (Sing ('NGt n)) where known = SNGt known
71−instance Known (Sing n) => Known (Sing ('NLe n)) where known = SNLe known
78+instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known
79+instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known
80+instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known
7281
7382instance Eq (Sing ('NEq n)) where _ == _ = True
7483instance Eq (Sing ('NLe n)) where _ == _ = True
@@ -79,9 +88,9 @@ data ArrayConstraint
7988 deriving (Generic)
8089
8190data instance Sing (ac :: ArrayConstraint) where
82− SAEq :: Sing n -> Sing ('AEq n)
91+ SAEq :: KnownNat n => Sing n -> Sing ('AEq n)
8392
84−instance Known (Sing n) => Known (Sing ('AEq n)) where known = SAEq known
93+instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known
8594
8695instance Eq (Sing ('AEq n)) where _ == _ = True
8796
@@ -123,11 +132,24 @@ instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
123132instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
124133
125134data FieldRepr :: (Symbol, Schema) -> Type where
126− FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
127−
128−type family MapSnd (cs :: [(Symbol, Schema)]) :: [Schema] where
129− MapSnd '[] = '[]
130− MapSnd ( '(fn, schema) ': as) = schema ': MapSnd as
135+ FieldRepr
136+ :: (Known (Sing schema), KnownSymbol name)
137+ => JsonRepr schema
138+ -> FieldRepr '(name, schema)
139+
140+knownFieldName
141+ :: forall proxy (fieldName :: Symbol) schema
142+ . KnownSymbol fieldName
143+ => proxy '(fieldName, schema)
144+ -> Text
145+knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName)
146+
147+knownFieldSchema
148+ :: forall proxy fieldName schema
149+ . Known (Sing schema)
150+ => proxy '(fieldName, schema)
151+ -> Sing schema
152+knownFieldSchema _ = known
131153
132154deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
133155
@@ -136,6 +158,7 @@ instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
136158
137159instance
138160 ( KnownSymbol name
161+ , Known (Sing schema)
139162 , Serial m (JsonRepr schema) )
140163 => Serial m (FieldRepr '(name, schema)) where
141164 series = FieldRepr <$> series
@@ -269,9 +292,9 @@ instance J.ToJSON (JsonRepr a) where
269292 RNil -> []
270293 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
271294
272−class FalseConstraint
295+class FalseConstraint a
273296
274−type family TopLevel (spec :: Schema) :: Constraint where
275− TopLevel ('SchemaArray a e) = ()
276− TopLevel ('SchemaObject o) = ()
277− TopLevel spec = FalseConstraint
297+type family TopLevel (schema :: Schema) :: Constraint where
298+ TopLevel ('SchemaArray acs s) = ()
299+ TopLevel ('SchemaObject o) = ()
300+ TopLevel spec = FalseConstraint spec
src/Data/Schematic/Validation.hsnew file+165
@@ -0,0 +1,165 @@
1+module Data.Schematic.Validation where
2+
3+import Control.Monad
4+import Control.Monad.Validation
5+import Data.Foldable
6+import Data.Functor.Identity
7+import Data.Monoid
8+import Data.Schematic.Path
9+import Data.Schematic.Schema
10+import Data.Schematic.Utils ()
11+import Data.Scientific
12+import Data.Singletons.Prelude
13+import Data.Singletons.TypeLits
14+import Data.Text as T
15+import Data.Vector as V
16+import Data.Vinyl
17+import Prelude as P
18+import Text.Regex
19+
20+
21+type Validation a = ValidationT ErrorMap Identity a
22+
23+type ErrorMap = MonoidMap Text [Text]
24+
25+data ParseResult a
26+ = Valid a
27+ | DecodingError Text
28+ | ValidationError ErrorMap
29+ deriving (Show, Eq, Functor)
30+
31+validateTextConstraint
32+ :: JSONPath
33+ -> Text
34+ -> Sing (tcs :: TextConstraint)
35+ -> Validation ()
36+validateTextConstraint (JSONPath path) t = \case
37+ STEq n -> do
38+ let
39+ nlen = natVal n
40+ predicate = nlen == (fromIntegral $ T.length t)
41+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
42+ warn = vWarning $ mmSingleton path (pure errMsg)
43+ unless predicate warn
44+ STLe n -> do
45+ let
46+ nlen = natVal n
47+ predicate = nlen <= (fromIntegral $ T.length t)
48+ errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
49+ warn = vWarning $ mmSingleton path (pure errMsg)
50+ unless predicate warn
51+ STGt n -> do
52+ let
53+ nlen = natVal n
54+ predicate = nlen > (fromIntegral $ T.length t)
55+ errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
56+ warn = vWarning $ mmSingleton path (pure errMsg)
57+ unless predicate warn
58+ STRegex r -> do
59+ let
60+ regex = symbolVal r
61+ predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
62+ errMsg = path <> " must match " <> T.pack (show regex)
63+ warn = vWarning $ mmSingleton path (pure errMsg)
64+ unless predicate warn
65+ STEnum ss -> do
66+ let
67+ matching :: Sing (s :: [Symbol]) -> Bool
68+ matching SNil = False
69+ matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
70+ errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
71+ warn = vWarning $ mmSingleton path (pure errMsg)
72+ unless (matching ss) warn
73+
74+validateNumberConstraint
75+ :: JSONPath
76+ -> Scientific
77+ -> Sing (tcs :: NumberConstraint)
78+ -> Validation ()
79+validateNumberConstraint (JSONPath path) num = \case
80+ SNEq n -> do
81+ let
82+ nlen = natVal n
83+ predicate = fromIntegral nlen == num
84+ errMsg = path <> " should be == " <> T.pack (show nlen)
85+ warn = vWarning $ mmSingleton path (pure errMsg)
86+ unless predicate warn
87+ SNGt n -> do
88+ let
89+ nlen = natVal n
90+ predicate = num > fromIntegral nlen
91+ errMsg = path <> " should be > " <> T.pack (show nlen)
92+ warn = vWarning $ mmSingleton path (pure errMsg)
93+ unless predicate warn
94+ SNLe n -> do
95+ let
96+ nlen = natVal n
97+ predicate = fromIntegral nlen <= num
98+ errMsg = path <> " should be <= " <> T.pack (show nlen)
99+ warn = vWarning $ mmSingleton path (pure errMsg)
100+ unless predicate warn
101+
102+validateArrayConstraint
103+ :: JSONPath
104+ -> V.Vector a
105+ -> Sing (tcs :: ArrayConstraint)
106+ -> Validation ()
107+validateArrayConstraint (JSONPath path) v = \case
108+ SAEq n -> do
109+ let
110+ nlen = natVal n
111+ predicate = nlen == fromIntegral (V.length v)
112+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
113+ warn = vWarning $ mmSingleton path (pure errMsg)
114+ unless predicate warn
115+
116+validateJsonRepr
117+ :: Sing schema
118+ -> [DemotedPathSegment]
119+ -> JsonRepr schema
120+ -> Validation ()
121+validateJsonRepr sschema dpath jr = case jr of
122+ ReprText t -> case sschema of
123+ SSchemaText scs -> do
124+ let
125+ process :: Sing (cs :: [TextConstraint]) -> Validation ()
126+ process SNil = pure ()
127+ process (SCons c cs) = do
128+ validateTextConstraint (demotedPathToText dpath) t c
129+ process cs
130+ process scs
131+ ReprNumber n -> case sschema of
132+ SSchemaNumber scs -> do
133+ let
134+ process :: Sing (cs :: [NumberConstraint]) -> Validation ()
135+ process SNil = pure ()
136+ process (SCons c cs) = do
137+ validateNumberConstraint (demotedPathToText dpath) n c
138+ process cs
139+ process scs
140+ ReprNull -> pure ()
141+ ReprArray v -> case sschema of
142+ SSchemaArray acs s -> do
143+ let
144+ process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
145+ process SNil = pure ()
146+ process (SCons c cs) = do
147+ validateArrayConstraint (demotedPathToText dpath) v c
148+ process cs
149+ process acs
150+ for_ (V.indexed v) $ \(ix, jr') -> do
151+ let newPath = dpath <> pure (DIx $ fromIntegral ix)
152+ validateJsonRepr s newPath jr'
153+ ReprOptional d -> case sschema of
154+ SSchemaOptional ss -> case d of
155+ Just x -> validateJsonRepr ss dpath x
156+ Nothing -> pure ()
157+ ReprObject fs -> case sschema of
158+ SSchemaObject _ -> go fs
159+ where
160+ go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()
161+ go RNil = pure ()
162+ go (f@(FieldRepr d) :& ftl) = do
163+ let newPath = dpath <> [DKey (knownFieldName f)]
164+ validateJsonRepr (knownFieldSchema f) newPath d
165+ go ftl