git.iko.soy/typeable/schematic
on aa474d0 help sign in
typeable/schematic/src/Data/Schematic/Validation.hs
177 lines 5.7 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.Vector as V
16import Data.Vinyl
17import Prelude as P
18import Text.Regex
21type Validation a = ValidationT ErrorMap Identity a
23type ErrorMap = MonoidMap Text [Text]
25data ParseResult a
26 = Valid a
27 | DecodingError Text -- static
28 | ValidationError ErrorMap -- runtime
29 deriving (Show, Eq, Functor)
31isValid :: ParseResult a -> Bool
32isValid (Valid _) = True
33isValid _ = False
35isDecodingError :: ParseResult a -> Bool
36isDecodingError (DecodingError _) = True
37isDecodingError _ = False
39isValidationError :: ParseResult a -> Bool
40isValidationError (ValidationError _) = True
41isValidationError _ = False
43validateTextConstraint
44 :: JSONPath
45 -> Text
46 -> Sing (tcs :: TextConstraint)
47 -> Validation ()
48validateTextConstraint (JSONPath path) t = \case
49 STEq n -> do
50 let
51 nlen = natVal n
52 predicate = nlen == (fromIntegral $ T.length t)
53 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
54 warn = vWarning $ mmSingleton path (pure errMsg)
55 unless predicate warn
56 STLe n -> do
57 let
58 nlen = natVal n
59 predicate = nlen <= (fromIntegral $ T.length t)
60 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
61 warn = vWarning $ mmSingleton path (pure errMsg)
62 unless predicate warn
63 STGt n -> do
64 let
65 nlen = natVal n
66 predicate = nlen > (fromIntegral $ T.length t)
67 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
68 warn = vWarning $ mmSingleton path (pure errMsg)
69 unless predicate warn
70 STRegex r -> do
71 let
72 regex = symbolVal r
73 predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
74 errMsg = path <> " must match " <> T.pack (show regex)
75 warn = vWarning $ mmSingleton path (pure errMsg)
76 unless predicate warn
77 STEnum ss -> do
78 let
79 matching :: Sing (s :: [Symbol]) -> Bool
80 matching SNil = False
81 matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs
82 errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))
83 warn = vWarning $ mmSingleton path (pure errMsg)
84 unless (matching ss) warn
86validateNumberConstraint
87 :: JSONPath
88 -> Scientific
89 -> Sing (tcs :: NumberConstraint)
90 -> Validation ()
91validateNumberConstraint (JSONPath path) num = \case
92 SNEq n -> do
93 let
94 nlen = natVal n
95 predicate = fromIntegral nlen == num
96 errMsg = path <> " should be == " <> T.pack (show nlen)
97 warn = vWarning $ mmSingleton path (pure errMsg)
98 unless predicate warn
99 SNGt n -> do
100 let
101 nlen = natVal n
102 predicate = num > fromIntegral nlen
103 errMsg = path <> " should be > " <> T.pack (show nlen)
104 warn = vWarning $ mmSingleton path (pure errMsg)
105 unless predicate warn
106 SNLe n -> do
107 let
108 nlen = natVal n
109 predicate = fromIntegral nlen <= num
110 errMsg = path <> " should be <= " <> T.pack (show nlen)
111 warn = vWarning $ mmSingleton path (pure errMsg)
112 unless predicate warn
114validateArrayConstraint
115 :: JSONPath
116 -> V.Vector a
117 -> Sing (tcs :: ArrayConstraint)
118 -> Validation ()
119validateArrayConstraint (JSONPath path) v = \case
120 SAEq n -> do
121 let
122 nlen = natVal n
123 predicate = nlen == fromIntegral (V.length v)
124 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
125 warn = vWarning $ mmSingleton path (pure errMsg)
126 unless predicate warn
128validateJsonRepr
129 :: Sing schema
130 -> [DemotedPathSegment]
131 -> JsonRepr schema
132 -> Validation ()
133validateJsonRepr sschema dpath jr = case jr of
134 ReprText t -> case sschema of
135 SSchemaText scs -> do
136 let
137 process :: Sing (cs :: [TextConstraint]) -> Validation ()
138 process SNil = pure ()
139 process (SCons c cs) = do
140 validateTextConstraint (demotedPathToText dpath) t c
141 process cs
142 process scs
143 ReprNumber n -> case sschema of
144 SSchemaNumber scs -> do
145 let
146 process :: Sing (cs :: [NumberConstraint]) -> Validation ()
147 process SNil = pure ()
148 process (SCons c cs) = do
149 validateNumberConstraint (demotedPathToText dpath) n c
150 process cs
151 process scs
152 ReprNull -> pure ()
153 ReprArray v -> case sschema of
154 SSchemaArray acs s -> do
155 let
156 process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
157 process SNil = pure ()
158 process (SCons c cs) = do
159 validateArrayConstraint (demotedPathToText dpath) v c
160 process cs
161 process acs
162 for_ (V.indexed v) $ \(ix, jr') -> do
163 let newPath = dpath <> pure (DIx $ fromIntegral ix)
164 validateJsonRepr s newPath jr'
165 ReprOptional d -> case sschema of
166 SSchemaOptional ss -> case d of
167 Just x -> validateJsonRepr ss dpath x
168 Nothing -> pure ()
169 ReprObject fs -> case sschema of
170 SSchemaObject _ -> go fs
171 where
172 go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()
173 go RNil = pure ()
174 go (f@(FieldRepr d) :& ftl) = do
175 let newPath = dpath <> [DKey (knownFieldName f)]
176 validateJsonRepr (knownFieldSchema f) newPath d
177 go ftl