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