{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.Menshen( HasValid(..) , Validator , HasValidSize , size , notEmpty , notBlank , notNull , assertNull , assertTrue , assertFalse , positive , positiveOrZero , negative , negativeOrZero , minInt , maxInt , minDecimal , maxDecimal , pattern , email , (&) , (=~) , ValidationException(..) , HasI18n(..) ) where import Data.Scientific import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Data.Word import Text.Regex.TDFA #if __GLASGOW_HASKELL__ > 708 import Data.Function ((&)) #else infixl 1 & (&) :: a -> (a -> b) -> b x & f = f x #endif class HasI18n a where toI18n :: a -> String data ValidationException = ShouldBeFalse | ShouldBeTrue | ShouldNull | ShouldNotNull | InvalidSize Word64 Word64 | InvalidPositive | InvalidPositiveOrZero | InvalidNegative | InvalidNegativeOrZero | InvalidMax Integer | InvalidMin Integer | InvalidEmail | InvalidNotBlank | InvalidNotEmpty | InvalidPast | InvalidFuture | InvalidPastOrPresent | InvalidFutureOrPresent | InvalidDecimalMax Scientific | InvalidDecimalMin Scientific | InvalidDigits Word8 Word8 | InvalidPattern String deriving Show instance HasI18n ValidationException where toI18n ShouldBeTrue = "must be true" toI18n ShouldBeFalse = "must be false" toI18n ShouldNull = "must be null" toI18n ShouldNotNull = "must not be null" toI18n (InvalidSize a b) = "size must be between " ++ show a ++ " and " ++ show b toI18n InvalidPositive = "must be greater than 0" toI18n InvalidPositiveOrZero = "must be greater than or equal to 0" toI18n InvalidNegative = "must be less than 0" toI18n InvalidNegativeOrZero = "must be less than or equal to 0" toI18n InvalidEmail = "must be a well-formed email address" toI18n InvalidNotBlank = "must not be blank" toI18n InvalidNotEmpty = "must not be empty" toI18n InvalidPast = "must be a past date" toI18n InvalidFuture = "must be a future date" toI18n InvalidPastOrPresent = "must be a date in the past or in the present" toI18n InvalidFutureOrPresent = "must be a date in the present or in the future" toI18n (InvalidMax n) = "must be less than or equal to " ++ show n toI18n (InvalidMin n) = "must be greater than or equal to " ++ show n toI18n (InvalidDecimalMax d) = "must be less than " ++ show d toI18n (InvalidDecimalMin d) = "must be greater than " ++ show d toI18n (InvalidDigits i f) = "numeric value out of bounds (<" ++ show i ++ " digits>.<" ++ show f ++ " digits> expected)" toI18n (InvalidPattern r) = "must match " ++ r class Monad m => HasValid m where invalid :: HasI18n a => a -> m b invalid = error . toI18n instance HasValid IO instance HasValid (Either String) where invalid = Left . toI18n type Validator a = forall m. HasValid m => m a -> m a class HasValidSize a where size :: (Word64, Word64) -> Validator a size (x,y) = \ma -> do a <- ma let la = getLength a if la < x || la > y then invalid $ InvalidSize x y else return a notEmpty :: Validator a notEmpty = \ma -> do a <- ma if getLength a == 0 then invalid InvalidNotEmpty else return a notBlank :: Validator a notBlank = \ma -> do a <- ma if getLength a == 0 then invalid InvalidNotBlank else return a getLength :: a -> Word64 {-# MINIMAL getLength #-} instance HasValidSize TS.Text where getLength = fromIntegral . TS.length instance HasValidSize TL.Text where getLength = fromIntegral . TL.length instance HasValidSize [a] where getLength = fromIntegral . length pattern :: RegexLike Regex a => String -> Validator a pattern p = \ma -> do a <- ma if a =~ p then return a else invalid $ InvalidPattern p emailPattern :: String emailPattern = "^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\\.[A-Za-z]{2,64}$" email :: RegexLike Regex a => Validator a email = \ma -> do a <- ma if a =~ emailPattern then return a else invalid InvalidEmail positive :: (Eq a, Num a) => Validator a positive = \ma -> do a <- ma if a /= 0 && abs a - a == 0 then return a else invalid InvalidPositive positiveOrZero :: (Eq a, Num a) => Validator a positiveOrZero = \ma -> do a <- ma if abs a - a == 0 then return a else invalid InvalidPositiveOrZero negative :: (Eq a, Num a) => Validator a negative = \ma -> do a <- ma if a /= 0 && abs a + a == 0 then return a else invalid InvalidNegative negativeOrZero :: (Eq a, Num a) => Validator a negativeOrZero = \ma -> do a <- ma if abs a + a == 0 then return a else invalid InvalidNegativeOrZero assertTrue :: Validator Bool assertTrue = \ma -> do a <- ma if a then return a else invalid ShouldBeTrue assertFalse :: Validator Bool assertFalse = \ma -> do a <- ma if not a then return a else invalid ShouldBeFalse notNull :: Validator (Maybe a) notNull = \ma -> do a <- ma case a of Just _ -> return a _ -> invalid ShouldNotNull assertNull :: Validator (Maybe a) assertNull = \ma -> do a <- ma case a of Just _ -> invalid ShouldNull _ -> return a maxInt :: (Ord a, Integral a) => a -> Validator a maxInt m = \ma -> do a <- ma if a > m then invalid (InvalidMax $ toInteger m) else return a minInt :: (Ord a, Integral a) => a -> Validator a minInt m = \ma -> do a <- ma if a < m then invalid (InvalidMin $ toInteger m) else return a maxDecimal :: (Ord a, RealFloat a) => a -> Validator a maxDecimal m = \ma -> do a <- ma if a > m then invalid (InvalidDecimalMax $ fromFloatDigits m) else return a minDecimal :: (Ord a, RealFloat a) => a -> Validator a minDecimal m = \ma -> do a <- ma if a < m then invalid (InvalidDecimalMin $ fromFloatDigits m) else return a