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