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