module Snap.Predicate.Param
( Parameter (..)
, Param (..)
, ParamOpt (..)
, ParamDef (..)
, HasParam (..)
)
where
import Data.ByteString (ByteString)
import Data.Map (member)
import Data.Monoid
import Data.Typeable
import Data.Predicate
import Snap.Core
import Snap.Predicate.Error
import Snap.Predicate.Internal
import Snap.Util.Readable
data Parameter a = Parameter
{ _pName :: !ByteString
, _pRead :: [ByteString] -> Either ByteString a
, _pDefault :: !(Maybe a)
}
instance Typeable a => Predicate (Parameter a) Request where
type FVal (Parameter a) = Error
type TVal (Parameter a) = a
apply (Parameter nme f def) =
rqApply RqPred
{ _rqName = nme
, _rqRead = f
, _rqDef = def
, _rqCachePref = "parameter:"
, _rqVals = params nme
, _rqError = Just $ err 400 ("Missing parameter '" <> nme <> "'.")
}
instance Show (Parameter a) where
show p = "Parameter: " ++ show (_pName p)
data Param a = Param ByteString
instance (Typeable a, Readable a) => Predicate (Param a) Request where
type FVal (Param a) = Error
type TVal (Param a) = a
apply (Param x) = apply (Parameter x readValues Nothing)
instance Show (Param a) where
show (Param x) = "Param: " ++ show x
data ParamDef a = ParamDef ByteString a
instance (Typeable a, Readable a) => Predicate (ParamDef a) Request where
type FVal (ParamDef a) = Error
type TVal (ParamDef a) = a
apply (ParamDef x d) = apply (Parameter x readValues (Just d))
instance Show a => Show (ParamDef a) where
show (ParamDef x d) = "ParamDef: " ++ show x ++ " [" ++ show d ++ "]"
data ParamOpt a = ParamOpt ByteString
instance (Typeable a, Readable a) => Predicate (ParamOpt a) Request where
type FVal (ParamOpt a) = Error
type TVal (ParamOpt a) = Maybe a
apply (ParamOpt x) =
rqApplyMaybe RqPred
{ _rqName = x
, _rqRead = readValues
, _rqDef = Nothing
, _rqCachePref = "paramopt:"
, _rqVals = params x
, _rqError = Nothing
}
instance Show (ParamOpt a) where
show (ParamOpt x) = "ParamOpt: " ++ show x
data HasParam = HasParam ByteString
instance Predicate HasParam Request where
type FVal HasParam = Error
type TVal HasParam = ()
apply (HasParam x) r = return $
if member x (rqParams r)
then T 0 ()
else F (err 400 ("Missing parameter '" <> x <> "'."))
instance Show HasParam where
show (HasParam x) = "HasParam: " ++ show x