>
> module Frame.Validation (
> Validators,
>
> validate,
> validateField,
> allValidated,
>
> notEmpty,
> shorterThan,
> greaterThan,
> withinBounds
> ) where
> import Database.HaskellDB.DBLayout
> import qualified Data.Map as Map
> import Frame.Utilities
> import Frame.Types
>
> type Validators = Map FieldName [WrapperType -> Maybe String]
>
> typeValidations :: WrapperType
> -> [WrapperType -> Maybe String]
> typeValidations (WrapString _ _) = [withinBounds]
> typeValidations w@(WrapError _ _) = [\x -> Just $ wrapError w]
> typeValidations _ = []
>
> validateField :: [WrapperType -> Maybe String] -> WrapperType -> [Maybe String]
> validateField fs t = map (\f -> f t) (fs ++ typeValidations t)
> validateField' :: Validators -> FieldName -> WrapperType -> [Maybe String]
> validateField' vs fn t = case Map.lookup fn vs of
> Just fs -> validateField fs t
> Nothing -> []
>
> validate :: Validators -> Fields -> Map.Map FieldName [Maybe String]
> validate vs = Map.mapWithKey (validateField' vs)
> maybeAnd :: [Maybe String] -> Bool
> maybeAnd ms = and $ Prelude.map isNothing ms
> validated :: Map.Map FieldName [Maybe String] -> Map.Map FieldName Bool
> validated = Map.map maybeAnd
>
> allValidated :: Validators -> Fields -> Bool
> allValidated vs fs = and $ Map.elems $ validated $ validate vs fs
>
> notEmpty :: WrapperType
> -> Maybe String
> notEmpty (WrapString _ s) = s /= "" ? "Cannot be empty"
> notEmpty (WrapEmpty _) = notEmpty (WrapString Nothing "")
> notEmpty (WrapError _ s) = notEmpty (WrapString Nothing s)
> notEmpty _ = Nothing
>
> shorterThan :: Int
> -> WrapperType
> -> Maybe String
> shorterThan n (WrapString _ s) = length s < n ? "Must be under " ++ show n ++ " characters long"
> shorterThan n (WrapEmpty _) = shorterThan n (WrapString Nothing "")
> shorterThan n (WrapError _ s) = shorterThan n (WrapString Nothing s)
> shorterThan _ _ = Nothing
>
> greaterThan :: Int
> -> WrapperType
> -> Maybe String
> greaterThan x (WrapInt y) = y > x ? "Must be over " ++ show x
> greaterThan _ _ = Nothing
>
> withinBounds :: WrapperType
> -> Maybe String
> withinBounds (WrapString (Just n) s) = length s <= n ? "Must be " ++ show n ++ " characters or less long"
> withinBounds _ = Nothing