packages feed

snap-predicates (empty) → 0.1.0

raw patch · 12 files changed

+892/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, case-insensitive, containers, snap-core, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2013 Toralf Wittner, Brendan Hay++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,59 @@+Snap-Predicates+===============++This library provides a 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++import Data.ByteString (ByteString)+import Data.Monoid+import Data.Predicate+import Snap.Core+import Snap.Routes+import Snap.Predicates+import Snap.Http.Server++main :: IO ()+main = do+    mapM_ putStrLn (showRoutes sitemap)+    quickHttpServe (route . expandRoutes $ sitemap)++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++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++createUser :: AcceptThrift -> Snap ()+createUser _ = writeBS "createUser"++createUser' :: AcceptJson -> Snap ()+createUser' _ = writeBS "createUser'"++status :: AcceptJson :*: Char -> Snap ()+status _ = writeBS "status"+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snap-predicates.cabal view
@@ -0,0 +1,88 @@+name:                snap-predicates+version:             0.1.0+synopsis:            Predicates for route definitions.+license:             MIT+license-file:        LICENSE+author:              Toralf Wittner, Brendan Hay+maintainer:          Toralf Wittner <tw@dtex.org>+copyright:           Copyright (c) 2013 Toralf Wittner, Brendan Hay+stability:           experimental+category:            Snap+build-type:          Simple+cabal-version:       >= 1.10+extra-source-files:  README.md++description:+    Provides a 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.++library+    default-language: Haskell2010+    hs-source-dirs:   src+    ghc-options:      -Wall -O2 -fwarn-tabs -funbox-strict-fields+    ghc-prof-options: -prof -auto-all++    exposed-modules:+        Data.Predicate+      , Snap.Predicates+      , Snap.Routes+      , Snap.Predicates.Tutorial++    build-depends:+        base             >= 4   && < 5+      , transformers     >= 0.3+      , bytestring       >= 0.9+      , containers       >= 0.5+      , case-insensitive >= 1.0+      , snap-core        >= 0.9++    other-extensions:+       BangPatterns+     , FlexibleInstances+     , GADTs+     , MultiParamTypeClasses+     , OverloadedStrings+     , TypeFamilies+     , TypeOperators++test-suite snap-predicates-test-suite+    type:             exitcode-stdio-1.0+    default-language: Haskell2010+    hs-source-dirs:   src test+    main-is:          TestSuite.hs+    ghc-options:      -Wall -O2 -fwarn-tabs -funbox-strict-fields+    ghc-prof-options: -prof -auto-all++    other-modules:+        Tests.Data.Predicate+      , Tests.Snap.Predicates+      , Tests.Snap.Routes++    build-depends:+        base             >= 4   && < 5+      , transformers     >= 0.3+      , bytestring       >= 0.9+      , containers       >= 0.5+      , case-insensitive >= 1.0+      , snap-core        >= 0.9++      , HUnit                      >= 1.2+      , QuickCheck                 >= 2.3+      , test-framework             >= 0.8+      , 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
+ src/Data/Predicate.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+module Data.Predicate where++import Control.Applicative hiding (Const)+import Control.Monad++-- | 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+  deriving (Eq, Show)++-- | The 'Predicate' class declares the function 'apply' which+-- evaluates the predicate against some value, returning a value+-- of type 'Boolean'.+-- Besides being parameterised over predicate type and predicate+-- parameter, the class is also parameterised over the actual types+-- of T's and F's meta-data.+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++-- | A 'Predicate' instance which always returns 'T' with+-- the given value as T's meta-data.+data Const f t where+    Const :: t -> Const f t++instance Predicate (Const f t) a where+    type FVal (Const f t) = f+    type TVal (Const f t) = t+    apply (Const a) _     = T a++instance Show t => Show (Const f t) where+    show (Const a) = "Const " ++ show a++-- | A 'Predicate' instance which always returns 'F' with+-- the given value as F's meta-data.+data Fail f t where+    Fail :: f -> Fail f t++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++instance Show f => Show (Fail f t) where+    show (Fail a) = "Fail " ++ show a++-- | 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.+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++instance (Show a, Show b) => Show (a :|: b) where+    show (a :|: b) = "(" ++ show a ++ " | " ++ show b ++ ")"++type a :+: b = Either a b++-- | 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.+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)++instance (Show a, Show b) => Show (a :||: b) where+    show (a :||: b) = "(" ++ show a ++ " || " ++ show b ++ ")"++-- | Data-type used for tupling-up the results of ':&:'.+data a :*: b = a :*: b deriving (Eq, Show)++-- | A 'Predicate' instance corresponding to the logical+-- AND connective of two 'Predicate's.+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   = (:*:) <$> apply a r <*> apply b r++instance (Show a, Show b) => Show (a :&: b) where+    show (a :&: b) = "(" ++ show a ++ " & " ++ show b ++ ")"
+ src/Snap/Predicates.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicates+  ( Accept (..)+  , AcceptJson (..)+  , AcceptThrift (..)+  , Param (..)+  )+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
+ src/Snap/Predicates/Tutorial.hs view
@@ -0,0 +1,169 @@+module Snap.Predicates.Tutorial+  ( -- * Motivation+    -- $motivation++    -- * Introduction+    -- $introduction++    -- * Example Predicate+    -- $example++    -- * Routes+    -- $routes+  )+where++{- $motivation++The purpose of the @snap-predicates@ package is to facilitate the+convenient definition of safe Snap handlers. Here safety+means that a handler can declare all pre-conditions which must be+fulfilled such that the handler can produce a successful response.+It is then statically guaranteed that the handler will not be+invoked if any of these pre-conditions fails.++-}++{- $introduction++The @snap-predicates@ package defines a 'Data.Predicate.Boolean' type+which carries \-\- in addition to actual truth values 'Data.Predicate.T'+and 'Data.Predicate.F' \-\- meta-data for each case:++@+data 'Data.Predicate.Boolean' f t =+    'Data.Predicate.F' (Maybe f)+  | 'Data.Predicate.T' t+  deriving (Eq, Show)+@++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'+or 'Data.Predicate.F'.++@+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)+@++All concrete 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.++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:++  * 'Data.Predicate.:|:' and 'Data.Predicate.:||:' as logical @OR@s++  * 'Data.Predicate.:&:' as logical @AND@++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.++If 'Data.Predicate.:&:' evaluates to 'Data.Predicate.T' it has to combine+the meta-data of both predicates, and it uses the product type+'Data.Predicate.:*:' for this. This type also has a right-associative+data constructor using the same symbol, so one can combine many predicates+without having to nest the meta-data pairs.++In the @OR@ case, the two predicates have potentially meta-data of+different types, so we use a sum type 'Either' whenever we combine+two predicates with 'Data.Predicate.:||:'. For convenience a type-alias+'Data.Predicate.:+:' is defined for 'Either', which allows simple infix+notation. However, for the common case where both predicates have+meta-data of the same type, there is often no need to distinguish which+@OR@-branch was true. In this case, the 'Data.Predicate.:|:' combinator+can be used.++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.+-}++{- $example++@+data 'Snap.Predicates.Accept' = 'Snap.Predicates.Accept' 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 <> \"'.\")+@++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.++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.++-}++{- $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.++@+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          -> ...+@++However another possibility is to augment route definitions with the+'Snap.Routes.Routes' monad to use them with 'Snap.Core.route', e.g.++@+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\"+@++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 ()+@++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.++Given the route and handler definitions above, one can then integrate+with Snap via 'Snap.Routes.expandRoutes', which turns the+'Snap.Routes.Routes' monad into a list of+@'Snap.Core.MonadSnap' m => [(ByteString, m ())]@.+Additionally routes can be turned into Strings via 'Snap.Routes.showRoutes'.++-}
+ src/Snap/Routes.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleContexts  #-}+module Snap.Routes+  ( Routes+  , showRoutes+  , expandRoutes+  , get+  , Snap.Routes.head+  , addRoute+  , post+  , put+  , delete+  , trace+  , options+  , connect+  )+where++import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import Data.Either+import Data.Predicate+import Data.Word+import Snap.Core+import Control.Monad.Trans.State.Strict (State)+import qualified Control.Monad.Trans.State.Strict as State+import qualified Data.List as L++type Error = (Word, Maybe ByteString)++data Pack m where+    Pack :: (Show p, Predicate p Request, FVal p ~ Error)+         => p+         -> (TVal p -> m ())+         -> Pack m++data Route m = Route+  { _method  :: !Method+  , _path    :: !ByteString+  , _pred    :: !(Pack m)+  }++newtype Routes m a = Routes+  { _unroutes :: State [Route m] a }++instance Monad (Routes m) where+    return  = Routes . return+    m >>= f = Routes $ _unroutes m >>= _unroutes . f++addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)+         => Method+         -> ByteString        -- ^ path+         -> (TVal p -> m ())  -- ^ handler+         -> p                 -- ^ predicate+         -> Routes m ()+addRoute m r x p = Routes $ State.modify ((Route m r (Pack p x)):)++get, head, post, put, delete, trace, options, connect ::+    (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)+    => ByteString        -- ^ path+    -> (TVal p -> m ())  -- ^ handler+    -> p                 -- ^ 'Predicate'+    -> Routes m ()+get     = addRoute GET+head    = addRoute HEAD+post    = addRoute POST+put     = addRoute PUT+delete  = addRoute DELETE+trace   = addRoute TRACE+options = addRoute OPTIONS+connect = addRoute CONNECT++-- | 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 ->+        case _pred x of+            Pack p _ -> shows (_method x)+                      . (' ':)+                      . shows (_path x)+                      . (' ':)+                      . shows p $ ""++-- | 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+  where+    sorted :: [Route m] -> [Route m]+    sorted = L.sortBy (\a b -> _path a `compare` _path b)++    grouped :: [Route m] -> [[Route m]]+    grouped = L.groupBy (\a b -> _path a == _path b)++-- The handler selection proceeds as follows:+-- (1) Consider only handlers with matching methods, or else return 405.+-- (2) Evaluate 'Route' predicates.+-- (3) Pick the first one which is 'Good', or else respond with status+--     and message of the first one.+select :: MonadSnap m => [Route m] -> m ()+select g = do+    ms <- filterM byMethod g+    if L.null ms+        then respond (405, Nothing)+        else evalAll ms+  where+    byMethod :: MonadSnap m => Route m -> m Bool+    byMethod x = (_method x ==) <$> getsRequest rqMethod++    evalAll :: MonadSnap m => [Route m] -> m ()+    evalAll rs = do+        req <- getRequest+        let (n, y) = partitionEithers $ map (eval req) rs+        if null y+            then respond (L.head n)+            else L.head 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)++respond :: MonadSnap m => Error -> m ()+respond (i, msg) = do+    putResponse . clearContentLength+                . setResponseCode (fromIntegral i)+                $ emptyResponse+    maybe (return ()) writeBS msg
+ test/TestSuite.hs view
@@ -0,0 +1,15 @@+module Main where++import Test.Framework (defaultMain, testGroup)+import qualified Tests.Data.Predicate as Predicate+import qualified Tests.Snap.Predicates as SnapPredicates+import qualified Tests.Snap.Routes as SnapRoutes++main :: IO ()+main = defaultMain tests+  where+    tests =+        [ testGroup "Tests.Data.Predicate"  Predicate.tests+        , testGroup "Tests.Snap.Predicates" SnapPredicates.tests+        , testGroup "Tests.Snap.Routes"     SnapRoutes.tests+        ]
+ test/Tests/Data/Predicate.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans  #-}+module Tests.Data.Predicate (tests) where++import Control.Applicative hiding (Const)+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Data.Predicate++tests :: [Test]+tests =+    [ testProperty "Const" testConst+    , testProperty "Fail" testFail+    , testProperty "(:&:)" testAnd+    , testProperty "(:||:)" testOr+    , testProperty "(:|:)" testOr'+    ]++testConst :: Const Int Char -> Bool+testConst x@(Const c) = apply x () == T c++testFail :: Fail Int Char -> Bool+testFail x@(Fail c) = apply x () == F (Just 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++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' :: 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++data Rand = Rand (Boolean Int Char) deriving Show++instance Predicate Rand a where+    type FVal Rand   = Int+    type TVal Rand   = Char+    apply (Rand x) _ = x++instance Arbitrary (Boolean Int Char) where+    arbitrary =+        oneof [ T <$> (arbitrary :: Gen Char)+              , F <$> (arbitrary :: Gen (Maybe Int))+              ]++instance Arbitrary (Const Int Char) where+    arbitrary = Const <$> (arbitrary :: Gen Char)++instance Arbitrary (Fail Int Char) where+    arbitrary = Fail <$> (arbitrary :: Gen Int)++instance Arbitrary Rand where+    arbitrary = Rand <$> (arbitrary :: Gen (Boolean Int Char))
+ test/Tests/Snap/Predicates.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeFamilies #-}+module Tests.Snap.Predicates (tests) where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Data.Predicate+import Snap.Predicates+import Snap.Test+import qualified Data.Map.Strict as M++tests :: [Test]+tests =+    [ testAccept+    , testParam+    , testAcceptJson+    , testAcceptThrift+    ]++testAccept :: Test+testAccept = testCase "Accept Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "x/y"+    assertEqual "Matching Accept" (T ()) (apply (Accept "x/y") rq0)++    rq1 <- buildRequest $ get "/" M.empty+    assertEqual "Status Code 406"+        (F $ Just (406, Just "Expected 'Accept: x/y'."))+        (apply (Accept "x/y") rq1)++testAcceptJson :: Test+testAcceptJson = testCase "AcceptJson Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "application/json"+    assertEqual "Matching AcceptJson" (T AcceptJson) (apply AcceptJson rq0)++    rq1 <- buildRequest $ addHeader "Accept" "foo"+    assertEqual "Status Code 406"+        (F $ Just (406, Just "Expected 'Accept: application/json'."))+        (apply AcceptJson rq1)++testAcceptThrift :: Test+testAcceptThrift = testCase "AcceptThrift Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "application/x-thrift"+    assertEqual "Matching AcceptThrift" (T AcceptThrift) (apply AcceptThrift rq0)++    rq1 <- buildRequest $ addHeader "Accept" "application/json"+    assertEqual "Status Code 406"+        (F $ Just (406, Just "Expected 'Accept: application/x-thrift'."))+        (apply AcceptThrift 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)++    rq1 <- buildRequest $ get "/" M.empty+    assertEqual "Status Code 400"+        (F $ Just (400, Just "Expected parameter 'x'."))+        (apply (Param "x") rq1)
+ test/Tests/Snap/Routes.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings, TypeOperators #-}+module Tests.Snap.Routes (tests) where++import Control.Applicative hiding (Const)+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Data.ByteString (ByteString)+import Data.Predicate+import Snap.Core+import Snap.Predicates+import Snap.Routes+import qualified Snap.Test as T+import qualified Data.Map.Strict as M++tests :: [Test]+tests =+    [ testSitemap ]++testSitemap :: Test+testSitemap = testCase "Sitemap" $ do+    let routes = expandRoutes sitemap+    assertEqual "Endpoints" ["/a", "/b", "/c", "/d"] (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"++    get "/b" handlerB $+        AcceptJson :&: (Param "name" :||: Param "nick") :&: Param "foo"++    get  "/c" handlerC $ Fail (410, Just "Gone.")++    post "/d" handlerD $ AcceptThrift++handlerA :: AcceptJson :*: ByteString :*: ByteString -> Snap ()+handlerA (_ :*: _ :*: _) = return ()++handlerB :: AcceptJson :*: (ByteString :+: ByteString) :*: ByteString -> Snap ()+handlerB (_ :*: name :*: _) =+    case name of+        Left  _ -> return ()+        Right _ -> return ()++handlerC :: AcceptThrift -> Snap ()+handlerC _ = do+    req <- getRequest+    case apply (Param "bar" :&: Param "baz") req of+        T (_ :*: _) -> return ()+        F _         -> return ()+    return ()++handlerD :: AcceptThrift -> Snap ()+handlerD _ = return ()++testEndpointA :: Snap () -> Assertion+testEndpointA m = do+    let rq0 = T.get "/a" M.empty+    st0 <- rspStatus <$> T.runHandler rq0 m+    assertEqual "Accept fails" 406 st0++    let rq1 = rq0 >> T.addHeader "Accept" "application/json"+    st1 <- rspStatus <$> T.runHandler rq1 m+    assertEqual "Param fails" 400 st1++    let rq2 = T.get "/a" (M.fromList [("name", ["x"])]) >>+              T.addHeader "Accept" "application/json"+    st2 <- rspStatus <$> T.runHandler rq2 m+    assertEqual "Param fails" 400 st2++    let rq3 = T.get "/a" (M.fromList [("name", ["x"]), ("foo", ["y"])]) >>+              T.addHeader "Accept" "application/json"+    T.runHandler rq3 m >>= T.assertSuccess+