git.iko.soy/typeable/schematic
on master help sign in
Runtime validations
a619dabDenis Redozubov
src/Data/Schematic.hs+24
compare with master
unifiedsplit
@@ -1,7 +1,31 @@
1module Data.Schematic
1module Data.Schematic
2 ( module Data.Schematic.Schema
2 ( module Data.Schematic.Schema
3 , module Data.Schematic.Utils
3 , module Data.Schematic.Utils
4+ , parseAndValidateJson
4 ) where
5 ) where
5
6
7+import Control.Monad.Validation
8+import Data.Aeson as J
9+import Data.Aeson.Types as J
10+import Data.Functor.Identity
6import Data.Schematic.Schema
11import Data.Schematic.Schema
7import Data.Schematic.Utils
12import 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 @@
1module Data.Schematic.Path where
1module Data.Schematic.Path where
2
2
3−import Data.Singletons
3+import Data.Foldable as F
4−import Data.Singletons.TypeLits
4+import Data.Monoid
5import Data.Schematic.Utils
5import Data.Schematic.Utils
6+import Data.Singletons
6import Data.Singletons.Prelude
7import Data.Singletons.Prelude
8+import Data.Singletons.TypeLits
7import Data.Text as T
9import Data.Text as T
8
10
9
11
@@ -21,10 +23,28 @@ instance (KnownNat n, Known (Sing n))
21 => Known (Sing ('Ix n)) where
23 => Known (Sing ('Ix n)) where
22 known = SIx known
24 known = SIx known
23
25
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+
24−pathToText :: Sing (ps :: [PathSegment]) -> Text
33+demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
25−pathToText = T.pack . go ""
34+demotePath = go []
26 where
35 where
27− go :: String -> Sing (ps :: [PathSegment]) -> String
36+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]
28 go acc SNil = acc
37 go acc SNil = acc
38+ go acc (SCons p ps) = go (acc ++ [demote p]) ps
39+ demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
29− go acc (SCons (SKey k) tl) = go (acc ++ "." ++ symbolVal k) tl
40+ demote (SKey s) = DKey $ T.pack $ symbolVal s
30− go acc (SCons (SIx n) tl) = go (acc ++ "[" ++ show (natVal n) ++ "]") tl
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
15import Data.Schematic.Instances ()
15import Data.Schematic.Instances ()
16import Data.Schematic.Utils
16import Data.Schematic.Utils
17import Data.Scientific
17import Data.Scientific
18−import Data.Singletons.Prelude.List
18+import Data.Singletons.Prelude.List hiding (All)
19import Data.Singletons.TH
19import Data.Singletons.TH
20import Data.Singletons.TypeLits
20import Data.Singletons.TypeLits
21import Data.Text as T
21import Data.Text as T
@@ -27,6 +27,10 @@ import Prelude as P
27import Test.SmallCheck.Series
27import Test.SmallCheck.Series
28
28
29
29
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+
30type family CRepr (s :: Schema) :: Type where
34type family CRepr (s :: Schema) :: Type where
31 CRepr ('SchemaText cs) = TextConstraint
35 CRepr ('SchemaText cs) = TextConstraint
32 CRepr ('SchemaNumber cs) = NumberConstraint
36 CRepr ('SchemaNumber cs) = NumberConstraint
@@ -38,22 +42,27 @@ data TextConstraint
38 | TLe Nat
42 | TLe Nat
39 | TGt Nat
43 | TGt Nat
40 | TRegex Symbol
44 | TRegex Symbol
45+ | TEnum [Symbol]
41 deriving (Generic)
46 deriving (Generic)
42
47
43data instance Sing (tc :: TextConstraint) where
48data instance Sing (tc :: TextConstraint) where
44− STEq :: Sing n -> Sing ('TEq n)
49+ STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)
45− STLe :: Sing n -> Sing ('TLe n)
50+ STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)
46− STGt :: Sing n -> Sing ('TGt n)
51+ STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)
47− STRegex :: Sing s -> Sing ('TRegex s)
52+ STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s)
48−
53+ STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)
54+
49−instance Known (Sing n) => Known (Sing ('TEq n)) where known = STEq known
55+instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known
50−instance Known (Sing n) => Known (Sing ('TGt n)) where known = STGt known
56+instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known
51−instance Known (Sing n) => Known (Sing ('TLe n)) where known = STLe known
57+instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known
52−instance Known (Sing s) => Known (Sing ('TRegex s)) where known = STRegex 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
53
60
54instance Eq (Sing ('TEq n)) where _ == _ = True
61instance Eq (Sing ('TEq n)) where _ == _ = True
55instance Eq (Sing ('TLe n)) where _ == _ = True
62instance Eq (Sing ('TLe n)) where _ == _ = True
56instance Eq (Sing ('TGt n)) where _ == _ = True
63instance Eq (Sing ('TGt n)) where _ == _ = True
64+instance Eq (Sing ('TRegex t)) where _ == _ = True
65+instance Eq (Sing ('TEnum ss)) where _ == _ = True
57
66
58data NumberConstraint
67data NumberConstraint
59 = NLe Nat
68 = NLe Nat
@@ -62,13 +71,13 @@ data NumberConstraint
62 deriving (Generic)
71 deriving (Generic)
63
72
64data instance Sing (nc :: NumberConstraint) where
73data instance Sing (nc :: NumberConstraint) where
65− SNEq :: Sing n -> Sing ('NEq n)
74+ SNEq :: KnownNat n => Sing n -> Sing ('NEq n)
66− SNGt :: Sing n -> Sing ('NGt n)
75+ SNGt :: KnownNat n => Sing n -> Sing ('NGt n)
67− SNLe :: Sing n -> Sing ('NLe n)
76+ SNLe :: KnownNat n => Sing n -> Sing ('NLe n)
68
77
69−instance Known (Sing n) => Known (Sing ('NEq n)) where known = SNEq known
78+instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known
70−instance Known (Sing n) => Known (Sing ('NGt n)) where known = SNGt known
79+instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known
71−instance Known (Sing n) => Known (Sing ('NLe n)) where known = SNLe known
80+instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known
72
81
73instance Eq (Sing ('NEq n)) where _ == _ = True
82instance Eq (Sing ('NEq n)) where _ == _ = True
74instance Eq (Sing ('NLe n)) where _ == _ = True
83instance Eq (Sing ('NLe n)) where _ == _ = True
@@ -79,9 +88,9 @@ data ArrayConstraint
79 deriving (Generic)
88 deriving (Generic)
80
89
81data instance Sing (ac :: ArrayConstraint) where
90data instance Sing (ac :: ArrayConstraint) where
82− SAEq :: Sing n -> Sing ('AEq n)
91+ SAEq :: KnownNat n => Sing n -> Sing ('AEq n)
83
92
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
85
94
86instance Eq (Sing ('AEq n)) where _ == _ = True
95instance Eq (Sing ('AEq n)) where _ == _ = True
87
96
@@ -123,11 +132,24 @@ instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
123instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
132instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
124
133
125data FieldRepr :: (Symbol, Schema) -> Type where
134data FieldRepr :: (Symbol, Schema) -> Type where
135+ FieldRepr
136+ :: (Known (Sing schema), KnownSymbol name)
137+ => JsonRepr schema
126− FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
138+ -> FieldRepr '(name, schema)
127−
139+
128−type family MapSnd (cs :: [(Symbol, Schema)]) :: [Schema] where
140+knownFieldName
129− MapSnd '[] = '[]
141+ :: forall proxy (fieldName :: Symbol) schema
130− MapSnd ( '(fn, schema) ': as) = schema ': MapSnd as
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
131
153
132deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
154deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
133
155
@@ -136,6 +158,7 @@ instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
136
158
137instance
159instance
138 ( KnownSymbol name
160 ( KnownSymbol name
161+ , Known (Sing schema)
139 , Serial m (JsonRepr schema) )
162 , Serial m (JsonRepr schema) )
140 => Serial m (FieldRepr '(name, schema)) where
163 => Serial m (FieldRepr '(name, schema)) where
141 series = FieldRepr <$> series
164 series = FieldRepr <$> series
@@ -269,9 +292,9 @@ instance J.ToJSON (JsonRepr a) where
269 RNil -> []
292 RNil -> []
270 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
293 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
271
294
272−class FalseConstraint
295+class FalseConstraint a
273
296
274−type family TopLevel (spec :: Schema) :: Constraint where
297+type family TopLevel (schema :: Schema) :: Constraint where
275− TopLevel ('SchemaArray a e) = ()
298+ TopLevel ('SchemaArray acs s) = ()
276− TopLevel ('SchemaObject o) = ()
299+ TopLevel ('SchemaObject o) = ()
277− TopLevel spec = FalseConstraint
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