packages feed

snap-predicates 0.1.0 → 0.2.0

raw patch · 20 files changed

+1271/−290 lines, 20 filesdep +attoparsecdep +monads-tfdep +text

Dependencies added: attoparsec, monads-tf, text

Files

README.md view
@@ -1,26 +1,18 @@ Snap-Predicates =============== -This library provides a definition of a type-class `Predicate`+This library provides the definition of a type-class `Predicate` together with several concrete implementations which are used to constrain the set of possible `Snap` handlers in a type-safe way. -Example----------```haskell-{-# LANGUAGE OverloadedStrings, TypeOperators #-}-module Main where+A module [Snap.Predicates.Tutorial](http://hackage.haskell.org/packages/archive/snap-predicates/latest/doc/html/Snap-Predicates-Tutorial.html)+is included, outlining the basic concepts. -import Data.ByteString (ByteString)-import Data.Monoid-import Data.Predicate-import Snap.Core-import Snap.Routes-import Snap.Predicates-import Snap.Http.Server+Example Usage+------------- +```haskell main :: IO () main = do     mapM_ putStrLn (showRoutes sitemap)@@ -28,32 +20,17 @@  sitemap :: Routes Snap () sitemap = do-    get "/a" getUser $-        AcceptJson :&: (Param "name" :|: Param "nick") :&: Param "foo"--    get "/b" getUser' $-        AcceptJson :&: (Param "name" :||: Param "nick") :&: Param "foo"--    get  "/status" status      $ Fail (410, Just "Gone.")-    post "/"       createUser  $ AcceptThrift-    post "/"       createUser' $ AcceptJson--getUser :: AcceptJson :*: ByteString :*: ByteString -> Snap ()-getUser (_ :*: name :*: foo) =-    writeBS $ "getUser: name or nick=" <> name <> " foo=" <> foo+    head_ "/status" (const $ return ()) -getUser' :: AcceptJson :*: (ByteString :+: ByteString) :*: ByteString -> Snap ()-getUser' (_ :*: name :*: foo) =-    case name of-        Left  a -> writeBS $ "getUser: name=" <> a <> " foo=" <> foo-        Right b -> writeBS $ "getUser: nick=" <> b <> " foo=" <> foo+    get  "/foo" listFoo $+        Accept Text Plain :&: ParamDef "off" 0 :&: ParamDef "size" 100 -createUser :: AcceptThrift -> Snap ()-createUser _ = writeBS "createUser"+    post "/foo" createFoo $+        Accept Text Plain :&: ContentType Application Protobuf -createUser' :: AcceptJson -> Snap ()-createUser' _ = writeBS "createUser'"+listFoo :: MediaType Text Plain :*: Int :*: Int -> Snap ()+listFoo (_mt :*: _off :*: _size) = return () -status :: AcceptJson :*: Char -> Snap ()-status _ = writeBS "status"+createFoo :: MediaType Text Plain :*: Content Application Protobuf -> Snap ()+createFoo (_mt :*: _ct) = return () ```
snap-predicates.cabal view
@@ -1,6 +1,6 @@ name:                snap-predicates-version:             0.1.0-synopsis:            Predicates for route definitions.+version:             0.2.0+synopsis:            Declarative routing for Snap. license:             MIT license-file:        LICENSE author:              Toralf Wittner, Brendan Hay@@ -13,7 +13,7 @@ extra-source-files:  README.md  description:-    Provides a definition of a predicate type-class together+    Provides the definition of a predicate type-class together     with several concrete implementations which are used to     constrain the set of possible Snap handlers in a type-safe     way.@@ -25,27 +25,34 @@     ghc-prof-options: -prof -auto-all      exposed-modules:-        Data.Predicate+        Data.ByteString.Readable+      , Data.Predicate+      , Data.Predicate.Env       , Snap.Predicates-      , Snap.Routes+      , Snap.Predicates.Accept+      , Snap.Predicates.Error+      , Snap.Predicates.Params+      , Snap.Predicates.Content+      , Snap.Predicates.MediaTypes       , Snap.Predicates.Tutorial+      , Snap.Routes +    other-modules:+        Snap.Predicates.Internal+        Snap.Predicates.MediaTypes.Internal+      , Snap.Predicates.Parsers.Accept+      , Snap.Predicates.Parsers.Shared+     build-depends:         base             >= 4   && < 5       , transformers     >= 0.3+      , monads-tf        >= 0.1       , bytestring       >= 0.9+      , text             >= 0.11       , containers       >= 0.5       , case-insensitive >= 1.0       , snap-core        >= 0.9--    other-extensions:-       BangPatterns-     , FlexibleInstances-     , GADTs-     , MultiParamTypeClasses-     , OverloadedStrings-     , TypeFamilies-     , TypeOperators+      , attoparsec       >= 0.10  test-suite snap-predicates-test-suite     type:             exitcode-stdio-1.0@@ -63,10 +70,14 @@     build-depends:         base             >= 4   && < 5       , transformers     >= 0.3+      , monads-tf        >= 0.1       , bytestring       >= 0.9+      , text             >= 0.11       , containers       >= 0.5       , case-insensitive >= 1.0       , snap-core        >= 0.9+      , text             >= 0.11+      , attoparsec       >= 0.10        , HUnit                      >= 1.2       , QuickCheck                 >= 2.3@@ -74,15 +85,6 @@       , test-framework-hunit       >= 0.2       , test-framework-quickcheck2 >= 0.2 -    other-extensions:-       BangPatterns-     , FlexibleInstances-     , GADTs-     , MultiParamTypeClasses-     , OverloadedStrings-     , TypeFamilies-     , TypeOperators- source-repository head     type:             git-    location:         https://github.com/twittner/snap-predicates+    location:         git://github.com/twittner/snap-predicates.git
+ src/Data/ByteString/Readable.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}+module Data.ByteString.Readable (Readable (..)) where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Text.Read+import qualified Data.Text as T+import qualified Data.ByteString as S++-- | The type-class 'Readable' is used to convert 'ByteString' values to+-- values of other types. Most instances assume the 'ByteString' is+-- encoded via UTF-8.+--+-- Minimal complete instance definition is given by 'readByteString'.+class Readable a where+    -- | Parse the given 'ByteString' into a typed value and also return+    -- the unconsumed bytes. In case of error, provide an error message.+    readByteString :: ByteString -> Either ByteString (a, ByteString)++    -- | Parse the given 'ByteString' into a list of typed values and+    -- return the unconsumed bytes. In case of error, provide an error+    -- message. Instances can use this function to express their way of+    -- reading lists of values. The default implementation parses+    -- comma-separated values (also accepting interspersed spaces).+    readByteStringList :: ByteString -> Either ByteString ([a], ByteString)+    readByteStringList s = parseList ([], s)++    -- | Either turn the given 'ByteString' into a typed value or an error+    -- message. This function also checks, that all input bytes have been+    -- consumed or else it will fail.+    fromByteString :: ByteString -> Either ByteString a+    fromByteString s = do+        (v, s') <- readByteString s+        if S.null s'+            then Right v+            else Left ("unconsumed bytes: '" <> s' <> "'.")++parseList :: Readable a => ([a], ByteString) -> Either ByteString ([a], ByteString)+parseList (!acc, !s)+    | S.null s  = return (reverse acc, s)+    | otherwise = do+        (a, s') <- readByteString s+        parseList (a:acc, S.dropWhile noise s')+  where+    noise w = w `elem` [0x20, 0x2C] -- [' ', ',']++instance Readable a => Readable (Maybe a) where+    readByteString s =+        case readByteString s of+            Left       _  -> Right (Nothing, "")+            Right (v, s') -> Right (Just v, s')++instance Readable a => Readable [a] where+    readByteString = readByteStringList++instance Readable ByteString where+    readByteString = Right . (, "")++instance Readable Text where+    readByteString s = (, "") <$> mapLeft (decodeUtf8' s)++instance Readable Char where+    readByteString s = do+        t <- mapLeft (decodeUtf8' s)+        return (T.head t, encodeUtf8 (T.tail t))++    readByteStringList s = (, "") . T.unpack <$> mapLeft (decodeUtf8' s)++instance Readable Double where+    readByteString = parse (signed double)++instance Readable Int where+    readByteString = parse (signed decimal)++mapLeft :: Show e => Either e a -> Either ByteString a+mapLeft (Left  s) = Left (encodeUtf8 . T.pack . show $ s)+mapLeft (Right x) = Right x++parse :: (Text -> Either String (a, Text)) -> ByteString -> Either ByteString (a, ByteString)+parse f s = do+    t <- mapLeft (decodeUtf8' s)+    case f t of+        Left       e  -> Left (encodeUtf8 (T.pack e))+        Right (v, t') -> return (v, encodeUtf8 t')
src/Data/Predicate.hs view
@@ -5,14 +5,30 @@ {-# LANGUAGE FlexibleInstances     #-} module Data.Predicate where +import Prelude hiding (and, or) import Control.Applicative hiding (Const)-import Control.Monad+import Control.Monad.State.Strict+import Data.Predicate.Env (Env)+import qualified Data.Predicate.Env as E +-- | 'Delta' is a measure of distance. It is (optionally)+-- used in predicates that evaluate to 'T' but not uniquely so, i.e.+-- different evaluations of 'T' are possible and they may have a different+-- \"fitness\".+--+-- An example is content-negotiation. A HTTP request may specify+-- a preference list of various media-types. A predicate matching one+-- specific media-type evaluates to 'T', but other media-types may match+-- even better. To represent this ambivalence, the predicate will include+-- a delta value which can be used to decide which of the matching+-- predicates should be preferred.+type Delta = Double+ -- | A 'Bool'-like type where each branch 'T'rue or 'F'alse carries -- some meta-data which is threaded through 'Predicate' evaluation.-data Boolean f t =-    F (Maybe f) -- ^ logical False with some meta-data-  | T t         -- ^ logical True with some meta-data+data Boolean f t+  = F f       -- ^ logical False with some meta-data+  | T Delta t -- ^ logical True with some meta-data   deriving (Eq, Show)  -- | The 'Predicate' class declares the function 'apply' which@@ -24,28 +40,7 @@ class Predicate p a where     type FVal p     type TVal p-    apply :: p -> a -> Boolean (FVal p) (TVal p)--instance Monad (Boolean f) where-    return      = T-    (T x) >>= g = g x-    (F x) >>= _ = F x--instance MonadPlus (Boolean f) where-    mzero           = F Nothing-    (F _) `mplus` b = b-    b     `mplus` _ = b--instance Functor (Boolean f) where-    fmap = liftM--instance Applicative (Boolean f) where-    pure  = return-    (<*>) = ap--instance Alternative (Boolean f) where-    empty = mzero-    (<|>) = mplus+    apply :: p -> a -> State Env (Boolean (FVal p) (TVal p))  -- | A 'Predicate' instance which always returns 'T' with -- the given value as T's meta-data.@@ -55,7 +50,7 @@ instance Predicate (Const f t) a where     type FVal (Const f t) = f     type TVal (Const f t) = t-    apply (Const a) _     = T a+    apply (Const a) _     = return (T 0 a)  instance Show t => Show (Const f t) where     show (Const a) = "Const " ++ show a@@ -68,7 +63,7 @@ instance Predicate (Fail f t) a where     type FVal (Fail f t) = f     type TVal (Fail f t) = t-    apply (Fail a) _     = F $ Just a+    apply (Fail a) _     = return (F a)  instance Show f => Show (Fail f t) where     show (Fail a) = "Fail " ++ show a@@ -76,13 +71,22 @@ -- | A 'Predicate' instance corresponding to the logical -- OR connective of two 'Predicate's. It requires the -- meta-data of each 'T'rue branch to be of the same type.+--+-- If both arguments evaluate to 'T' the one with the+-- smaller 'Delta' will be preferred, or--if equal--the+-- left-hand argument. data a :|: b = a :|: b  instance (Predicate a c, Predicate b c, TVal a ~ TVal b, FVal a ~ FVal b) => Predicate (a :|: b) c   where     type FVal (a :|: b) = FVal a     type TVal (a :|: b) = TVal a-    apply (a :|: b) r   = apply a r <|> apply b r+    apply (a :|: b) r   = or <$> apply a r <*> apply b r+      where+        or x@(T d0 _) y@(T d1 _) = if d1 < d0 then y else x+        or x@(T _  _)   (F    _) = x+        or (F      _) x@(T _  _) = x+        or (F      _) x@(F    _) = x  instance (Show a, Show b) => Show (a :|: b) where     show (a :|: b) = "(" ++ show a ++ " | " ++ show b ++ ")"@@ -92,13 +96,22 @@ -- | A 'Predicate' instance corresponding to the logical -- OR connective of two 'Predicate's. The meta-data of -- each 'T'rue branch can be of different types.+--+-- If both arguments evaluate to 'T' the one with the+-- smaller 'Delta' will be preferred, or--if equal--the+-- left-hand argument. data a :||: b = a :||: b  instance (Predicate a c, Predicate b c, FVal a ~ FVal b) => Predicate (a :||: b) c   where     type FVal (a :||: b) = FVal a     type TVal (a :||: b) = TVal a :+: TVal b-    apply (a :||: b) r   = (Left <$> apply a r) <|> (Right <$> apply b r)+    apply (a :||: b) r   = or <$> apply a r <*> apply b r+      where+        or (T d0 t0) (T d1 t1) = if d1 < d0 then T d1 (Right t1) else T d0 (Left t0)+        or (T  d  t) (F     _) = T d (Left t)+        or (F     _) (T  d  t) = T d (Right t)+        or (F     _) (F     f) = F f  instance (Show a, Show b) => Show (a :||: b) where     show (a :||: b) = "(" ++ show a ++ " || " ++ show b ++ ")"@@ -114,7 +127,23 @@   where     type FVal (a :&: b) = FVal a     type TVal (a :&: b) = TVal a :*: TVal b-    apply (a :&: b) r   = (:*:) <$> apply a r <*> apply b r+    apply (a :&: b) r   = and <$> apply a r <*> apply b r+      where+        and (T d x) (T w y) = T (d + w) (x :*: y)+        and (T _ _) (F   f) = F f+        and (F   f) _       = F f  instance (Show a, Show b) => Show (a :&: b) where     show (a :&: b) = "(" ++ show a ++ " & " ++ show b ++ ")"++-- | Evaluate the given predicate 'p' against the given value 'a'.+eval :: Predicate p a => p -> a -> Boolean (FVal p) (TVal p)+eval p a = evalState (apply p a) E.empty++-- | The 'with' function will invoke the given function only if the predicate 'p'+-- applied to the test value 'a' evaluates to 'T'.+with :: (Monad m, Predicate p a) => p -> a -> (TVal p -> m ()) -> m ()+with p a f =+    case eval p a of+        T _ x -> f x+        _     -> return ()
+ src/Data/Predicate/Env.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Predicate.Env+  ( Env+  , empty+  , lookup+  , insert+  )+where++import Prelude hiding (lookup)+import Control.Monad.State.Strict+import Data.ByteString (ByteString)+import Data.Dynamic+import qualified Data.Map.Strict as M++-- | An environment for predicates, consisting of+-- mappings form 'ByteString's to 'Dynamic' values.+newtype Env = Env+  { _unenv :: M.Map ByteString Dynamic }++-- | An empty environment.+empty :: Env+empty = Env M.empty++-- | Try to get the associated value for the given key.+-- Only successful iff, (i) 'Env' contains a binding for 'k'+-- and (ii) the type of value and target match.+lookup :: (MonadState m, StateType m ~ Env, Typeable a) => ByteString -> m (Maybe a)+lookup k = gets $ maybe Nothing fromDynamic . M.lookup k . _unenv++-- | Add a binding from key to value to 'Env', overriding+-- previous bindings if existing.+insert :: (MonadState m, StateType m ~ Env, Typeable a) => ByteString -> a -> m ()+insert k v = modify $ Env . M.insert k (toDyn v) . _unenv
src/Snap/Predicates.hs view
@@ -1,78 +1,14 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Snap.Predicates-  ( Accept (..)-  , AcceptJson (..)-  , AcceptThrift (..)-  , Param (..)+  ( module Snap.Predicates.Error+  , module Snap.Predicates.Accept+  , module Snap.Predicates.Content+  , module Snap.Predicates.MediaTypes+  , module Snap.Predicates.Params   ) where -import Data.ByteString (ByteString)-import Data.Monoid-import Data.Word-import Data.Predicate-import Snap.Core-import qualified Data.CaseInsensitive as CI-import qualified Data.Map.Strict as M---- | A 'Predicate' against the 'Request's "Accept" header.-data Accept = Accept ByteString deriving Eq--instance Predicate Accept Request where-    type FVal Accept = (Word, Maybe ByteString)-    type TVal Accept = ()-    apply (Accept x) r =-        if x `elem` headers' r "accept"-            then T ()-            else F $ Just (406, Just $ "Expected 'Accept: " <> x <> "'.")--instance Show Accept where-    show (Accept x) = "Accept: " ++ show x---- | A 'Predicate' which is true only for Accept: "application/json".-data AcceptJson = AcceptJson deriving Eq--instance Predicate AcceptJson Request where-    type FVal AcceptJson = (Word, Maybe ByteString)-    type TVal AcceptJson = AcceptJson-    apply AcceptJson r =-        apply (Accept "application/json") r >> return AcceptJson--instance Show AcceptJson where-    show AcceptJson = "Accept: \"application/json\""---- | A 'Predicate' which is true only for Accept: "application/x-thrift".-data AcceptThrift = AcceptThrift deriving Eq--instance Predicate AcceptThrift Request where-    type FVal AcceptThrift = (Word, Maybe ByteString)-    type TVal AcceptThrift = AcceptThrift-    apply AcceptThrift r =-        apply (Accept "application/x-thrift") r >> return AcceptThrift--instance Show AcceptThrift where-    show AcceptThrift = "Accept: \"application/x-thrift\""---- | A 'Predicate' looking for some parameter value.-data Param = Param ByteString deriving Eq--instance Predicate Param Request where-    type FVal Param = (Word, Maybe ByteString)-    type TVal Param = ByteString-    apply (Param x) r =-        case params' r x of-            []    -> F $ Just (400, Just $ "Expected parameter '" <> x <> "'.")-            (v:_) -> T v--instance Show Param where-    show (Param x) = "Param: " ++ show x---- Internal helpers:--headers' :: Request -> ByteString -> [ByteString]-headers' rq name = maybe [] id . getHeaders (CI.mk name) $ rq--params' :: Request -> ByteString -> [ByteString]-params' rq name = maybe [] id . M.lookup name . rqParams $ rq+import Snap.Predicates.Error+import Snap.Predicates.Accept+import Snap.Predicates.Content+import Snap.Predicates.MediaTypes+import Snap.Predicates.Params
+ src/Snap/Predicates/Accept.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicates.Accept+  ( Accept (..)+  , module Snap.Predicates.MediaTypes+  )+where++import Data.Monoid hiding (All)+import Data.String+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicates.Error+import Snap.Predicates.MediaTypes+import Snap.Predicates.MediaTypes.Internal+import qualified Data.Predicate.Env as E++-- | A 'Predicate' against the 'Request's \"Accept\" header.+data Accept t s = Accept t s deriving Eq++instance (MType t, MSubType s) => Predicate (Accept t s) Request where+    type FVal (Accept t s) = Error+    type TVal (Accept t s) = MediaType t s+    apply (Accept x y) r   = do+        mtypes <- E.lookup "accept" >>= maybe (readMediaTypes "accept" r) return+        if null mtypes+            then return (T 0 (MediaType x y 1.0 []))+            else case mediaType True x y mtypes of+               Just m  -> return (T (1.0 - _quality m) m)+               Nothing -> return (F (err 406 message))+      where+        message = "Expected 'Accept: "+                    <> fromString (show x)+                    <> "/"+                    <> fromString (show y)+                    <> "'."++instance (Show t, Show s) => Show (Accept t s) where+    show (Accept t s) = "Accept: " ++ show t ++ "/" ++ show s
+ src/Snap/Predicates/Content.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicates.Content+  ( Content+  , ContentType (..)+  , module Snap.Predicates.MediaTypes+  )+where++import Data.Monoid hiding (All)+import Data.String+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicates.Error+import Snap.Predicates.MediaTypes+import Snap.Predicates.MediaTypes.Internal+import qualified Data.Predicate.Env as E++type Content x y = MediaType x y++-- | A 'Predicate' against the 'Request's \"Content-Type\" header.+data ContentType t s = ContentType t s deriving Eq++instance (MType t, MSubType s) => Predicate (ContentType t s) Request where+    type FVal (ContentType t s) = Error+    type TVal (ContentType t s) = MediaType t s+    apply (ContentType x y) r   = do+        mtypes <- E.lookup "content-type" >>= maybe (readMediaTypes "content-type" r) return+        case mediaType False x y mtypes of+               Just m  -> return (T 0 m)+               Nothing -> return (F (err 415 message))+      where+        message = "Expected 'Content-Type: "+                    <> fromString (show x)+                    <> "/"+                    <> fromString (show y)+                    <> "'."++instance (Show t, Show s) => Show (ContentType t s) where+    show (ContentType t s) = "ContentType: " ++ show t ++ "/" ++ show s
+ src/Snap/Predicates/Error.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE BangPatterns #-}+module Snap.Predicates.Error where++import Data.ByteString (ByteString)+import Data.Word++-- | The error type used as 'F' meta-data in all snap predicates.+data Error = Error+  { _status  :: !Word               -- ^ (HTTP) status code+  , _message :: !(Maybe ByteString) -- ^ optional status message+  } deriving (Eq, Show)++-- | Convenience function to construct 'Error' values from+-- status code and status message.+err :: Word -> ByteString -> Error+err s = Error s . Just
+ src/Snap/Predicates/Internal.hs view
@@ -0,0 +1,21 @@+module Snap.Predicates.Internal+  ( headers+  , params+  , safeHead+  )+where++import Snap.Core hiding (headers)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import qualified Data.Map.Strict as M++headers :: Request -> ByteString -> [ByteString]+headers rq name = maybe [] id . getHeaders (mk name) $ rq++params :: Request -> ByteString -> [ByteString]+params rq name = maybe [] id . M.lookup name . rqParams $ rq++safeHead :: [a] -> Maybe a+safeHead []    = Nothing+safeHead (h:_) = Just h
+ src/Snap/Predicates/MediaTypes.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns      #-}+module Snap.Predicates.MediaTypes+  ( -- * Types+    MType (..)+  , MSubType (..)+  , MediaType (..)++  -- * Media-Types+  , Type (..)+  , All (..)+  , Application (..)+  , Audio (..)+  , Image (..)+  , Message (..)+  , Multipart (..)+  , Text (..)+  , Video (..)++  -- * Media-Sub-Types+  , SubType (..)+  , AtomXml (..)+  , Css (..)+  , Csv (..)+  , Encrypted (..)+  , FormData (..)+  , Gif (..)+  , Gzip (..)+  , Javascript (..)+  , Jpeg (..)+  , Json (..)+  , Mixed (..)+  , Mp4 (..)+  , Mpeg (..)+  , OctetStream (..)+  , Ogg (..)+  , Partial (..)+  , Plain (..)+  , Png (..)+  , Postscript (..)+  , Protobuf (..)+  , RdfXml (..)+  , RssXml (..)+  , Tar (..)+  , Tiff (..)+  , Thrift (..)+  , Vorbis (..)+  , Webm (..)+  , XhtmlXml (..)+  , Xml (..)+  )+where++import Data.ByteString (ByteString)++-- | Type-class for converting a 'ByteString' to a media-type.+class (Show a, Eq a) => MType a where+    toType :: a -> ByteString -> Maybe a++-- | Type-class for converting a 'ByteString' to a media-subtype.+class (Show a, Eq a) => MSubType a where+    toSubType :: a -> ByteString -> Maybe a++-- | The Media-type representation.+data MediaType t s = MediaType+  { _type    :: !t+  , _subtype :: !s+  , _quality :: !Double+  , _params  :: ![(ByteString, ByteString)]+  } deriving (Eq, Show)++-- Media-Types:++-- | Generic media-type.+data Type = Type ByteString deriving Eq++instance MType Type where+    toType o@(Type t) s = if t == s then Just o else Nothing++instance Show Type where+    show (Type t) = show t++data Application = Application deriving Eq++instance MType Application where+    toType _ "application" = Just Application+    toType _ _             = Nothing++instance Show Application where+    show _ = "application"++data Audio = Audio deriving Eq++instance MType Audio where+    toType _ "audio" = Just Audio+    toType _ _       = Nothing++instance Show Audio where+    show _ = "audio"++data Image = Image deriving Eq++instance MType Image where+    toType _ "image" = Just Image+    toType _ _       = Nothing++instance Show Image where+    show _ = "image"++data Message = Message deriving Eq++instance MType Message where+    toType _ "message" = Just Message+    toType _ _         = Nothing++instance Show Message where+    show _ = "message"++data Multipart = Multipart deriving Eq++instance MType Multipart where+    toType _ "multipart" = Just Multipart+    toType _ _           = Nothing++instance Show Multipart where+    show _ = "multipart"++data Text = Text deriving Eq++instance MType Text where+    toType _ "text" = Just Text+    toType _ _      = Nothing++instance Show Text where+    show _ = "text"++data Video = Video deriving Eq++instance MType Video where+    toType _ "video" = Just Video+    toType _ _       = Nothing++instance Show Video where+    show _ = "video"++-- Media-Subtypes:++-- | Generic media-subtype.+data SubType = SubType ByteString deriving Eq++instance MSubType SubType where+    toSubType o@(SubType t) s = if t == s then Just o else Nothing++instance Show SubType where+    show (SubType t) = show t++data AtomXml = AtomXml deriving Eq++instance MSubType AtomXml where+    toSubType _ "atom+xml" = Just AtomXml+    toSubType _ _          = Nothing++instance Show AtomXml where+    show _ = "atom+xml"++data Css = Css deriving Eq++instance MSubType Css where+    toSubType _ "css" = Just Css+    toSubType _ _     = Nothing++instance Show Css where+    show _ = "css"++data Csv = Csv deriving Eq++instance MSubType Csv where+    toSubType _ "csv" = Just Csv+    toSubType _ _     = Nothing++instance Show Csv where+    show _ = "csv"++data Encrypted = Encrypted deriving Eq++instance MSubType Encrypted where+    toSubType _ "encrypted" = Just Encrypted+    toSubType _ _           = Nothing++instance Show Encrypted where+    show _ = "encrypted"++data FormData = FormData deriving Eq++instance MSubType FormData where+    toSubType _ "form-data" = Just FormData+    toSubType _ _           = Nothing++instance Show FormData where+    show _ = "form-data"++data Gif = Gif deriving Eq++instance MSubType Gif where+    toSubType _ "gif" = Just Gif+    toSubType _ _     = Nothing++instance Show Gif where+    show _ = "gif"++data Gzip = Gzip deriving Eq++instance MSubType Gzip where+    toSubType _ "gzip" = Just Gzip+    toSubType _ _      = Nothing++instance Show Gzip where+    show _ = "gzip"++data Javascript = Javascript deriving Eq++instance MSubType Javascript where+    toSubType _ "javascript" = Just Javascript+    toSubType _ _            = Nothing++instance Show Javascript where+    show _ = "javascript"++data Jpeg = Jpeg deriving Eq++instance MSubType Jpeg where+    toSubType _ "jpeg" = Just Jpeg+    toSubType _ _      = Nothing++instance Show Jpeg where+    show _ = "jpeg"++data Json = Json deriving Eq++instance MSubType Json where+    toSubType _ "json" = Just Json+    toSubType _ _      = Nothing++instance Show Json where+    show _ = "json"++data Mixed = Mixed deriving Eq++instance MSubType Mixed where+    toSubType _ "mixed" = Just Mixed+    toSubType _ _       = Nothing++instance Show Mixed where+    show _ = "mixed"++data Mp4 = Mp4 deriving Eq++instance MSubType Mp4 where+    toSubType _ "mp4" = Just Mp4+    toSubType _ _     = Nothing++instance Show Mp4 where+    show _ = "mp4"++data Mpeg = Mpeg deriving Eq++instance MSubType Mpeg where+    toSubType _ "mpeg" = Just Mpeg+    toSubType _ _      = Nothing++instance Show Mpeg where+    show _ = "mpeg"++data OctetStream = OctetStream deriving Eq++instance MSubType OctetStream where+    toSubType _ "octet-stream" = Just OctetStream+    toSubType _ _              = Nothing++instance Show OctetStream where+    show _ = "octet-stream"++data Ogg = Ogg deriving Eq++instance MSubType Ogg where+    toSubType _ "ogg" = Just Ogg+    toSubType _ _     = Nothing++instance Show Ogg where+    show _ = "ogg"++data Partial = Partial deriving Eq++instance MSubType Partial where+    toSubType _ "partial" = Just Partial+    toSubType _ _         = Nothing++instance Show Partial where+    show _ = "partial"++data Plain = Plain deriving Eq++instance MSubType Plain where+    toSubType _ "plain" = Just Plain+    toSubType _ _       = Nothing++instance Show Plain where+    show _ = "plain"++data Png = Png deriving Eq++instance MSubType Png where+    toSubType _ "png" = Just Png+    toSubType _ _     = Nothing++instance Show Png where+    show _ = "png"++data Postscript = Postscript deriving Eq++instance MSubType Postscript where+    toSubType _ "postscript" = Just Postscript+    toSubType _ _            = Nothing++instance Show Postscript where+    show _ = "postscript"++data Protobuf = Protobuf deriving Eq++instance MSubType Protobuf where+    toSubType _ "x-protobuf" = Just Protobuf+    toSubType _ _            = Nothing++instance Show Protobuf where+    show _ = "x-protobuf"++data RdfXml = RdfXml deriving Eq++instance MSubType RdfXml where+    toSubType _ "rdf+xml" = Just RdfXml+    toSubType _ _         = Nothing++instance Show RdfXml where+    show _ = "rdf+xml"++data RssXml = RssXml deriving Eq++instance MSubType RssXml where+    toSubType _ "rss+xml" = Just RssXml+    toSubType _ _         = Nothing++instance Show RssXml where+    show _ = "rss+xml"++data Tar = Tar deriving Eq++instance MSubType Tar where+    toSubType _ "tar" = Just Tar+    toSubType _ _     = Nothing++instance Show Tar where+    show _ = "tar"++data Tiff = Tiff deriving Eq++instance MSubType Tiff where+    toSubType _ "tiff" = Just Tiff+    toSubType _ _      = Nothing++instance Show Tiff where+    show _ = "tiff"++data Thrift = Thrift deriving Eq++instance MSubType Thrift where+    toSubType _ "x-thrift" = Just Thrift+    toSubType _ _          = Nothing++instance Show Thrift where+    show _ = "x-thrift"++data Vorbis = Vorbis deriving Eq++instance MSubType Vorbis where+    toSubType _ "vorbis" = Just Vorbis+    toSubType _ _        = Nothing++instance Show Vorbis where+    show _ = "vorbis"++data Webm = Webm deriving Eq++instance MSubType Webm where+    toSubType _ "webm" = Just Webm+    toSubType _ _      = Nothing++instance Show Webm where+    show _ = "webm"++data XhtmlXml = XhtmlXml deriving Eq++instance MSubType XhtmlXml where+    toSubType _ "xhtml+xml" = Just XhtmlXml+    toSubType _ _           = Nothing++instance Show XhtmlXml where+    show _ = "xhtml+xml"++data Xml = Xml deriving Eq++instance MSubType Xml where+    toSubType _ "xml" = Just Xml+    toSubType _ _     = Nothing++instance Show Xml where+    show _ = "xml"++-- | media-type and sub-type \"*\".+data All = All deriving Eq++instance MType All where+    toType _ "*" = Just All+    toType _ _   = Nothing++instance MSubType All where+    toSubType _ "*" = Just All+    toSubType _ _   = Nothing++instance Show All where+    show _ = "*"
+ src/Snap/Predicates/MediaTypes/Internal.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+module Snap.Predicates.MediaTypes.Internal where++import Control.Monad+import Control.Monad.State.Strict+import Data.ByteString (ByteString)+import Data.List (sortBy)+import Data.Maybe+import Snap.Core (Request)+import Snap.Predicates.Internal+import Snap.Predicates.MediaTypes+import qualified Data.Predicate.Env as E+import qualified Snap.Predicates.Parsers.Accept as A++mediaType :: (MType t, MSubType s) => Bool -> t -> s -> [A.MediaType] -> Maybe (MediaType t s)+mediaType fuzzy t s = safeHead . mapMaybe (\m -> do+    t' <- if fuzzy && A.medType    m == "*" then Just t else toType t    (A.medType m)+    s' <- if fuzzy && A.medSubtype m == "*" then Just s else toSubType s (A.medSubtype m)+    guard (t == t' && s == s')+    return $ MediaType t s (A.medQuality m) (A.medParams m))++readMediaTypes :: (MonadState m, StateType m ~ E.Env) => ByteString -> Request -> m [A.MediaType]+readMediaTypes k r = do+    let mtypes = sortBy q . concat . map A.parseMediaTypes $ headers r k+    E.insert k mtypes+    return mtypes+  where+    q a b = A.medQuality b `compare` A.medQuality a
+ src/Snap/Predicates/Params.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicates.Params+  ( Parameter (..)+  , Param (..)+  , ParamOpt (..)+  , ParamDef (..)+  )+where++import Data.ByteString (ByteString)+import Data.ByteString.Readable+import Data.Either+import Data.Monoid+import Data.String+import Data.Typeable+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicates.Error+import Snap.Predicates.Internal+import qualified Data.Predicate.Env as E+import qualified Data.ByteString as S++-- | The most generic request parameter predicate provided.+-- It will get all request parameter values of '_name' and pass them on to+-- the conversion function '_read', which might either yield an error+-- message or a value. In case of error, an optional default may be+-- returned instead, if nothing is provided, the error message will be used+-- when construction the 400 status.+data Parameter a = Parameter+  { _name    :: !ByteString                         -- ^ request parameter name+  , _read    :: [ByteString] -> Either ByteString a -- ^ conversion function+  , _default :: !(Maybe a)                          -- ^ (optional) default value+  }++instance Typeable a => Predicate (Parameter a) Request where+    type FVal (Parameter a) = Error+    type TVal (Parameter a) = a+    apply (Parameter nme f def) r =+        E.lookup (key nme) >>= maybe work result+      where+        work = case params r nme of+            [] -> maybe (return (F (err 400 ("Missing parameter '" <> nme <> "'."))))+                        (return . (T 0))+                        def+            vs -> do+                let x = f vs+                E.insert (key nme) x+                case x of+                    Left msg -> return $ maybe (F (err 400 msg)) (T 0) def+                    Right  v -> return $ T 0 v++        result (Left msg) = return (F (err 400 msg))+        result (Right  v) = return (T 0 v)++        key name = "parameter:" <> name <> ":" <> (fromString . show . typeOf $ def)++instance Show (Parameter a) where+    show p = "Parameter: " ++ show (_name p)++-- | Specialisation of 'Parameter' which returns the first request+-- which could be converted to the target type.+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 f Nothing)+      where+        f vs = let (es, xs) = partitionEithers $ map fromByteString vs+               in if null xs+                      then Left (S.intercalate "\n" es)+                      else Right (head xs)++instance Show (Param a) where+    show (Param x) = "Param: " ++ show x++-- | Like 'Param', but denoting an optional parameter, i.e. if the+-- parameter is not present or can not be converted to the target type, the+-- predicate will still succeed.+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)     = apply (Parameter x f (Just Nothing))+      where+        f vs = let xs = rights $ map fromByteString vs+               in if null xs then Right Nothing else Right (head xs)++instance Show (ParamOpt a) where+    show (ParamOpt x) = "ParamOpt: " ++ show x++-- | Like 'Param', but in case the parameter could not be found, the+-- provided default value will be used. ParamDef is provided for+-- convenience and nothing else than Param || Const, e.g.+-- @ParamDef \"foo\" 0 == Param \"foo\" ':|:' 'Const' 0@.+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 (Param x :|: Const d)++instance Show a => Show (ParamDef a) where+    show (ParamDef x d) = "ParamDef: " ++ show x ++ " [" ++ show d ++ "]"
+ src/Snap/Predicates/Parsers/Accept.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings, BangPatterns, DeriveDataTypeable #-}+module Snap.Predicates.Parsers.Accept+  ( MediaType (..)+  , parseMediaTypes+  )+where++import Control.Applicative+import Data.Attoparsec+import Data.Attoparsec.Text (double)+import Data.ByteString (ByteString)+import Data.Text.Encoding+import Data.Typeable+import Snap.Predicates.Parsers.Shared+import qualified Data.Attoparsec.Text as T++data MediaType = MediaType+  { medType    :: !ByteString+  , medSubtype :: !ByteString+  , medQuality :: !Double+  , medParams  :: ![(ByteString, ByteString)]+  } deriving (Eq, Show, Typeable)++parseMediaTypes :: ByteString -> [MediaType]+parseMediaTypes = either (const []) id . parseOnly mediaTypes++mediaTypes :: Parser [MediaType]+mediaTypes = mediaType `sepBy` chr ','++mediaType :: Parser MediaType+mediaType = toMediaType <$> trim typ <*> (chr '/' *> trim subtyp) <*> params+  where+    toMediaType t s p =+        case lookup "q" p >>= toDouble of+            Just q  -> MediaType t s q (filter ((/= "q") . fst) p)+            Nothing -> MediaType t s 1.0 p++params :: Parser [(ByteString, ByteString)]+params = (trim (chr ';') *> (element `sepBy` trim (chr ';'))) <|> return []+  where+    element = (,) <$> trim key <*> (chr '=' *> trim val)++typ, subtyp, key, val :: Parser ByteString+typ    = takeTill (oneof "/ ")+subtyp = takeTill (oneof ",; ")++key = do+    c <- peekWord8+    if c == Just (w ',')+        then fail "comma"+        else takeTill (oneof "= ")++val = takeTill (oneof ",; ")++toDouble :: ByteString -> Maybe Double+toDouble bs = do+    txt <- toMaybe (decodeUtf8' bs)+    dec <- toMaybe (T.parseOnly double txt)+    return dec+  where+    toMaybe (Right x) = Just x+    toMaybe (Left  _) = Nothing
+ src/Snap/Predicates/Parsers/Shared.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+module Snap.Predicates.Parsers.Shared where++import Control.Applicative+import Data.Attoparsec+import Data.ByteString (ByteString)+import Data.Char (ord)+import Data.Word+import qualified Data.ByteString as S++spaces :: Parser ()+spaces = skipWhile (== w ' ')++trim :: Parser a -> Parser a+trim p = spaces *> p <* spaces++oneof :: ByteString -> Word8 -> Bool+oneof = flip elem . S.unpack++chr :: Char -> Parser Word8+chr = word8 . w++w :: Char -> Word8+w = fromIntegral . ord
src/Snap/Predicates/Tutorial.hs view
@@ -33,10 +33,15 @@ @ data 'Data.Predicate.Boolean' f t =     'Data.Predicate.F' (Maybe f)-  | 'Data.Predicate.T' t+  | 'Data.Predicate.T' 'Data.Predicate.Delta' t   deriving (Eq, Show) @ +'Data.Predicate.Delta' can in most instances be ignored, i.e. set to 0.+It's purpose is as a measure of distance for those predicates which evaluate+to 'Data.Predicate.T' but some may be \"closer\" in some way than others. An+example is for instance HTTP content-negotiations (cf. 'Snap.Predicates.MediaTypes.Accept')+ Further there is a type-class 'Data.Predicate.Predicate' defined which contains an evaluation function 'Data.Predicate.apply', where the predicate instance is applied to some value, yielding 'Data.Predicate.T'@@ -46,15 +51,23 @@ class 'Data.Predicate.Predicate' p a where     type 'Data.Predicate.FVal' p     type 'Data.Predicate.TVal' p-    apply :: p -> a -> Boolean ('Data.Predicate.FVal' p) ('Data.Predicate.TVal' p)+    apply :: p -> a -> 'Control.Monad.State.Strict.State' 'Data.Predicate.Env' (Boolean ('Data.Predicate.FVal' p)) ('Data.Predicate.TVal' p) @ -All concrete predicates are instances of this type-class, which does not+All predicates are instances of this type-class, which does not specify the type against which the predicate is evaluated, nor the types of actual meta-data for the true/false case of the Boolean returned. Snap related predicates are normally defined against 'Snap.Core.Request' and in case they fail, they return a status code and an optional message. +Predicates may utilise the stateful 'Data.Predicate.Env.Env' to cache intermediate+results accross multiple evaluations, i.e. a resource may be declared multiple+times with different sets of predicates which means that in case a predicate+is part of more than one set it is evaluated multiple times for the same+input data. As an optimisation it may be beneficial to store intermediate+results in 'Data.Predicate.Env.Env' and re-use them later (cf. the implementation+of 'Snap.Predicates.MediaTypes.Accept').+ Besides these type definitions, there are some ways to connect two 'Data.Predicate.Predicate's to form a new one as the logical @OR@ or the logical @AND@ of its parts. These are:@@ -65,7 +78,7 @@  Besides evaluating to 'Data.Predicate.T' or 'Data.Predicate.F' depending on the truth values of its parts, these connectives also propagate the-meta-data appropriately.+meta-data and 'Data.Predicate.Delta' appropriately.  If 'Data.Predicate.:&:' evaluates to 'Data.Predicate.T' it has to combine the meta-data of both predicates, and it uses the product type@@ -85,51 +98,48 @@ Finally there are 'Data.Predicate.Const' and 'Data.Predicate.Fail' to always evaluate to 'Data.Predicate.T' or 'Data.Predicate.F' respectively. -As an example of how these operators are used, see below in 'Routes' section.+As an example of how these operators are used, see below in section \"Routes\". -}  {- $example  @-data 'Snap.Predicates.Accept' = 'Snap.Predicates.Accept' ByteString deriving Eq+data 'Snap.Predicates.Params.Param' = Param 'Data.ByteString.ByteString' deriving Eq -instance 'Data.Predicate.Predicate' 'Snap.Predicates.Accept' 'Snap.Core.Request' where-    type 'Data.Predicate.FVal' 'Snap.Predicates.Accept' = (Word, Maybe ByteString)-    type 'Data.Predicate.TVal' 'Snap.Predicates.Accept' = ()-    'Data.Predicate.apply' ('Snap.Predicates.Accept' x) r =-        if x \`elem\` headerValues r \"Accept\"-            then 'Data.Predicate.T' ()-            else 'Data.Predicate.F' $ Just (406, Just $ \"Expected 'Accept: \" <> x <> \"'.\")+instance 'Data.Predicate.Predicate' Param 'Snap.Core.Request' where+    type 'Data.Predicate.FVal' Param = 'Snap.Predicates.Error'+    type 'Data.Predicate.TVal' Param = ByteString+    apply (Param x) r =+        case params r x of+            []    -> return (F ('Snap.Predicates.Error' 400 (Just $ \"Expected parameter '\" \<\> x \<\> \"'.\")))+            (v:_) -> return (T [] v) @ -This is a simple example testing the value of a 'Snap.Core.Request's accept-header against some given value. The function @headerValues@ is not shown,-but gets the actual Accept-Header values of the request.+This is a simple example looking for the existence of a 'Snap.Core.Request' parameter+with the given name. In the success case, the parameter value is returned.  As mentioned before, Snap predicates usually fix the type @a@ from 'Data.Predicate.Predicate' above to 'Snap.Core.Request'. The associated types 'Data.Predicate.FVal' and 'Data.Predicate.TVal' denote the meta-data-types of the predicate. In this example, there is no useful information for-the 'Data.Predicate.T'-case, so 'Data.Predicate.TVal' becomes '()'.-The 'Data.Predicate.F'-case is set to the pair @(Word, Maybe ByteString)@-and indeed, if the predicate fails it sets the right HTTP status code-(406) and some helpful message.+types of the predicate. In this example, the meta-date type is 'Data.ByteString.ByteString'.+The 'Data.Predicate.F'-case is 'Snap.Predicates.Error' which contains a status+code and an optional message.  -}  {- $routes  So how are 'Data.Predicate.Predicate's used in some Snap application?-One way is to just apply them to a given request inside a snap handler, e.g.+One way is to just evaluate them against a given request inside a snap handler, e.g.  @ someHandler :: 'Snap.Core.Snap' () someHandler = do     req <- 'Snap.Core.getRequest'-    case apply ('Snap.Predicates.Accept' \"application/json\" 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"baz\") req of-        'Data.Predicate.T' (_ 'Data.Predicate.:*:' bazValue) -> ...-        'Data.Predicate.F' (Just (i, msg))  -> ...-        'Data.Predicate.F' Nothing          -> ...+    case 'Data.Predicate.eval' ('Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:&:' 'Snap.Predicates.Params.Param' \"baz\") req of+        'Data.Predicate.T' (_ 'Data.Predicate.:*:' bazValue)      -> ...+        'Data.Predicate.F' (Just ('Snap.Predicates.Error' st msg)) -> ...+        'Data.Predicate.F' Nothing               -> ... @  However another possibility is to augment route definitions with the@@ -138,27 +148,33 @@ @ sitemap :: 'Snap.Routes.Routes' Snap () sitemap = do-    'Snap.Routes.get'  \"\/a\" handlerA $ 'Snap.Predicates.AcceptJson' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:|:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"-    'Snap.Routes.get'  \"\/b\" handlerB $ 'Snap.Predicates.AcceptJson' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:||:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"-    'Snap.Routes.get'  \"\/c\" handlerC $ 'Data.Predicate.Fail' (410, Just \"Gone.\")-    'Snap.Routes.post' \"\/d\" handlerD $ 'Snap.Predicates.AcceptThrift'-    'Snap.Routes.post' \"\/e\" handlerE $ 'Snap.Predicates.Accept' \"plain/text\"+    'Snap.Routes.get'  \"\/a\" handlerA $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:|:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"+    'Snap.Routes.get'  \"\/b\" handlerB $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Text' 'Snap.Predicates.MediaTypes.Plain' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:||:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"+    'Snap.Routes.get'  \"\/c\" handlerC $ 'Data.Predicate.Fail' ('Snap.Predicates.Error' 410 (Just \"Gone.\"))+    'Snap.Routes.post' \"\/d\" handlerD $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Protobuf'+    'Snap.Routes.post' \"\/e\" handlerE $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Xml' @  The handlers then encode their pre-conditions in their type-signature:  @-handlerA :: 'Snap.Predicates.AcceptJson' 'Data.Predicate.:*:' ByteString 'Data.Predicate.:*:' ByteString -> Snap ()-handlerB :: 'Snap.Predicates.AcceptJson' 'Data.Predicate.:*:' (ByteString 'Data.Predicate.:+:' ByteString) 'Data.Predicate.:*:' ByteString -> Snap ()-handlerC :: 'Snap.Predicates.AcceptJson' 'Data.Predicate.:*:' Char -> Snap ()-handlerD :: 'Snap.Predicates.AcceptThrift' -> Snap ()-handlerE :: () -> Snap ()+handlerA :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:*:' ByteString 'Data.Predicate.:*:' ByteString -> Snap ()+handlerB :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Text' 'Snap.Predicates.MediaTypes.Plain' 'Data.Predicate.:*:' (ByteString 'Data.Predicate.:+:' ByteString) 'Data.Predicate.:*:' ByteString -> Snap ()+handlerC :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:*:' Char -> Snap ()+handlerD :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Protobuf' -> Snap ()+handlerE :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Xml' -> Snap () @ -As usually these type-declarations have to match, or else the code will-not compile. One thing to note is that 'Data.Predicate.Fail' works with-all handler signatures, which is safe, because the handler is never-invoked, or else Fail is used in some logical disjunction.+The type-declaration of a handler has to match the corresponding predicate,+i.e. the type of the predicate's 'Data.Predicate.T' meta-data value:++@+('Snap.Core.MonadSnap' m, 'Data.Predicate.Predicate' p 'Snap.Core.Request') => 'Data.Predicate.TVal' p -> m ()+@++One thing to note is that 'Data.Predicate.Fail' works with+all 'Data.Predicate.T' meta-data types which is safe because the handler is never+invoked, or 'Data.Predicate.Fail' is used in some logical disjunction.  Given the route and handler definitions above, one can then integrate with Snap via 'Snap.Routes.expandRoutes', which turns the
src/Snap/Routes.hs view
@@ -7,30 +7,40 @@   ( Routes   , showRoutes   , expandRoutes+  , addRoute   , get+  , get_   , Snap.Routes.head-  , addRoute+  , head_   , post+  , post_   , put+  , put_   , delete+  , delete_   , trace+  , trace_   , options+  , options_   , connect+  , connect_   ) where -import Control.Applicative+import Control.Applicative hiding (Const) import Control.Monad+import Control.Monad.State.Strict hiding (get, put) import Data.ByteString (ByteString) import Data.Either+import Data.List hiding (head, delete) import Data.Predicate-import Data.Word+import Data.Predicate.Env (Env) import Snap.Core-import Control.Monad.Trans.State.Strict (State)-import qualified Control.Monad.Trans.State.Strict as State+import Snap.Predicates import qualified Data.List as L--type Error = (Word, Maybe ByteString)+import qualified Data.Predicate.Env as E+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C  data Pack m where     Pack :: (Show p, Predicate p Request, FVal p ~ Error)@@ -44,6 +54,10 @@   , _pred    :: !(Pack m)   } +-- | The Routes monad is used to add routing declarations via 'addRoute' or+-- one of 'get', 'post', etc.+-- Routing declarations can then be turned into the ordinary snap format,+-- i.e. @MonadSnap m => [(ByteString, m a)]@ or into strings. newtype Routes m a = Routes   { _unroutes :: State [Route m] a } @@ -51,14 +65,17 @@     return  = Routes . return     m >>= f = Routes $ _unroutes m >>= _unroutes . f +-- | Add a route for some 'Method' and path (potentially with variable+-- captures), and constrained the some 'Predicate'. addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)          => Method          -> ByteString        -- ^ path          -> (TVal p -> m ())  -- ^ handler-         -> p                 -- ^ predicate+         -> p                 -- ^ 'Predicate'          -> Routes m ()-addRoute m r x p = Routes $ State.modify ((Route m r (Pack p x)):)+addRoute m r x p = Routes $ modify ((Route m r (Pack p x)):) +-- | Specialisation of 'addRoute' for a specific HTTP 'Method'. get, head, post, put, delete, trace, options, connect ::     (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)     => ByteString        -- ^ path@@ -74,11 +91,26 @@ options = addRoute OPTIONS connect = addRoute CONNECT +-- | Specialisation of 'addRoute' for a specific HTTP 'Method' taking+-- no 'Predicate' into consideration.+get_, head_, post_, put_, delete_, trace_, options_, connect_ ::+    (MonadSnap m)+    => ByteString    -- ^ path+    -> (() -> m ())  -- ^ handler+    -> Routes m ()+get_     p h = addRoute GET     p h (Const ())+head_    p h = addRoute HEAD    p h (Const ())+post_    p h = addRoute POST    p h (Const ())+put_     p h = addRoute PUT     p h (Const ())+delete_  p h = addRoute DELETE  p h (Const ())+trace_   p h = addRoute TRACE   p h (Const ())+options_ p h = addRoute OPTIONS p h (Const ())+connect_ p h = addRoute CONNECT p h (Const ())+ -- | Turn route definitions into a list of 'String's. showRoutes :: Routes m () -> [String] showRoutes (Routes routes) =-    let rs = reverse $ State.execState routes []-    in flip map rs $ \x ->+    flip map (concat . normalise $ execState routes []) $ \x ->         case _pred x of             Pack p _ -> shows (_method x)                       . (' ':)@@ -86,20 +118,44 @@                       . (' ':)                       . shows p $ "" --- | Turn route definitions into "snapable" format, i.e.+-- | Turn route definitions into \"snapable\" format, i.e. -- Routes are grouped per path and selection evaluates routes -- against the given Snap 'Request'. expandRoutes :: MonadSnap m => Routes m () -> [(ByteString, m ())] expandRoutes (Routes routes) =-    let rg = grouped . sorted . reverse $ State.execState routes []-    in map (\g -> (_path (L.head g), select g)) rg+    map (\g -> (_path (L.head g), select g)) (normalise $ execState routes [])++-- | Group routes by path.+normalise :: [Route m] -> [[Route m]]+normalise rr =+    let rg    = grouped . sorted $ rr+        paths = map (namelessPath . L.head) rg+        ambig = paths \\ nub paths+    in if null ambig then rg else error (ambiguityMessage ambig)   where     sorted :: [Route m] -> [Route m]-    sorted = L.sortBy (\a b -> _path a `compare` _path b)+    sorted = sortBy (\a b -> _path a `compare` _path b)      grouped :: [Route m] -> [[Route m]]-    grouped = L.groupBy (\a b -> _path a == _path b)+    grouped = groupBy (\a b -> _path a == _path b) +    namelessPath :: Route m -> ByteString+    namelessPath =+        let colon = 0x3A+            slash = 0x2F+            fun s = if s /= "" && S.head s == colon then "<>" else s+        in S.intercalate "/" . map fun . S.split slash . _path++    ambiguityMessage a =+        "Paths differing only in variable names are not supported.\n"  +++        "Problematic paths (with variable positions denoted by <>):\n" +++        (show a)++data Handler m = Handler+  { _delta   :: !Delta+  , _handler :: !(m ())+  }+ -- The handler selection proceeds as follows: -- (1) Consider only handlers with matching methods, or else return 405. -- (2) Evaluate 'Route' predicates.@@ -108,32 +164,42 @@ select :: MonadSnap m => [Route m] -> m () select g = do     ms <- filterM byMethod g-    if L.null ms-        then respond (405, Nothing)+    if null ms+        then do+            respond (Error 405 Nothing)+            modifyResponse (setHeader "Allow" validMethods)         else evalAll ms   where     byMethod :: MonadSnap m => Route m -> m Bool     byMethod x = (_method x ==) <$> getsRequest rqMethod +    validMethods :: ByteString+    validMethods = S.intercalate "," $ nub (C.pack . show . _method <$> g)+     evalAll :: MonadSnap m => [Route m] -> m ()     evalAll rs = do         req <- getRequest-        let (n, y) = partitionEithers $ map (eval req) rs+        let (n, y) = partitionEithers . snd $ foldl' (evalSingle req) (E.empty, []) rs         if null y             then respond (L.head n)-            else L.head y+            else closest y -    eval :: MonadSnap m => Request -> Route m -> Either Error (m ())-    eval rq r = case _pred r of-        Pack p h ->-            case apply p rq of-                F Nothing  -> Left (500, Nothing)-                F (Just m) -> Left m-                T v        -> Right (h v)+    evalSingle :: MonadSnap m => Request -> (Env, [Either Error (Handler m)]) -> Route m -> (Env, [Either Error (Handler m)])+    evalSingle rq (e, rs) r =+        case _pred r of+            Pack p h ->+                case runState (apply p rq) e of+                    (F   m, e') -> (e', Left m : rs)+                    (T d v, e') -> (e', Right (Handler d (h v)) : rs) +    closest :: MonadSnap m => [Handler m] -> m ()+    closest = foldl' (<|>) pass+            . map _handler+            . sortBy (\a b -> _delta a `compare` _delta b)+ respond :: MonadSnap m => Error -> m ()-respond (i, msg) = do+respond e = do     putResponse . clearContentLength-                . setResponseCode (fromIntegral i)+                . setResponseCode (fromIntegral . _status $ e)                 $ emptyResponse-    maybe (return ()) writeBS msg+    maybe (return ()) writeBS (_message e)
test/Tests/Data/Predicate.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans  #-} module Tests.Data.Predicate (tests) where -import Control.Applicative hiding (Const)+import Control.Applicative hiding (Const, empty) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck@@ -20,40 +20,42 @@     ]  testConst :: Const Int Char -> Bool-testConst x@(Const c) = apply x () == T c+testConst x@(Const c) = eval x () == T 0 c  testFail :: Fail Int Char -> Bool-testFail x@(Fail c) = apply x () == F (Just c)+testFail x@(Fail c) = eval x () == F c  testAnd :: Rand -> Rand -> Bool-testAnd a@(Rand (T x)) b@(Rand (T y)) = apply (a :&: b) () == T (x :*: y)-testAnd a@(Rand (T _)) b@(Rand (F y)) = apply (a :&: b) () == F y-testAnd a@(Rand (F x)) b@(Rand (T _)) = apply (a :&: b) () == F x-testAnd a@(Rand (F x)) b@(Rand (F _)) = apply (a :&: b) () == F x+testAnd a@(Rand (T d x)) b@(Rand (T w y)) = eval (a :&: b) () == T (d + w) (x :*: y)+testAnd a@(Rand (T _ _)) b@(Rand (F   y)) = eval (a :&: b) () == F y+testAnd a@(Rand (F   x)) b@(Rand (T _ _)) = eval (a :&: b) () == F x+testAnd a@(Rand (F   x)) b@(Rand (F   _)) = eval (a :&: b) () == F x  testOr :: Rand -> Rand -> Bool-testOr a@(Rand (T x)) b@(Rand (T _)) = apply (a :||: b) () == T (Left x)-testOr a@(Rand (T x)) b@(Rand (F _)) = apply (a :||: b) () == T (Left x)-testOr a@(Rand (F _)) b@(Rand (T y)) = apply (a :||: b) () == T (Right y)-testOr a@(Rand (F _)) b@(Rand (F y)) = apply (a :||: b) () == F y+testOr a@(Rand (T d x)) b@(Rand (T e y)) = eval (a :||: b) () == if d <= e then T d (Left x) else T e (Right y)+testOr a@(Rand (T d x)) b@(Rand (F   _)) = eval (a :||: b) () == T d (Left x)+testOr a@(Rand (F   _)) b@(Rand (T d y)) = eval (a :||: b) () == T d (Right y)+testOr a@(Rand (F   _)) b@(Rand (F   y)) = eval (a :||: b) () == F y  testOr' :: Rand -> Rand -> Bool-testOr' a@(Rand (T x)) b@(Rand (T _)) = apply (a :|: b) () == T x-testOr' a@(Rand (T x)) b@(Rand (F _)) = apply (a :|: b) () == T x-testOr' a@(Rand (F _)) b@(Rand (T y)) = apply (a :|: b) () == T y-testOr' a@(Rand (F _)) b@(Rand (F y)) = apply (a :|: b) () == F y+testOr' a@(Rand (T d x)) b@(Rand (T e y)) = eval (a :|: b) () == if d <= e then T d x else T e y+testOr' a@(Rand (T d x)) b@(Rand (F   _)) = eval (a :|: b) () == T d x+testOr' a@(Rand (F   _)) b@(Rand (T d y)) = eval (a :|: b) () == T d y+testOr' a@(Rand (F   _)) b@(Rand (F   y)) = eval (a :|: b) () == F y -data Rand = Rand (Boolean Int Char) deriving Show+newtype Rand = Rand+  { _rand :: Boolean Int Char+  } deriving Show  instance Predicate Rand a where     type FVal Rand   = Int     type TVal Rand   = Char-    apply (Rand x) _ = x+    apply (Rand x) _ = return x  instance Arbitrary (Boolean Int Char) where     arbitrary =-        oneof [ T <$> (arbitrary :: Gen Char)-              , F <$> (arbitrary :: Gen (Maybe Int))+        oneof [ T <$> (arbitrary :: Gen Delta) <*> (arbitrary :: Gen Char)+              , F <$> (arbitrary :: Gen Int)               ]  instance Arbitrary (Const Int Char) where
test/Tests/Snap/Predicates.hs view
@@ -4,6 +4,7 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test)+import Data.ByteString (ByteString) import Data.Predicate import Snap.Predicates import Snap.Test@@ -13,6 +14,7 @@ tests =     [ testAccept     , testParam+    , testParamOpt     , testAcceptJson     , testAcceptThrift     ]@@ -20,39 +22,53 @@ testAccept :: Test testAccept = testCase "Accept Predicate" $ do     rq0 <- buildRequest $ addHeader "Accept" "x/y"-    assertEqual "Matching Accept" (T ()) (apply (Accept "x/y") rq0)+    let predicate = Accept (Type "x") (SubType "y")+    let true = T 0 $ MediaType (Type "x") (SubType "y") 1.0 []+    assertEqual "Matching Accept" true (eval predicate rq0) -    rq1 <- buildRequest $ get "/" M.empty+    rq1 <- buildRequest $ addHeader "Accept" "u/v"     assertEqual "Status Code 406"-        (F $ Just (406, Just "Expected 'Accept: x/y'."))-        (apply (Accept "x/y") rq1)+        (F (err 406 ("Expected 'Accept: \"x\"/\"y\"'.")))+        (eval predicate rq1)  testAcceptJson :: Test testAcceptJson = testCase "AcceptJson Predicate" $ do     rq0 <- buildRequest $ addHeader "Accept" "application/json"-    assertEqual "Matching AcceptJson" (T AcceptJson) (apply AcceptJson rq0)+    let predicate = Accept Application Json+    let true = T 0 $ MediaType Application Json 1.0 []+    assertEqual "Matching AcceptJson" true (eval predicate rq0) -    rq1 <- buildRequest $ addHeader "Accept" "foo"+    rq1 <- buildRequest $ addHeader "Accept" "foo/bar"     assertEqual "Status Code 406"-        (F $ Just (406, Just "Expected 'Accept: application/json'."))-        (apply AcceptJson rq1)+        (F (err 406 ("Expected 'Accept: application/json'.")))+        (eval predicate rq1)  testAcceptThrift :: Test testAcceptThrift = testCase "AcceptThrift Predicate" $ do     rq0 <- buildRequest $ addHeader "Accept" "application/x-thrift"-    assertEqual "Matching AcceptThrift" (T AcceptThrift) (apply AcceptThrift rq0)+    let predicate = Accept Application Thrift+    let true = T 0 $ MediaType Application Thrift 1.0 []+    assertEqual "Matching AcceptThrift" true (eval predicate rq0)      rq1 <- buildRequest $ addHeader "Accept" "application/json"     assertEqual "Status Code 406"-        (F $ Just (406, Just "Expected 'Accept: application/x-thrift'."))-        (apply AcceptThrift rq1)+        (F (err 406 ("Expected 'Accept: application/x-thrift'.")))+        (eval predicate rq1)  testParam :: Test testParam = testCase "Param Predicate" $ do     rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])-    assertEqual "Matching Param" (T "y") (apply (Param "x") rq0)+    assertEqual "Matching Param" (T 0 "y") (eval (Param "x" :: Param ByteString) rq0)      rq1 <- buildRequest $ get "/" M.empty     assertEqual "Status Code 400"-        (F $ Just (400, Just "Expected parameter 'x'."))-        (apply (Param "x") rq1)+        (F (err 400 ("Missing parameter 'x'.")))+        (eval (Param "x" :: Param ByteString) rq1)++testParamOpt :: Test+testParamOpt = testCase "ParamOpt Predicate" $ do+    rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])+    assertEqual "Matching Param 1" (T 0 (Just "y")) (eval (ParamOpt "x" :: ParamOpt ByteString) rq0)++    rq1 <- buildRequest $ get "/" M.empty+    assertEqual "Matching Param 2" (T 0 Nothing) (eval (ParamOpt "x" :: ParamOpt ByteString) rq1)
test/Tests/Snap/Routes.hs view
@@ -2,62 +2,81 @@ module Tests.Snap.Routes (tests) where  import Control.Applicative hiding (Const)+import Control.Monad.IO.Class import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Data.ByteString (ByteString)+import Data.Either import Data.Predicate+import Data.String+import Data.Text (Text, strip)+import Data.Text.Encoding import Snap.Core-import Snap.Predicates+import Snap.Predicates hiding (Text) import Snap.Routes import qualified Snap.Test as T import qualified Data.Map.Strict as M+import qualified Data.Text as Text  tests :: [Test] tests =-    [ testSitemap ]+    [ testSitemap+    , testMedia+    ]  testSitemap :: Test testSitemap = testCase "Sitemap" $ do     let routes = expandRoutes sitemap-    assertEqual "Endpoints" ["/a", "/b", "/c", "/d"] (map fst routes)+    assertEqual "Endpoints" ["/a", "/b", "/c", "/d", "/e"] (map fst routes)     mapM_ (\(r, h) -> h r) (zip (map snd routes) [testEndpointA])  sitemap :: Routes Snap () sitemap = do     get "/a" handlerA $-        AcceptJson :&: (Param "name" :|: Param "nick") :&: Param "foo"+        Accept Application Json :&: (Param "name" :|: Param "nick") :&: Param "foo"      get "/b" handlerB $-        AcceptJson :&: (Param "name" :||: Param "nick") :&: Param "foo"+        Accept Application Json :&: (Param "name" :||: Param "nick") :&: Param "foo" -    get  "/c" handlerC $ Fail (410, Just "Gone.")+    get "/c" handlerC $ Fail (err 410 "Gone.") -    post "/d" handlerD $ AcceptThrift+    post "/d" handlerD $ Accept Application Json :&: Parameter "foo" decode Nothing -handlerA :: AcceptJson :*: ByteString :*: ByteString -> Snap ()-handlerA (_ :*: _ :*: _) = return ()+    get "/e" handlerE $ (Param "foo" :|: Const 0) :&: ParamOpt "bar"+  where+    decode bs =+        let txt = rights (map decodeUtf8' bs)+        in if null txt+               then Left "UTF-8 decoding error"+               else Right (map strip txt) -handlerB :: AcceptJson :*: (ByteString :+: ByteString) :*: ByteString -> Snap ()+handlerA :: MediaType Application Json :*: Int :*: ByteString -> Snap ()+handlerA (_ :*: i :*: _) = writeText (fromString . show $ i)++handlerB :: MediaType Application Json :*: (ByteString :+: ByteString) :*: ByteString -> Snap () handlerB (_ :*: name :*: _) =     case name of         Left  _ -> return ()         Right _ -> return () -handlerC :: AcceptThrift -> Snap ()+handlerC :: MediaType Application Json -> Snap () handlerC _ = do-    req <- getRequest-    case apply (Param "bar" :&: Param "baz") req of-        T (_ :*: _) -> return ()-        F _         -> return ()-    return ()+    rq <- getRequest+    with (Param "bar" :&: Param "baz") rq $ \(bar :*: baz) -> do+        writeBS bar+        writeBS baz -handlerD :: AcceptThrift -> Snap ()-handlerD _ = return ()+handlerD :: MediaType Application Json :*: [Text] -> Snap ()+handlerD (_ :*: txt) = writeText $ Text.intercalate ", " txt +handlerE :: Int :*: Maybe ByteString -> Snap ()+handlerE (foo :*: Just bar) = writeText (Text.pack . show $ foo) >> writeBS bar+handlerE (_   :*: Nothing)  = return ()+ testEndpointA :: Snap () -> Assertion testEndpointA m = do-    let rq0 = T.get "/a" M.empty+    let rq0 = T.get "/a" M.empty >> T.addHeader "Accept" "foo/bar"     st0 <- rspStatus <$> T.runHandler rq0 m     assertEqual "Accept fails" 406 st0 @@ -70,7 +89,32 @@     st2 <- rspStatus <$> T.runHandler rq2 m     assertEqual "Param fails" 400 st2 -    let rq3 = T.get "/a" (M.fromList [("name", ["x"]), ("foo", ["y"])]) >>+    let rq3 = T.get "/a" (M.fromList [("name", ["123"]), ("foo", ["y"])]) >>               T.addHeader "Accept" "application/json"     T.runHandler rq3 m >>= T.assertSuccess +-- Media Selection Tests:++testMedia :: Test+testMedia = testCase "Media Selection" $ do+    let [(_, h)] = expandRoutes sitemapMedia+    expectMedia "application/json;q=0.3, application/x-thrift;q=0.7" "application/x-thrift" h+    expectMedia "application/json;q=0.7, application/x-thrift;q=0.3" "application/json" h++sitemapMedia :: Routes Snap ()+sitemapMedia = do+    get "/media" handlerJson   $ Accept Application Json+    get "/media" handlerThrift $ Accept Application Thrift++handlerJson :: MediaType Application Json -> Snap ()+handlerJson _ = writeBS "application/json"++handlerThrift :: MediaType Application Thrift -> Snap ()+handlerThrift _ = writeBS "application/x-thrift"++expectMedia :: ByteString -> ByteString -> Snap () -> Assertion+expectMedia hdr res m = do+    let rq0 = T.get "/media" M.empty >>+              T.addHeader "Accept" hdr+    txt0 <- T.runHandler rq0 m >>= liftIO . T.getResponseBody+    assertEqual "media type" res txt0