git.iko.soy/typeable/schematic
on 0.2.0.0 help sign in
typeable/schematic/src/Data/Schematic/Validation.hs
207 lines 7.0 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.Vector as V
17import Data.Vinyl
18import Prelude as P
19import Text.Regex
22type Validation a = ValidationT ErrorMap Identity a
24type ErrorMap = MonoidMap Text [Text]
26data ParseResult a
27 = Valid a
28 | DecodingError Text -- static
29 | ValidationError ErrorMap -- runtime
30 deriving (Show, Eq, Functor, Foldable, Traversable)
32isValid :: ParseResult a -> Bool
33isValid (Valid _) = True
34isValid _ = False
36isDecodingError :: ParseResult a -> Bool
37isDecodingError (DecodingError _) = True
38isDecodingError _ = False
40isValidationError :: ParseResult a -> Bool
41isValidationError (ValidationError _) = True
42isValidationError _ = False
44validateTextConstraint
45 :: JSONPath
46 -> Text
47 -> Sing (tcs :: TextConstraint)
48 -> Validation ()
49validateTextConstraint (JSONPath path) t = \case
50 STEq n -> do
51 let
52 nlen = withKnownNat n $ natVal n
53 predicate = nlen == (fromIntegral $ T.length t)
54 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
55 warn = vWarning $ mmSingleton path (pure errMsg)
56 unless predicate warn
57 STLt 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 STLe 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 STGt 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 STGe 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 STRegex r -> do
86 let
87 regex = withKnownSymbol r $ symbolVal r
88 predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
89 errMsg = path <> " must match " <> T.pack (show regex)
90 warn = vWarning $ mmSingleton path (pure errMsg)
91 unless predicate warn
92 STEnum ss -> do
93 let
94 matching :: Sing (s :: [Symbol]) -> Bool
95 matching SNil = False
96 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
97 errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
98 warn = vWarning $ mmSingleton path (pure errMsg)
99 unless (matching ss) warn
101validateNumberConstraint
102 :: JSONPath
103 -> Scientific
104 -> Sing (tcs :: NumberConstraint)
105 -> Validation ()
106validateNumberConstraint (JSONPath path) num = \case
107 SNEq n -> do
108 let
109 nlen = withKnownNat n $ natVal n
110 predicate = fromIntegral nlen == num
111 errMsg = path <> " should be == " <> T.pack (show nlen)
112 warn = vWarning $ mmSingleton path (pure errMsg)
113 unless predicate warn
114 SNGt n -> do
115 let
116 nlen = withKnownNat n $ natVal n
117 predicate = num > fromIntegral nlen
118 errMsg = path <> " should be > " <> T.pack (show nlen)
119 warn = vWarning $ mmSingleton path (pure errMsg)
120 unless predicate warn
121 SNGe 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 SNLt n -> do
129 let
130 nlen = withKnownNat n $ natVal n
131 predicate = fromIntegral nlen < num
132 errMsg = path <> " should be < " <> T.pack (show nlen)
133 warn = vWarning $ mmSingleton path (pure errMsg)
134 unless predicate warn
135 SNLe n -> do
136 let
137 nlen = withKnownNat n $ natVal n
138 predicate = fromIntegral nlen <= num
139 errMsg = path <> " should be <= " <> T.pack (show nlen)
140 warn = vWarning $ mmSingleton path (pure errMsg)
141 unless predicate warn
143validateArrayConstraint
144 :: JSONPath
145 -> V.Vector a
146 -> Sing (tcs :: ArrayConstraint)
147 -> Validation ()
148validateArrayConstraint (JSONPath path) v = \case
149 SAEq n -> do
150 let
151 nlen = withKnownNat n $ natVal n
152 predicate = nlen == fromIntegral (V.length v)
153 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
154 warn = vWarning $ mmSingleton path (pure errMsg)
155 unless predicate warn
157validateJsonRepr
158 :: Sing schema
159 -> [DemotedPathSegment]
160 -> JsonRepr schema
161 -> Validation ()
162validateJsonRepr sschema dpath jr = case jr of
163 ReprText t -> case sschema of
164 SSchemaText scs -> do
165 let
166 process :: Sing (cs :: [TextConstraint]) -> Validation ()
167 process SNil = pure ()
168 process (SCons c cs) = do
169 validateTextConstraint (demotedPathToText dpath) t c
170 process cs
171 process scs
172 ReprNumber n -> case sschema of
173 SSchemaNumber scs -> do
174 let
175 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
176 process SNil = pure ()
177 process (SCons c cs) = do
178 validateNumberConstraint (demotedPathToText dpath) n c
179 process cs
180 process scs
181 ReprNull -> pure ()
182 ReprBoolean _ -> pure ()
183 ReprArray v -> case sschema of
184 SSchemaArray acs s -> do
185 let
186 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
187 process SNil = pure ()
188 process (SCons c cs) = do
189 validateArrayConstraint (demotedPathToText dpath) v c
190 process cs
191 process acs
192 for_ (V.indexed v) $ \(ix, jr') -> do
193 let newPath = dpath <> pure (DIx $ fromIntegral ix)
194 validateJsonRepr s newPath jr'
195 ReprOptional d -> case sschema of
196 SSchemaOptional ss -> case d of
197 Just x -> validateJsonRepr ss dpath x
198 Nothing -> pure ()
199 ReprObject fs -> case sschema of
200 SSchemaObject _ -> go fs
201 where
202 go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()
203 go RNil = pure ()
204 go (f@(FieldRepr d) :& ftl) = do
205 let newPath = dpath <> [DKey (knownFieldName f)]
206 validateJsonRepr (knownFieldSchema f) newPath d
207 go ftl