@@ -19,7 +19,6 @@ import Control.Monad.Reader
1919
2020import Data.Aeson
2121import Data.Foldable (traverse_, for_, sequenceA_)
22−import Data.HashMap.Strict (HashMap)
2322import qualified Data.HashMap.Strict as HashMap
2423import qualified "unordered-containers" Data.HashSet as HashSet
2524import Data.Scientific (isInteger)
@@ -52,8 +51,27 @@ instance Monad ValidationResult where
5251 ValidationPassed x >>= f = f x
5352 ValidationFailed msg >>= _ = ValidationFailed msg
5453
55−newtype Validation a = Validation { runValidation :: ReaderT (HashMap Text Schema) ValidationResult a }
56− deriving (Functor, Applicative, Alternative, Monad, MonadReader (HashMap Text Schema))
54+data ValidationConfig = ValidationConfig
55+ { validationPatternChecker :: Pattern -> Text -> Bool
56+ , validationDefinitions :: Definitions Schema
57+ }
58+
59+-- | Default @'ValidationConfig'@:
60+--
61+-- @
62+-- defaultValidationConfig = 'ValidationConfig'
63+-- { 'validationPatternChecker' = \_pattern _str -> True
64+-- , 'validationDefinitions' = mempty
65+-- }
66+-- @
67+defaultValidationConfig :: ValidationConfig
68+defaultValidationConfig = ValidationConfig
69+ { validationPatternChecker = \_pattern _str -> True
70+ , validationDefinitions = mempty
71+ }
72+
73+newtype Validation a = Validation { runValidation :: ReaderT ValidationConfig ValidationResult a }
74+ deriving (Functor, Applicative, Alternative, Monad, MonadReader ValidationConfig)
5775
5876invalid :: String -> Validation a
5977invalid msg = Validation (ReaderT (const (ValidationFailed [msg])))
@@ -63,7 +81,7 @@ valid = pure ()
6381
6482unref :: Reference -> Validation Schema
6583unref (Reference ref) = do
66− ms <- asks (HashMap.lookup ref)
84+ ms <- asks (HashMap.lookup ref . validationDefinitions)
6785 case ms of
6886 Nothing -> invalid $ "unknown schema " ++ show ref
6987 Just s -> pure s
@@ -118,12 +136,17 @@ validateWithSchema schema value
118136 *> when' (not . isInteger . (n /)) multipleOf
119137 (\k -> invalid $ "expected a multiple of " ++ show k ++ " but got " ++ show n)
120138
121− -- TODO: validate schemaPattern
122139 validateString s
123140 = when' (fromIntegral (Text.length s) >) maxLength
124141 (\n -> invalid $ "string exceeds maximum length (should be <=" ++ show n ++ "): " ++ show s)
125142 *> when' (fromIntegral (Text.length s) <) minLength
126143 (\n -> invalid $ "string is too short (length should be >=" ++ show n ++ "): " ++ show s)
144+ *> validatePattern
145+ where
146+ validatePattern = do
147+ check <- asks validationPatternChecker
148+ when' (`check` s) pattern
149+ (\regex -> invalid $ "string does not match pattern " ++ show regex)
127150
128151 validateArray xs
129152 = when' (fromIntegral (Vector.length xs) >) maxItems