Validator.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Validator
    ( -- * Core monad and runners
      ValidationM, ValidationT
    , ValidationRule, ValidationRuleT
    , TransValidationRule, TransValidationRuleT
    , runValidator, runValidatorT
      -- * Combinators
    , (>=>), (<=<)
      -- * Checks
    , minLength, maxLength, lengthBetween, notEmpty
    , largerThan, smallerThan, valueBetween
    , matchesRegex
    , conformsPred, conformsPredM
      -- * Transforming checks
    , requiredValue, nonEmptyList
    , conformsPredTrans, conformsPredTransM
      -- * Helper classes and types
    , HasLength(..), ConvertibleStrings(..)
    , Int64
      -- * Regular expression helpers
    , re, mkRegexQQ, Regex
    )
where

import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Trans.Either
import Data.Int
import Data.String.Conversions
import Text.Regex.PCRE.Heavy
import qualified Data.List.NonEmpty as NEL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL

-- | The validation monad
type ValidationM e = ValidationT e Identity

-- | The validation monad transformer
newtype ValidationT e m a
    = ValidationT { unValidationT :: EitherT e m a }
      deriving (Monad, Functor, Applicative, Alternative, MonadPlus, MonadTrans)

-- | Run a validation on a type 'a'
runValidator :: TransValidationRule e a b -> a -> Either e b
runValidator a b = runIdentity $ runValidatorT a b
{-# INLINE runValidator #-}

-- | Run a validation on a type 'a'
runValidatorT :: Monad m => TransValidationRuleT e m a b -> a -> m (Either e b)
runValidatorT validationSteps input =
    runEitherT $ unValidationT (validationSteps input)
{-# INLINE runValidatorT #-}

-- | A validation rule. Combine using @('>=>')@ or @('<=<')@
type ValidationRule e a = ValidationRuleT e Identity a

-- | A validation rule. Combine using @('>=>')@ or @('<=<')@
type ValidationRuleT e m a = TransValidationRuleT e m a a

-- | A transforming validation rule. Combine using @('>=>')@ or @('<=<')@
type TransValidationRule e a b = TransValidationRuleT e Identity a b

-- | A transforming validation rule. Combine using @('>=>')@ or @('<=<')@
type TransValidationRuleT e m a b = a -> ValidationT e m b

-- | All types that have a length, eg. 'String', '[a]', 'Vector a', etc.
class HasLength a where
    getLength :: a -> Int64

instance HasLength [a] where
    getLength = fromIntegral . length
    {-# INLINE getLength #-}

instance HasLength T.Text where
    getLength = fromIntegral . T.length
    {-# INLINE getLength #-}

instance HasLength TL.Text where
    getLength = TL.length
    {-# INLINE getLength #-}

instance HasLength BS.ByteString where
    getLength = fromIntegral . BS.length
    {-# INLINE getLength #-}

instance HasLength BSL.ByteString where
    getLength = BSL.length
    {-# INLINE getLength #-}

-- | Mark a custom check as failed
checkFailed :: Monad m => e -> ValidationT e m a
checkFailed = ValidationT . left
{-# INLINE checkFailed #-}

-- | Check that the value is at least N elements long
minLength :: (Monad m, HasLength a) => Int64 -> e -> ValidationRuleT e m a
minLength lowerBound e obj = largerThan lowerBound e (getLength obj) >> return obj
{-# INLINE minLength #-}

-- | Check that the value is at maxium N elements long
maxLength :: (Monad m, HasLength a) => Int64 -> e -> ValidationRuleT e m a
maxLength upperBound e obj =
    smallerThan upperBound e (getLength obj) >> return obj
{-# INLINE maxLength #-}

-- | Check that the value's length is between N and M
lengthBetween :: (Monad m, HasLength a) => Int64 -> Int64 -> e -> ValidationRuleT e m a
lengthBetween lowerBound upperBound e obj = valueBetween lowerBound upperBound e (getLength obj) >> return obj
{-# INLINE lengthBetween #-}

-- | Specialized minLength with N = 1
notEmpty :: (Monad m, HasLength a) => e -> ValidationRuleT e m a
notEmpty = minLength 1
{-# INLINE notEmpty #-}

-- | Check that a value is larger than N
largerThan :: (Monad m, Ord a) => a -> e -> ValidationRuleT e m a
largerThan lowerBound = conformsPred (>= lowerBound)
{-# INLINE largerThan #-}

-- | Check that a value is smaller than N
smallerThan :: (Monad m, Ord a) => a -> e -> ValidationRuleT e m a
smallerThan upperBound = conformsPred (<= upperBound)
{-# INLINE smallerThan #-}

-- | Check that a value is between M and N
valueBetween :: (Monad m, Ord a) => a -> a -> e -> ValidationRuleT e m a
valueBetween lowerBound upperBound e = largerThan lowerBound e >=> smallerThan upperBound e
{-# INLINE valueBetween #-}

-- | Checks that a value matches a regular expression
matchesRegex :: (ConvertibleStrings SBS a, ConvertibleStrings a SBS, Monad m) => Regex -> e -> ValidationRuleT e m a
matchesRegex r = conformsPred (=~ r)
{-# INLINE matchesRegex #-}

-- | Check that a value conforms a predicate
conformsPred :: Monad m => (a -> Bool) -> e -> ValidationRuleT e m a
conformsPred predicate e obj = unless (predicate obj) (checkFailed e) >> return obj
{-# INLINE conformsPred #-}

-- | Check that a value conforms a predicate
conformsPredM :: Monad m => (a -> m Bool) -> e -> ValidationRuleT e m a
conformsPredM predicate e obj =
    do res <- lift $ predicate obj
       unless res (checkFailed e) >> return obj
{-# INLINE conformsPredM #-}

-- | Check that an optional value is actually set to 'Just a'
requiredValue :: Monad m => e -> TransValidationRuleT e m (Maybe a) a
requiredValue = conformsPredTrans id
{-# INLINE requiredValue #-}

-- | Check that a list is not empty
nonEmptyList :: Monad m => e -> TransValidationRuleT e m [a] (NEL.NonEmpty a)
nonEmptyList = conformsPredTrans NEL.nonEmpty
{-# INLINE nonEmptyList #-}

-- | Do some check returning 'Nothing' if the value is invalid and 'Just a' otherwise.
conformsPredTrans :: Monad m => (a -> Maybe b) -> e -> TransValidationRuleT e m a b
conformsPredTrans f e obj =
    case f obj of
      Nothing -> checkFailed e
      Just val -> return val
{-# INLINE conformsPredTrans #-}

-- | Do some check returning 'Nothing' if the value is invalid and 'Just a' otherwise.
conformsPredTransM :: Monad m => (a -> m (Maybe b)) -> e -> TransValidationRuleT e m a b
conformsPredTransM f e obj =
    do res <- lift $ f obj
       case res of
         Nothing -> checkFailed e
         Just val -> return val
{-# INLINE conformsPredTransM #-}