module Snap.Predicate.Header
( Header (..)
, Hdr (..)
, HdrOpt (..)
, HdrDef (..)
, HasHdr (..)
)
where
import Data.ByteString (ByteString)
import Data.CaseInsensitive (mk)
import Data.Maybe
import Data.Monoid
import Data.Typeable
import Data.Predicate
import Snap.Core hiding (headers)
import Snap.Predicate.Error
import Snap.Predicate.Internal
import Snap.Util.Readable
data Header a = Header
{ _hdrName :: !ByteString
, _hdrRead :: [ByteString] -> Either ByteString a
, _hdrDefault :: !(Maybe a)
}
instance Typeable a => Predicate (Header a) Request where
type FVal (Header a) = Error
type TVal (Header a) = a
apply (Header nme f def) =
rqApply RqPred
{ _rqName = nme
, _rqRead = f
, _rqDef = def
, _rqCachePref = "header:"
, _rqVals = headers nme
, _rqError = Just $ err 400 ("Missing header '" <> nme <> "'.")
}
instance Show (Header a) where
show p = "Header: " ++ show (_hdrName p)
data Hdr a = Hdr ByteString
instance (Typeable a, Readable a) => Predicate (Hdr a) Request where
type FVal (Hdr a) = Error
type TVal (Hdr a) = a
apply (Hdr x) = apply (Header x readValues Nothing)
instance Show (Hdr a) where
show (Hdr x) = "Hdr: " ++ show x
data HdrDef a = HdrDef ByteString a
instance (Typeable a, Readable a) => Predicate (HdrDef a) Request where
type FVal (HdrDef a) = Error
type TVal (HdrDef a) = a
apply (HdrDef x d) = apply (Header x readValues (Just d))
instance Show a => Show (HdrDef a) where
show (HdrDef x d) = "HdrDef: " ++ show x ++ " [" ++ show d ++ "]"
data HdrOpt a = HdrOpt ByteString
instance (Typeable a, Readable a) => Predicate (HdrOpt a) Request where
type FVal (HdrOpt a) = Error
type TVal (HdrOpt a) = Maybe a
apply (HdrOpt x) =
rqApplyMaybe RqPred
{ _rqName = x
, _rqRead = readValues
, _rqDef = Nothing
, _rqCachePref = "headeropt:"
, _rqVals = headers x
, _rqError = Nothing
}
instance Show (HdrOpt a) where
show (HdrOpt x) = "HdrOpt: " ++ show x
data HasHdr = HasHdr ByteString
instance Predicate HasHdr Request where
type FVal HasHdr = Error
type TVal HasHdr = ()
apply (HasHdr x) r = return $
if isJust (getHeaders (mk x) r)
then T 0 ()
else F (err 400 ("Missing header '" <> x <> "'."))
instance Show HasHdr where
show (HasHdr x) = "HasHdr: " ++ show x