git.iko.soy/schematic
on 6cc400e help sign in
schematic/src/Data/Schematic/Validation.hs
277 lines 9.3 kB history raw
1module Data.Schematic.Validation where
3import Control.Monad
4import Control.Monad.Validation
5import Data.Aeson
6import Data.Aeson.Types
7import Data.Foldable
8import Data.Functor.Identity
9import Data.Monoid
10import Data.Schematic.Path
11import Data.Schematic.Schema
12import Data.Scientific
13import Data.Singletons.Prelude
14import Data.Singletons.TypeLits
15import Data.Text as T
16import Data.Traversable
17import Data.Union
18import Data.Vector as V
19import Data.Vinyl
20import Data.Vinyl.TypeLevel
21import Prelude as P
22import Text.Regex.TDFA
25type Validation a = ValidationT ErrorMap Identity a
27type ErrorMap = MonoidMap Text [Text]
29data ParseResult a
30 = Valid a
31 | DecodingError Text -- static
32 | ValidationError ErrorMap -- runtime
33 deriving (Show, Eq, Functor, Foldable, Traversable)
35instance (TopLevel a, SingI a, FromJSON (JsonRepr a))
36 => FromJSON (ParseResult (JsonRepr a)) where
37 parseJSON = pure . parseAndValidateJson @a
39isValid :: ParseResult a -> Bool
40isValid (Valid _) = True
41isValid _ = False
43isDecodingError :: ParseResult a -> Bool
44isDecodingError (DecodingError _) = True
45isDecodingError _ = False
47isValidationError :: ParseResult a -> Bool
48isValidationError (ValidationError _) = True
49isValidationError _ = False
51validateTextConstraint
52 :: JSONPath
53 -> Text
54 -> Sing (tcs :: TextConstraint)
55 -> Validation ()
56validateTextConstraint (JSONPath path) t = \case
57 STEq n -> do
58 let
59 nlen = withKnownNat n $ natVal n
60 predicate = nlen == (fromIntegral $ T.length t)
61 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
62 warn = vWarning $ mmSingleton path (pure errMsg)
63 unless predicate warn
64 STLt n -> do
65 let
66 nlen = withKnownNat n $ natVal n
67 predicate = nlen < (fromIntegral $ T.length t)
68 errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
69 warn = vWarning $ mmSingleton path (pure errMsg)
70 unless predicate warn
71 STLe n -> do
72 let
73 nlen = withKnownNat n $ natVal n
74 predicate = nlen <= (fromIntegral $ T.length t)
75 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
76 warn = vWarning $ mmSingleton path (pure errMsg)
77 unless predicate warn
78 STGt n -> do
79 let
80 nlen = withKnownNat n $ natVal n
81 predicate = nlen > (fromIntegral $ T.length t)
82 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
83 warn = vWarning $ mmSingleton path (pure errMsg)
84 unless predicate warn
85 STGe n -> do
86 let
87 nlen = withKnownNat n $ natVal n
88 predicate = nlen >= (fromIntegral $ T.length t)
89 errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
90 warn = vWarning $ mmSingleton path (pure errMsg)
91 unless predicate warn
92 STRegex r -> do
93 let
94 regex = withKnownSymbol r $ fromSing r
95 predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
96 errMsg = path <> " must match " <> regex
97 warn = vWarning $ mmSingleton path (pure errMsg)
98 unless predicate warn
99 STEnum ss -> do
100 let
101 matching :: Sing (s :: [Symbol]) -> Bool
102 matching SNil = False
103 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
104 errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
105 warn = vWarning $ mmSingleton path (pure errMsg)
106 unless (matching ss) warn
108validateNumberConstraint
109 :: JSONPath
110 -> Scientific
111 -> Sing (tcs :: NumberConstraint)
112 -> Validation ()
113validateNumberConstraint (JSONPath path) num = \case
114 SNEq n -> do
115 let
116 nlen = withKnownNat n $ natVal n
117 predicate = fromIntegral nlen == num
118 errMsg = path <> " should be == " <> T.pack (show nlen)
119 warn = vWarning $ mmSingleton path (pure errMsg)
120 unless predicate warn
121 SNGt n -> do
122 let
123 nlen = withKnownNat n $ natVal n
124 predicate = num > fromIntegral nlen
125 errMsg = path <> " should be > " <> T.pack (show nlen)
126 warn = vWarning $ mmSingleton path (pure errMsg)
127 unless predicate warn
128 SNGe n -> do
129 let
130 nlen = withKnownNat n $ natVal n
131 predicate = num >= fromIntegral nlen
132 errMsg = path <> " should be >= " <> T.pack (show nlen)
133 warn = vWarning $ mmSingleton path (pure errMsg)
134 unless predicate warn
135 SNLt n -> do
136 let
137 nlen = withKnownNat n $ natVal n
138 predicate = num < fromIntegral nlen
139 errMsg = path <> " should be < " <> T.pack (show nlen)
140 warn = vWarning $ mmSingleton path (pure errMsg)
141 unless predicate warn
142 SNLe n -> do
143 let
144 nlen = withKnownNat n $ natVal n
145 predicate = num <= fromIntegral nlen
146 errMsg = path <> " should be <= " <> T.pack (show nlen)
147 warn = vWarning $ mmSingleton path (pure errMsg)
148 unless predicate warn
150validateArrayConstraint
151 :: JSONPath
152 -> V.Vector a
153 -> Sing (tcs :: ArrayConstraint)
154 -> Validation ()
155validateArrayConstraint (JSONPath path) v = \case
156 SAEq n -> do
157 let
158 nlen = withKnownNat n $ natVal n
159 predicate = nlen == fromIntegral (V.length v)
160 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
161 warn = vWarning $ mmSingleton path (pure errMsg)
162 unless predicate warn
164validateJsonRepr
165 :: Sing schema
166 -> [DemotedPathSegment]
167 -> JsonRepr schema
168 -> Validation ()
169validateJsonRepr sschema dpath jr = case jr of
170 ReprText t -> case sschema of
171 SSchemaText scs -> do
172 let
173 process :: Sing (cs :: [TextConstraint]) -> Validation ()
174 process SNil = pure ()
175 process (SCons c cs) = do
176 validateTextConstraint (demotedPathToText dpath) t c
177 process cs
178 process scs
179 ReprNumber n -> case sschema of
180 SSchemaNumber scs -> do
181 let
182 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
183 process SNil = pure ()
184 process (SCons c cs) = do
185 validateNumberConstraint (demotedPathToText dpath) n c
186 process cs
187 process scs
188 ReprNull -> pure ()
189 ReprBoolean _ -> pure ()
190 ReprArray v -> case sschema of
191 SSchemaArray acs s -> do
192 let
193 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
194 process SNil = pure ()
195 process (SCons c cs) = do
196 validateArrayConstraint (demotedPathToText dpath) v c
197 process cs
198 process acs
199 for_ (V.indexed v) $ \(ix, jr') -> do
200 let newPath = dpath <> pure (DIx $ fromIntegral ix)
201 validateJsonRepr s newPath jr'
202 ReprOptional d -> case sschema of
203 SSchemaOptional ss -> case d of
204 Just x -> validateJsonRepr ss dpath x
205 Nothing -> pure ()
206 ReprObject fs -> case sschema of
207 SSchemaObject _ -> go fs
208 where
209 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
210 go RNil = pure ()
211 go (f@(FieldRepr d) :& ftl) = do
212 let newPath = dpath <> [DKey (knownFieldName f)]
213 validateJsonRepr (knownFieldSchema f) newPath d
214 go ftl
215 ReprUnion _ -> pure () -- FIXME
216 -- case sschema of
217 -- SSchemaUnion ss -> case ss of
218 -- SCons s stl -> case umatch' s u of
219 -- Nothing -> case urestrict u of
220 -- Nothing ->
221 -- fail "impossible to produce subUnion, please report this as a bug"
222 -- Just x -> do
223 -- let
224 -- JSONPath path = demotedPathToText dpath
225 -- case stl of
226 -- SNil -> void $ vWarning $ mmSingleton path
227 -- $ pure "union handling error, please report this as bug"
228 -- SCons s' stl' ->
229 -- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
230 -- $ toUnion (SCons s' stl') x
231 -- Just x -> validateJsonRepr s dpath x
233-- subUnion
234-- :: Sing (s ': stl)
235-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
236-- => Union f (s ': stl)
237-- -> Maybe (Union f stl) )
238-- subUnion (SCons s stl) = urestrict
240-- withUSubset
241-- :: Sing (s ': stl)
242-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
243-- -> Maybe (Union f stl)
244-- withUSubset (SCons s stl) r = r
246toUnion
247 :: USubset s' (s ': ss) (RImage s' (s ': ss))
248 => Sing (s ': ss)
249 -> Union JsonRepr s'
250 -> JsonRepr ('SchemaUnion (s ': ss))
251toUnion _ = ReprUnion . urelax
253umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
254umatch' _ u = umatch u
256parseAndValidateJson
257 :: forall schema
258 . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
259 => Value
260 -> ParseResult (JsonRepr schema)
261parseAndValidateJson v =
262 case parseEither parseJSON v of
263 Left s -> DecodingError $ T.pack s
264 Right jsonRepr ->
265 let
266 validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
267 res = runIdentity . runValidationTEither $ validate
268 in case res of
269 Left em -> ValidationError em
270 Right () -> Valid jsonRepr
272parseAndValidateJsonBy
273 :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
274 => proxy schema
275 -> Value
276 -> ParseResult (JsonRepr schema)
277parseAndValidateJsonBy _ = parseAndValidateJson