@@ -3,6 +3,7 @@ module Data.Schematic.Validation where
33import Control.Monad
44import Control.Monad.Validation
55import Data.Aeson
6+import Data.Aeson.Internal
67import Data.Aeson.Types
78import Data.Foldable
89import Data.Functor.Identity
@@ -49,51 +50,51 @@ isValidationError (ValidationError _) = True
4950isValidationError _ = False
5051
5152validateTextConstraint
52− :: JSONPath
53+ :: JSONPathText
5354 -> Text
5455 -> Sing (tcs :: TextConstraint)
5556 -> Validation ()
56−validateTextConstraint (JSONPath path) t = \case
57+validateTextConstraint (JSONPathText path) t = \case
5758 STEq n -> do
5859 let
5960 nlen = withKnownNat n $ natVal n
6061 predicate = nlen == (fromIntegral $ T.length t)
61− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
62+ errMsg = "length should be == " <> T.pack (show nlen)
6263 warn = vWarning $ mmSingleton path (pure errMsg)
6364 unless predicate warn
6465 STLt n -> do
6566 let
6667 nlen = withKnownNat n $ natVal n
6768 predicate = nlen > (fromIntegral $ T.length t)
68− errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
69+ errMsg = "length should be < " <> T.pack (show nlen)
6970 warn = vWarning $ mmSingleton path (pure errMsg)
7071 unless predicate warn
7172 STLe n -> do
7273 let
7374 nlen = withKnownNat n $ natVal n
7475 predicate = nlen >= (fromIntegral $ T.length t)
75− errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
76+ errMsg = "length should be <= " <> T.pack (show nlen)
7677 warn = vWarning $ mmSingleton path (pure errMsg)
7778 unless predicate warn
7879 STGt n -> do
7980 let
8081 nlen = withKnownNat n $ natVal n
8182 predicate = nlen < (fromIntegral $ T.length t)
82− errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
83+ errMsg = "length should be > " <> T.pack (show nlen)
8384 warn = vWarning $ mmSingleton path (pure errMsg)
8485 unless predicate warn
8586 STGe n -> do
8687 let
8788 nlen = withKnownNat n $ natVal n
8889 predicate = nlen <= (fromIntegral $ T.length t)
89− errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
90+ errMsg = "length should be >= " <> T.pack (show nlen)
9091 warn = vWarning $ mmSingleton path (pure errMsg)
9192 unless predicate warn
9293 STRegex r -> do
9394 let
9495 regex = withKnownSymbol r $ fromSing r
9596 predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)
96− errMsg = path <> " must match " <> regex
97+ errMsg = "must match " <> regex
9798 warn = vWarning $ mmSingleton path (pure errMsg)
9899 unless predicate warn
99100 STEnum ss -> do
@@ -101,69 +102,97 @@ validateTextConstraint (JSONPath path) t = \case
101102 matching :: Sing (s :: [Symbol]) -> Bool
102103 matching SNil = False
103104 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+ errMsg = "must be one of " <> T.pack (show (fromSing ss))
105106 warn = vWarning $ mmSingleton path (pure errMsg)
106107 unless (matching ss) warn
107108
108109validateNumberConstraint
109− :: JSONPath
110+ :: JSONPathText
110111 -> Scientific
111112 -> Sing (tcs :: NumberConstraint)
112113 -> Validation ()
113−validateNumberConstraint (JSONPath path) num = \case
114+validateNumberConstraint (JSONPathText path) num = \case
114115 SNEq n -> do
115116 let
116117 nlen = withKnownNat n $ natVal n
117118 predicate = fromIntegral nlen == num
118− errMsg = path <> " should be == " <> T.pack (show nlen)
119+ errMsg = "should be == " <> T.pack (show nlen)
119120 warn = vWarning $ mmSingleton path (pure errMsg)
120121 unless predicate warn
121122 SNGt n -> do
122123 let
123124 nlen = withKnownNat n $ natVal n
124125 predicate = num > fromIntegral nlen
125− errMsg = path <> " should be > " <> T.pack (show nlen)
126+ errMsg = "should be > " <> T.pack (show nlen)
126127 warn = vWarning $ mmSingleton path (pure errMsg)
127128 unless predicate warn
128129 SNGe n -> do
129130 let
130131 nlen = withKnownNat n $ natVal n
131132 predicate = num >= fromIntegral nlen
132− errMsg = path <> " should be >= " <> T.pack (show nlen)
133+ errMsg = "should be >= " <> T.pack (show nlen)
133134 warn = vWarning $ mmSingleton path (pure errMsg)
134135 unless predicate warn
135136 SNLt n -> do
136137 let
137138 nlen = withKnownNat n $ natVal n
138139 predicate = num < fromIntegral nlen
139− errMsg = path <> " should be < " <> T.pack (show nlen)
140+ errMsg = "should be < " <> T.pack (show nlen)
140141 warn = vWarning $ mmSingleton path (pure errMsg)
141142 unless predicate warn
142143 SNLe n -> do
143144 let
144145 nlen = withKnownNat n $ natVal n
145146 predicate = num <= fromIntegral nlen
146− errMsg = path <> " should be <= " <> T.pack (show nlen)
147+ errMsg = "should be <= " <> T.pack (show nlen)
147148 warn = vWarning $ mmSingleton path (pure errMsg)
148149 unless predicate warn
149150
150151validateArrayConstraint
151− :: JSONPath
152+ :: JSONPathText
152153 -> V.Vector a
153154 -> Sing (tcs :: ArrayConstraint)
154155 -> Validation ()
155−validateArrayConstraint (JSONPath path) v = \case
156+validateArrayConstraint (JSONPathText path) v = \case
156157 SAEq n -> do
157158 let
158159 nlen = withKnownNat n $ natVal n
159160 predicate = nlen == fromIntegral (V.length v)
160− errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
161+ errMsg = "length should be == " <> T.pack (show nlen)
162+ warn = vWarning $ mmSingleton path (pure errMsg)
163+ unless predicate warn
164+ SAGt n -> do
165+ let
166+ nlen = withKnownNat n $ natVal n
167+ predicate = fromIntegral (V.length v) > nlen
168+ errMsg = "length should be > " <> T.pack (show nlen)
169+ warn = vWarning $ mmSingleton path (pure errMsg)
170+ unless predicate warn
171+ SAGe n -> do
172+ let
173+ nlen = withKnownNat n $ natVal n
174+ predicate = fromIntegral (V.length v) >= nlen
175+ errMsg = "length should be >= " <> T.pack (show nlen)
176+ warn = vWarning $ mmSingleton path (pure errMsg)
177+ unless predicate warn
178+ SALt n -> do
179+ let
180+ nlen = withKnownNat n $ natVal n
181+ predicate = fromIntegral (V.length v) < nlen
182+ errMsg = "length should be < " <> T.pack (show nlen)
183+ warn = vWarning $ mmSingleton path (pure errMsg)
184+ unless predicate warn
185+ SALe n -> do
186+ let
187+ nlen = withKnownNat n $ natVal n
188+ predicate = fromIntegral (V.length v) <= nlen
189+ errMsg = "length should be <= " <> T.pack (show nlen)
161190 warn = vWarning $ mmSingleton path (pure errMsg)
162191 unless predicate warn
163192
164193validateJsonRepr
165194 :: Sing schema
166− -> [DemotedPathSegment]
195+ -> JSONPath
167196 -> JsonRepr schema
168197 -> Validation ()
169198validateJsonRepr sschema dpath jr = case jr of
@@ -197,7 +226,7 @@ validateJsonRepr sschema dpath jr = case jr of
197226 process cs
198227 process acs
199228 for_ (V.indexed v) $ \(ix, jr') -> do
200− let newPath = dpath <> pure (DIx $ fromIntegral ix)
229+ let newPath = dpath <> pure (Index $ fromIntegral ix)
201230 validateJsonRepr s newPath jr'
202231 ReprOptional d -> case sschema of
203232 SSchemaOptional ss -> case d of
@@ -209,7 +238,7 @@ validateJsonRepr sschema dpath jr = case jr of
209238 go :: Rec FieldRepr (ts :: [(Symbol, Schema)] ) -> Validation ()
210239 go RNil = pure ()
211240 go (f@(FieldRepr d) :& ftl) = do
212− let newPath = dpath <> [DKey (knownFieldName f)]
241+ let newPath = dpath <> [Key (knownFieldName f)]
213242 validateJsonRepr (knownFieldSchema f) newPath d
214243 go ftl
215244 ReprUnion _ -> pure () -- FIXME
@@ -221,7 +250,7 @@ validateJsonRepr sschema dpath jr = case jr of
221250 -- fail "impossible to produce subUnion, please report this as a bug"
222251 -- Just x -> do
223252 -- let
224− -- JSONPath path = demotedPathToText dpath
253+ -- JSONPathText path = demotedPathToText dpath
225254 -- case stl of
226255 -- SNil -> void $ vWarning $ mmSingleton path
227256 -- $ pure "union handling error, please report this as bug"