Validation.lhs

> -- | Functions for validation of fields
> module Frame.Validation (
>  Validators,
>  -- * Helper methods
>  validate,
>  validateField,
>  allValidated,
>  -- * Validation functions
>  notEmpty,
>  shorterThan,
>  greaterThan,
>  withinBounds
> ) where

> import Database.HaskellDB.DBLayout
> import qualified Data.Map as Map

> import Frame.Utilities
> import Frame.Types

> {-| 
>     A validator is a map associating field names to a list of functions taking a
>     wrapped type to a potential (error) string
> -}
> type Validators = Map FieldName [WrapperType -> Maybe String]

> -- | Type validation functions
> typeValidations :: WrapperType                   -- ^ The wrapped type to validate
>                 -> [WrapperType -> Maybe String] -- ^ The functions to validate that type
> typeValidations (WrapString _ _) = [withinBounds]
> typeValidations w@(WrapError _ _) = [\x -> Just $ wrapError w] -- Constant failure
> typeValidations _ = []

> -- | Validate a particular field against a list of validators
> 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 a whole set of fields against a set of validators
> 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

> -- | True if all fields validate against a set of validators
> allValidated :: Validators -> Fields -> Bool
> allValidated vs fs = and $ Map.elems $ validated $ validate vs fs

> -- | Cannot be empty
> notEmpty :: WrapperType  -- ^ The wrapped value to check
>          -> Maybe String -- ^ Nothing if it's not empty, otherwise an error message
> notEmpty (WrapString _ s) = s /= "" ? "Cannot be empty"
> notEmpty (WrapEmpty _) = notEmpty (WrapString Nothing "")
> notEmpty (WrapError _ s) = notEmpty (WrapString Nothing s)
> notEmpty _ = Nothing

> -- | Must be shorter than a given length
> shorterThan :: Int          -- ^ Length to be shorter than
>             -> WrapperType  -- ^ The wrapped value to check
>             -> Maybe String -- ^ Nothing if it's shorter, otherwise an error message
> 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

> -- | Must be greater than a given number
> greaterThan :: Int          -- ^ Number to be greater than
>             -> WrapperType  -- ^ The wrapped value to check
>             -> Maybe String -- ^ Nothing if it's greater, otherwise an error
> greaterThan x (WrapInt y) = y > x ? "Must be over " ++ show x 
> greaterThan _ _ = Nothing

> -- | A type level check to make sure a string is within the bounds defined
> withinBounds :: WrapperType  -- ^ The wrapped type to check
>              -> Maybe String -- ^ Nothing if it's within bounds, otherwise an error
> withinBounds (WrapString (Just n) s) = length s <= n ? "Must be " ++ show n ++ " characters or less long"
> withinBounds _ = Nothing