module Network.Wai.Routing.Predicate.Header
( Hdr
, HasHdr
, hdr
, hasHdr
) where
import Data.ByteString (ByteString)
import Data.ByteString.From
import Data.CaseInsensitive (mk)
import Data.List (find)
import Data.Maybe
import Data.Monoid
import Network.HTTP.Types.Status
import Network.Wai.Routing.Error
import Network.Wai.Routing.Internal
import Network.Wai.Routing.Predicate.Predicate
import Network.Wai.Routing.Request
newtype Hdr a = Hdr ByteString
hdr :: ByteString -> Hdr a
hdr = Hdr
instance (FromByteString a) => Predicate (Hdr a) Req where
type FVal (Hdr a) = Error
type TVal (Hdr a) = a
apply (Hdr x) =
let msg = "Missing header '" <> x <> "'." in
rqApply (lookupHeader x) readValues (err status400 msg)
newtype HasHdr = HasHdr ByteString
hasHdr :: ByteString -> HasHdr
hasHdr = HasHdr
instance Predicate HasHdr Req where
type FVal HasHdr = Error
type TVal HasHdr = ()
apply (HasHdr x) r =
if isJust $ find ((mk x ==) . fst) (headers r)
then T 0 ()
else F (err status400 ("Missing header '" <> x <> "'."))