packages feed

wai-routing 0.3.1 → 0.4

raw patch · 25 files changed

+145/−1332 lines, 25 filesdep +wai-predicatesdep ~bytestring-from

Dependencies added: wai-predicates

Dependency ranges changed: bytestring-from

Files

README.md view
@@ -4,48 +4,3 @@ The set of possible handlers can be restricted by "predicates", which operate on WAI requests and have to be true or else the handler will not be called.--For details have a look at the haddock documentation of-`Network.Wai.Routing.Tutorial` or the `examples` folder in the-source distribution.--This library is a port of `snap-predicates` which provides-similar functionality for the snap framework.--The routing tree construction is implemented using `wai-route`.--Here is a simple usage example.---```haskell-import Data.ByteString (ByteString)-import Data.Text (Text)-import Network.Wai-import Network.Wai.Routing-import Network.Wai.Handler.Warp--main :: IO ()-main = run 8080 (route (prepare start))--start :: Monad m => Routes a m ()-start = do-    get "/user/:name" fetchUser $-        capture "name"--    get "/user/find" findUser $-        query "byName" :||: query "byId"--    delete "/user/:name" rmUser $-        capture "name" :&: opt (cookie "foo")--fetchUser :: Monad m => Text -> m Response-fetchUser name = ...--findUser :: Monad m => Either ByteString Word64 -> m Response-findUser (Left  name)  = ...-findUser (Right ident) = ...--rmUser :: Monad m => Text ::: Maybe Int -> m Response-rmUser (name ::: foo)  = ...-```-
examples/eval-routing.hs view
@@ -10,6 +10,7 @@ import Data.String import Network.HTTP.Types import Network.Wai+import Network.Wai.Predicate import Network.Wai.Routing import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger@@ -31,7 +32,7 @@ main = run 8080 $ logStdout (route (prepare start))  start :: Monad m => Routes a m ()-start = get "eval" eval (query "x" :&: query "y" :&: query "f")+start = get "eval" eval (query "x" .&. query "y" .&. query "f")  eval :: Monad m => Int ::: Int ::: Op -> m Response eval (x ::: y ::: f) = respond status200 . fromString . show $
src/Network/Wai/Routing.hs view
@@ -4,12 +4,10 @@  module Network.Wai.Routing     ( module Network.Wai.Routing.Route-    , module Network.Wai.Routing.Error     , module Network.Wai.Routing.Predicate-    , module Network.Wai.Routing.Request+    , HasCaptures (..)     ) where -import Network.Wai.Routing.Route-import Network.Wai.Routing.Error import Network.Wai.Routing.Predicate import Network.Wai.Routing.Request+import Network.Wai.Routing.Route
− src/Network/Wai/Routing/Error.hs 
@@ -1,19 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--module Network.Wai.Routing.Error where--import Data.ByteString (ByteString)-import Network.HTTP.Types.Status---- | The error type used as meta-data for @F@ in all WAI predicates.-data Error = Error-    { status  :: !Status          -- ^ HTTP status code-    , message :: Maybe ByteString -- ^ optional status message-    } deriving (Eq, Show)---- | Convenience function to construct 'Error' values from--- status code and body message.-err :: Status -> ByteString -> Error-err s = Error s . Just
− src/Network/Wai/Routing/Internal.hs 
@@ -1,37 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Network.Wai.Routing.Internal-    ( readValues-    , rqApply-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Data.List (foldl')-import Data.String (fromString)-import Network.HTTP.Types-import Network.Wai.Routing.Error-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--readValues :: FromByteString a => [ByteString] -> Either ByteString a-readValues = foldl' result (Left "no parse") . map (runParser parser)-  where-    result (Left  _) (Right x) = Right x-    result (Right x) _         = Right x-    result _         (Left  x) = Left (fromString x)--rqApply :: (Req -> [ByteString])-        -> ([ByteString] -> Either ByteString a)-        -> Error-        -> Req-        -> Boolean Error a-rqApply f reader e r =-    case f r of-        [] -> F e-        vs -> either (F . err status400) (T 0) $ reader vs
− src/Network/Wai/Routing/MediaType.hs 
@@ -1,31 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}--module Network.Wai.Routing.MediaType where--import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import GHC.TypeLits--data Media (t :: Symbol) (s :: Symbol) = Media-    { rawType      :: !ByteString-    , rawSubTypes  :: !ByteString-    , mediaQuality :: !Double-    , mediaParams  :: ![(ByteString, ByteString)]-    } deriving (Eq, Show)--mediaType :: SingI t => Media t s -> ByteString-mediaType m = withSing (f m)-  where-    f :: Media t s -> Sing t -> ByteString-    f _ t = pack (fromSing t)--mediaSubType :: SingI s => Media t s -> ByteString-mediaSubType m = withSing (f m)-  where-    f :: Media t s -> Sing s -> ByteString-    f _ s = pack (fromSing s)
− src/Network/Wai/Routing/Parser/MediaType.hs 
@@ -1,66 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings #-}--module Network.Wai.Routing.Parser.MediaType-    ( MediaType (..)-    , readMediaTypes-    ) where--import Control.Applicative-import Data.Attoparsec.Char8-import Data.ByteString (ByteString)-import Data.List (sortBy)-import Network.Wai.Routing.Parser.Shared-import Network.Wai.Routing.Request--data MediaType = MediaType-    { medType    :: !ByteString-    , medSubtype :: !ByteString-    , medQuality :: !Double-    , medParams  :: ![(ByteString, ByteString)]-    } deriving (Eq, Show)--readMediaTypes :: ByteString -> Req -> [MediaType]-readMediaTypes k r =-    sortBy q . concatMap parseMediaTypes $ lookupHeader k r-  where-    q a b = medQuality b `compare` medQuality a--parseMediaTypes :: ByteString -> [MediaType]-parseMediaTypes = either (const []) id . parseOnly mediaTypes--mediaTypes :: Parser [MediaType]-mediaTypes = mediaType `sepBy` char ','--mediaType :: Parser MediaType-mediaType =-    toMediaType <$> trim typ <*> (char '/' *> 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 (char ';') *> (element `sepBy` trim (char ';'))) <|> return []-  where-    element = (,) <$> trim key <*> (char '=' *> trim val)--typ, subtyp, key, val :: Parser ByteString-typ    = takeTill (oneof "/ ")-subtyp = takeTill (oneof ",; ")--key = do-    c <- peekChar-    if c == Just ',' then fail "comma" else takeTill (oneof "= ")--val = takeTill (oneof ",; ")--toDouble :: ByteString -> Maybe Double-toDouble bs = toMaybe (parseOnly double bs)-  where-    toMaybe (Right x) = Just x-    toMaybe (Left  _) = Nothing
− src/Network/Wai/Routing/Parser/Shared.hs 
@@ -1,22 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings #-}--module Network.Wai.Routing.Parser.Shared where--import Control.Applicative-import Data.Attoparsec.Char8-import Data.ByteString (ByteString)--import qualified Data.ByteString.Char8 as C--spaces :: Parser ()-spaces = skipWhile (== ' ')--trim :: Parser a -> Parser a-trim p = spaces *> p <* spaces--oneof :: ByteString -> Char -> Bool-oneof s c = C.any (== c) s
src/Network/Wai/Routing/Predicate.hs view
@@ -2,23 +2,38 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -module Network.Wai.Routing.Predicate-    ( module Network.Wai.Routing.Predicate.Accept-    , module Network.Wai.Routing.Predicate.Capture-    , module Network.Wai.Routing.Predicate.Content-    , module Network.Wai.Routing.Predicate.Cookie-    , module Network.Wai.Routing.Predicate.Header-    , module Network.Wai.Routing.Predicate.Param-    , module Network.Wai.Routing.Predicate.Predicate-    , module Network.Wai.Routing.Predicate.Query-    ) where+{-# LANGUAGE OverloadedStrings #-} -import Network.Wai.Routing.Predicate.Accept-import Network.Wai.Routing.Predicate.Capture-import Network.Wai.Routing.Predicate.Content-import Network.Wai.Routing.Predicate.Cookie-import Network.Wai.Routing.Predicate.Header-import Network.Wai.Routing.Predicate.Param-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Predicate.Query+-- | 'Predicate's which are specific to @wai-routing@.+-- Please note that these can be freely combined with other predicates from+-- @wai-predicates@.+module Network.Wai.Routing.Predicate where +import Data.ByteString (ByteString)+import Data.ByteString.From+import Data.Monoid+import Network.HTTP.Types+import Network.Wai.Predicate+import Network.Wai.Predicate.Request+import Network.Wai.Predicate.Utility+import Network.Wai.Routing.Request++-- | Request path parameters.+capture :: (HasCaptures r, FromByteString a) => ByteString -> Predicate r Error a+capture k r = case lookupCapture k r of+    [] -> Fail (err status400 ("Missing path parameter '" <> k <> "'."))+    cc -> either (Fail . err status400) return (readValues cc)++-- | Request path parameters.+hasCapture :: (HasCaptures r) => ByteString -> Predicate r Error ()+hasCapture k r =+    if null (lookupCapture k r)+        then Fail (err status400 ("Missing path parameter '" <> k <> "'."))+        else return ()++-- | @param \"foo\"@ is equivalent to @query \"foo\" .|. capture \"foo\"@+param :: (HasCaptures r, HasQuery r, FromByteString a) => ByteString -> Predicate r Error a+param k = query k .|. capture k++hasParam :: (HasCaptures r, HasQuery r) => ByteString -> Predicate r Error ()+hasParam k = hasQuery k .|. hasCapture k
− src/Network/Wai/Routing/Predicate/Accept.hs 
@@ -1,68 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}--module Network.Wai.Routing.Predicate.Accept-    ( Accept-    , accept-    , module Network.Wai.Routing.MediaType-    ) where--import Control.Monad-import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import Data.Monoid hiding (All)-import GHC.TypeLits-import Data.Maybe-import Network.HTTP.Types-import Network.Wai.Routing.Error-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request-import Network.Wai.Routing.MediaType--import qualified Network.Wai.Routing.Parser.MediaType as M---- | A 'Predicate' against the 'Request's \"Accept\" header.-data Accept (t :: Symbol) (s :: Symbol) = Accept--accept :: Accept t s-accept = Accept-{-# INLINABLE accept #-}--type1 :: SingI t => Accept t s -> ByteString-type1 m = withSing (f m)-  where-    f :: Accept t s -> Sing t -> ByteString-    f _ t = pack $ fromSing t--type2 :: SingI s => Accept t s -> ByteString-type2 m = withSing (f m)-  where-    f :: Accept t s -> Sing s -> ByteString-    f _ s = pack $ fromSing s--instance (SingI t, SingI s) => Predicate (Accept t s) Req where-    type FVal (Accept t s) = Error-    type TVal (Accept t s) = Media t s-    apply a r = let mtypes = M.readMediaTypes "accept" r in-        if null mtypes-            then T 0 (Media (type1 a) (type2 a) 1.0 [])-            else case findMediaType a mtypes of-                m:_ -> T (1.0 - mediaQuality m) m-                []  -> F (err status406 msg)-      where-        msg = "Expected 'Accept: " <> type1 a <> "/" <> type2 a <> "'."--findMediaType :: (SingI t, SingI s) => Accept t s -> [M.MediaType] -> [Media t s]-findMediaType a = mapMaybe (\m -> do-    let at = type1 a-        as = type2 a-        mt = M.medType m-        ms = M.medSubtype m-    guard (mt == "*" || at == mt && ms == "*" || as == ms)-    return $ Media at as (M.medQuality m) (M.medParams m))
− src/Network/Wai/Routing/Predicate/Capture.hs 
@@ -1,62 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- | Predicates against path parameters.--- When declaring routes, paths may contain \"variables\" which--- capture whatever is given at that position by an actual request.--- For example:------ @--- get \"\/user\/:name\/address\/:street\" handler $---     Capture \"name\" :&: Capture \"street\"--- @------ extracts from a request path whatever is given for @:name@--- and @:street@.-module Network.Wai.Routing.Predicate.Capture-    ( Capture-    , HasCapture-    , capture-    , hasCapture-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Data.Monoid-import Network.HTTP.Types.Status-import Network.Wai.Routing.Error-import Network.Wai.Routing.Internal-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--newtype Capture a = Capture ByteString--capture :: ByteString -> Capture a-capture = Capture-{-# INLINABLE capture #-}--instance (FromByteString a) => Predicate (Capture a) Req where-    type FVal (Capture a) = Error-    type TVal (Capture a) = a-    apply (Capture x)     =-        let msg = "Missing path parameter '" <> x <> "'." in-        rqApply (lookupCapture x) readValues (err status400 msg)--newtype HasCapture = HasCapture ByteString--hasCapture :: ByteString -> HasCapture-hasCapture = HasCapture-{-# INLINABLE hasCapture #-}--instance Predicate HasCapture Req where-    type FVal HasCapture   = Error-    type TVal HasCapture   = ()-    apply (HasCapture x) r =-        if null (lookupCapture x r)-            then F (err status400 ("Missing path parameter '" <> x <> "'."))-            else T 0 ()
− src/Network/Wai/Routing/Predicate/Content.hs 
@@ -1,71 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}--module Network.Wai.Routing.Predicate.Content-    ( ContentType-    , contentType-    , module Network.Wai.Routing.MediaType-    ) where--import Control.Monad-import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import Data.Monoid hiding (All)-import GHC.TypeLits-import Data.Maybe-import Network.HTTP.Types.Status-import Network.Wai.Routing.Error-import Network.Wai.Routing.MediaType-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--import qualified Network.Wai.Routing.Parser.MediaType as M---- | A 'Predicate' against the 'Request's \"Content-Type\" header.-data ContentType (t :: Symbol) (s :: Symbol) = ContentType--contentType :: ContentType t s-contentType = ContentType-{-# INLINABLE contentType #-}--type1 :: SingI t => ContentType t s -> ByteString-type1 m = withSing (f m)-  where-    f :: ContentType t s -> Sing t -> ByteString-    f _ t = pack $ fromSing t--type2 :: SingI s => ContentType t s -> ByteString-type2 m = withSing (f m)-  where-    f :: ContentType t s -> Sing s -> ByteString-    f _ s = pack $ fromSing s--instance (SingI t, SingI s) => Predicate (ContentType t s) Req where-    type FVal (ContentType t s) = Error-    type TVal (ContentType t s) = Media t s-    apply c r = let mtypes = M.readMediaTypes "content-type" r in-        case findContentType c mtypes of-            m:_ -> T (1.0 - mediaQuality m) m-            []  -> F (err status415 msg)-      where-        msg = "Expected 'Content-Type: " <> type1 c <> "/" <> type2 c <> "'."--findContentType :: (SingI t, SingI s) => ContentType t s -> [M.MediaType] -> [Media t s]-findContentType c = mapMaybe (\m -> do-    let ct = type1 c-        cs = type2 c-        mt = M.medType m-        ms = M.medSubtype m-    guard (ct == "*" || ct == mt && cs == "*" || cs == ms)-    return $ Media mt ms (quality ct cs) (M.medParams m))-  where-    quality "*" "*" = 0-    quality "*"  _  = 0.2-    quality  _  "*" = 0.5-    quality  _   _  = 1.0
− src/Network/Wai/Routing/Predicate/Cookie.hs 
@@ -1,52 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Network.Wai.Routing.Predicate.Cookie-    ( Cookie-    , HasCookie-    , cookie-    , hasCookie-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Data.Monoid-import Network.HTTP.Types.Status-import Network.Wai.Routing.Error-import Network.Wai.Routing.Internal-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--newtype Cookie a = Cookie ByteString--cookie :: ByteString -> Cookie a-cookie = Cookie-{-# INLINABLE cookie #-}--instance (FromByteString a) => Predicate (Cookie a) Req where-    type FVal (Cookie a) = Error-    type TVal (Cookie a) = a-    apply (Cookie x)     =-        rqApply (lookupCookie x) readValues (err status400 (msg x))--newtype HasCookie = HasCookie ByteString--hasCookie :: ByteString -> HasCookie-hasCookie = HasCookie-{-# INLINABLE hasCookie #-}--instance Predicate HasCookie Req where-    type FVal HasCookie   = Error-    type TVal HasCookie   = ()-    apply (HasCookie x) r =-        if null (lookupCookie x r)-            then F (err status400 (msg x))-            else T 0 ()--msg :: ByteString -> ByteString-msg x = "Missing cookie '" <> x <> "'."
− src/Network/Wai/Routing/Predicate/Header.hs 
@@ -1,54 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}--module Network.Wai.Routing.Predicate.Header-    ( Hdr-    , HasHdr-    , hdr-    , hasHdr-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Data.CaseInsensitive (mk)-import Data.List (find)-import Data.Maybe-import Data.Monoid-import Network.HTTP.Types.Status-import Network.Wai.Routing.Error-import Network.Wai.Routing.Internal-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--newtype Hdr a = Hdr ByteString--hdr :: ByteString -> Hdr a-hdr = Hdr-{-# INLINABLE hdr #-}--instance (FromByteString a) => Predicate (Hdr a) Req where-    type FVal (Hdr a) = Error-    type TVal (Hdr a) = a-    apply (Hdr x)     =-        let msg = "Missing header '" <> x <> "'." in-        rqApply (lookupHeader x) readValues (err status400 msg)--newtype HasHdr = HasHdr ByteString--hasHdr :: ByteString -> HasHdr-hasHdr = HasHdr-{-# INLINABLE hasHdr #-}--instance Predicate HasHdr Req where-    type FVal HasHdr   = Error-    type TVal HasHdr   = ()-    apply (HasHdr x) r =-        if isJust $ find ((mk x ==) . fst) (headers r)-            then T 0 ()-            else F (err status400 ("Missing header '" <> x <> "'."))-
− src/Network/Wai/Routing/Predicate/Param.hs 
@@ -1,45 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Network.Wai.Routing.Predicate.Param-    ( Param-    , HasParam-    , param-    , hasParam-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Network.Wai.Routing.Error-import Network.Wai.Routing.Request-import Network.Wai.Routing.Predicate.Capture-import Network.Wai.Routing.Predicate.Query-import Network.Wai.Routing.Predicate.Predicate---- | @Param \"x\"@ is equivalent to @'Query' \"x\" ':|:' 'Capture' \"x\"@.-newtype Param a = Param ByteString--param :: ByteString -> Param a-param = Param-{-# INLINABLE param #-}--instance (FromByteString a) => Predicate (Param a) Req where-    type FVal (Param a) = Error-    type TVal (Param a) = a-    apply (Param x)     = apply (query x :|: capture x)--newtype HasParam = HasParam ByteString--hasParam :: ByteString -> HasParam-hasParam = HasParam-{-# INLINABLE hasParam #-}--instance Predicate HasParam Req where-    type FVal HasParam = Error-    type TVal HasParam = ()-    apply (HasParam x) = apply (hasQuery x :|: hasCapture x)-
− src/Network/Wai/Routing/Predicate/Predicate.hs 
@@ -1,240 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--module Network.Wai.Routing.Predicate.Predicate-    ( Delta-    , Boolean   (..)-    , Predicate (..)-    , (:|:)     (..)-    , (:&:)     (..)-    , (:||:)    (..)-    , (:::)     (..)-    , (:+:)-    , Const-    , Fail-    , Opt-    , Def-    , PMap-    , PMapT-    , PMapF--    , constant-    , failure-    , true-    , opt-    , def-    , pmap-    , pmapT-    , pmapF-    , with-    ) where--import Prelude hiding (and, or)---- | '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 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--- 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)---- | 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 0 a--constant :: t -> Const f t-constant = Const-{-# INLINABLE constant #-}--true :: Const a ()-true = Const ()-{-# INLINABLE true #-}---- | 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--failure :: f -> Fail f t-failure = Fail-{-# INLINABLE failure #-}--instance Predicate (Fail f t) a where-    type FVal (Fail f t) = f-    type TVal (Fail f t) = t-    apply (Fail a) _     = F 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.------ 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 `or` 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--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.------ 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   = apply a r `or` 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---- | 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 `and` 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---- | A 'Predicate' modifier which makes the underlying predicate optional,--- i.e. the 'TVal' becomes a 'Maybe' and in the failure-case 'Nothing' is--- returned.-newtype Opt a = Opt a--opt :: a -> Opt a-opt = Opt-{-# INLINABLE opt #-}--instance (Predicate a b) => Predicate (Opt a) b where-    type FVal (Opt a) = FVal a-    type TVal (Opt a) = Maybe (TVal a)-    apply (Opt a) r   = case apply a r of-        T d x -> T d (Just x)-        F _   -> T 0 Nothing---- | A 'Predicate' modifier which returns as 'TVal' the provided default--- value if the underlying predicate fails.-data Def d a = Def d a--def :: d -> a -> Def d a-def = Def-{-# INLINABLE def #-}--instance (Predicate a b, d ~ TVal a) => Predicate (Def d a) b where-    type FVal (Def d a) = FVal a-    type TVal (Def d a) = TVal a-    apply (Def d a) r   = case apply a r of-        T n x -> T n x-        F _   -> T 0 d---- | A 'Predicate' function, i.e. a function of the underlying predicate's--- result.-data PMap a f t = PMap (Boolean (FVal a) (TVal a) -> Boolean f t) a--pmap :: (Boolean (FVal a) (TVal a) -> Boolean f t) -> a -> PMap a f t-pmap = PMap-{-# INLINABLE pmap #-}--instance (Predicate a b) => Predicate (PMap a f t) b where-    type FVal (PMap a f t) = f-    type TVal (PMap a f t) = t-    apply (PMap f a) r     = f $ apply a r---- | Like 'PMap' but a function of the underlying predicate's 'TVal'.-data PMapT a t = PMapT (TVal a -> Boolean (FVal a) t) a--pmapT :: (TVal a -> Boolean (FVal a) t) -> a -> PMapT a t-pmapT = PMapT-{-# INLINABLE pmapT #-}--instance (Predicate a b) => Predicate (PMapT a t) b where-    type FVal (PMapT a t) = FVal a-    type TVal (PMapT a t) = t-    apply (PMapT f a) r   = case apply a r of-        (T _ x) -> f x-        (F x)   -> F x---- | Like 'PMap' but a function of the underlying predicate's 'FVal'.-data PMapF a f = PMapF (FVal a -> Boolean f (TVal a)) a--pmapF :: (FVal a -> Boolean f (TVal a)) -> a -> PMapF a f-pmapF = PMapF-{-# INLINABLE pmapF #-}--instance (Predicate a b) => Predicate (PMapF a f) b where-    type FVal (PMapF a f) = f-    type TVal (PMapF a f) = TVal a-    apply (PMapF f a) r   = case apply a r of-        (F   x) -> f x-        (T d x) -> T d x---- | 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 apply p a of-    T _ x -> f x-    _     -> return ()
− src/Network/Wai/Routing/Predicate/Query.hs 
@@ -1,50 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Network.Wai.Routing.Predicate.Query-    ( Query-    , HasQuery-    , query-    , hasQuery-    ) where--import Data.ByteString (ByteString)-import Data.ByteString.From-import Data.Monoid-import Network.HTTP.Types.Status-import Network.Wai.Routing.Error-import Network.Wai.Routing.Internal-import Network.Wai.Routing.Predicate.Predicate-import Network.Wai.Routing.Request--newtype Query a = Query ByteString--query :: ByteString -> Query a-query = Query-{-# INLINABLE query #-}--instance (FromByteString a) => Predicate (Query a) Req where-    type FVal (Query a) = Error-    type TVal (Query a) = a-    apply (Query x)     =-        let msg = "Missing query '" <> x <> "'." in-        rqApply (lookupQuery x) readValues (err status400 msg)--newtype HasQuery = HasQuery ByteString--hasQuery :: ByteString -> HasQuery-hasQuery = HasQuery-{-# INLINABLE hasQuery #-}--instance Predicate HasQuery Req where-    type FVal HasQuery   = Error-    type TVal HasQuery   = ()-    apply (HasQuery x) r =-        if null (lookupQuery x r)-            then F (err status400 ("Missing query '" <> x <> "'."))-            else T 0 ()
src/Network/Wai/Routing/Request.hs view
@@ -2,84 +2,48 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- | A wrapped WAI 'Request' which holds additional data of interest--- only to 'Predicate' authors. module Network.Wai.Routing.Request-    ( Req-    , GetRequest-    , getRequest-    , fromWaiRequest-    , waiRequest-    , method-    , headers-    , lookupHeader+    ( RoutingReq+    , HasCaptures (..)+    , fromReq     , lookupCapture-    , lookupQuery-    , lookupCookie     ) where  import Data.ByteString (ByteString)-import Data.CaseInsensitive (mk)-import Data.Maybe (mapMaybe)-import Network.HTTP.Types-import Network.Wai (Request)-import Network.Wai.Routing.Predicate.Predicate-import Web.Cookie+import Network.Wai.Predicate.Request -import qualified Network.Wai as Wai+class HasCaptures a where+     captures :: a -> [(ByteString, ByteString)] -data Req = Req-    { captures :: [(ByteString, ByteString)]-    , request  :: Request-    , cookies  :: Cookies+data RoutingReq = RoutingReq+    { _captures :: [(ByteString, ByteString)]+    , _request  :: Req     } --- | A 'Predicate' which just returns the WAI 'Wai.Request'.--- By including this predicate, handlers have easy access to--- the complete request.-data GetRequest a = GetRequest+instance HasRequest RoutingReq where+    getRequest = getRequest . _request -getRequest :: GetRequest a-getRequest = GetRequest-{-# INLINABLE getRequest #-}+instance HasMethod RoutingReq where+    method = method . _request -instance Predicate (GetRequest a) Req where-    type FVal (GetRequest a) = a-    type TVal (GetRequest a) = Request-    apply GetRequest r       = T 0 (request r)+instance HasHeaders RoutingReq where+    headers = headers . _request -fromWaiRequest :: [(ByteString, ByteString)] -> Request -> Req-fromWaiRequest ca rq =-    Req ca rq (concatMap parseCookies (getHeaders "Cookie" rq))+instance HasCookies RoutingReq where+    cookies = cookies . _request -waiRequest :: Req -> Request-waiRequest = request+instance HasQuery RoutingReq where+    queryItems = queryItems . _request -headers :: Req -> RequestHeaders-headers = Wai.requestHeaders . request+instance HasPath RoutingReq where+    segments = segments . _request -method :: Req -> Method-method = Wai.requestMethod . request+instance HasCaptures RoutingReq where+    captures = _captures -lookupHeader :: ByteString -> Req -> [ByteString]-lookupHeader name = getHeaders name . request+fromReq :: [(ByteString, ByteString)] -> Req -> RoutingReq+fromReq = RoutingReq -lookupCapture :: ByteString -> Req -> [ByteString]+lookupCapture :: (HasCaptures r) => ByteString -> r -> [ByteString] lookupCapture name = map snd . filter ((name ==) . fst) . captures--lookupCookie :: ByteString -> Req -> [ByteString]-lookupCookie name = map snd . filter ((name ==) . fst) . cookies--lookupQuery :: ByteString -> Req -> [ByteString]-lookupQuery name = mapMaybe snd-                 . filter ((name ==) . fst)-                 . Wai.queryString-                 . request--getHeaders :: ByteString -> Wai.Request -> [ByteString]-getHeaders name = map snd . filter ((mk name ==) . fst) . Wai.requestHeaders
src/Network/Wai/Routing/Route.hs view
@@ -9,11 +9,11 @@  module Network.Wai.Routing.Route     ( Routes-    , Renderer-    , route     , prepare-    , renderer+    , route     , addRoute+    , attach+    , examine     , get     , Network.Wai.Routing.Route.head     , post@@ -22,8 +22,8 @@     , trace     , options     , connect-    , attach-    , examine+    , Renderer+    , renderer     ) where  import Control.Applicative hiding (Const)@@ -38,8 +38,8 @@ import Data.Monoid import Network.HTTP.Types import Network.Wai (Request, Response, responseLBS, responseBuilder, rawPathInfo)-import Network.Wai.Routing.Predicate-import Network.Wai.Routing.Error+import Network.Wai.Predicate+import Network.Wai.Predicate.Request import Network.Wai.Routing.Request  import qualified Data.ByteString.Char8  as C@@ -55,15 +55,12 @@     }  data Handler m = Handler-    { _delta   :: !Delta+    { _delta   :: !Double     , _handler :: m Response     }  data Pack m where-    Pack :: (Predicate p Req, FVal p ~ Error)-         => p-         -> (TVal p -> m Response)-         -> Pack m+    Pack :: Predicate RoutingReq Error a -> (a -> m Response) -> Pack m  -- | Function to turn an 'Error' value into a 'Lazy.ByteString'. -- Clients can provide their own renderer using 'renderer'.@@ -71,7 +68,7 @@  -- | Set a custom render function, i.e. a function to turn 'Error's into -- 'Lazy.ByteString's.-renderer :: Renderer -> Routes m a ()+renderer :: Renderer -> Routes a m () renderer f = Routes . modify $ \s -> s { renderfn = f }  -- | The Routes monad state type.@@ -101,22 +98,22 @@  -- | Add a route for some 'Method' and path (potentially with variable -- captures) and constrained by some 'Predicate'.-addRoute :: (Monad m, Predicate p Req, FVal p ~ Error)+addRoute :: Monad m          => Method-         -> ByteString             -- ^ path-         -> (TVal p -> m Response) -- ^ handler-         -> p                      -- ^ 'Predicate'-         -> Routes a m ()+         -> ByteString                   -- ^ path+         -> (a -> m Response)            -- ^ handler+         -> Predicate RoutingReq Error a -- ^ 'Predicate'+         -> Routes b m () addRoute m r x p = Routes . modify $ \s ->     s { routes = Route m r Nothing (Pack p x) : routes s }  -- | Specialisation of 'addRoute' for a specific HTTP 'Method'. get, head, post, put, delete, trace, options, connect ::-    (Monad m, Predicate p Req, FVal p ~ Error)-    => ByteString             -- ^ path-    -> (TVal p -> m Response) -- ^ handler-    -> p                      -- ^ 'Predicate'-    -> Routes a m ()+    Monad m+    => ByteString                   -- ^ path+    -> (a -> m Response)            -- ^ handler+    -> Predicate RoutingReq Error a -- ^ 'Predicate'+    -> Routes b m () get     = addRoute (renderStdMethod GET) head    = addRoute (renderStdMethod HEAD) post    = addRoute (renderStdMethod POST)@@ -140,17 +137,17 @@  -- | A WAI 'Application' (generalised from 'IO' to 'Monad') which -- routes requests to handlers based on predicated route declarations.-route :: Monad m => [(ByteString, Req -> m Response)] -> Request -> m Response+route :: Monad m => [(ByteString, RoutingReq -> m Response)] -> Request -> m Response route rm rq = do     let tr = Tree.fromList rm     case Tree.lookup tr (Tree.segments $ rawPathInfo rq) of-        Just (f, v) -> f (fromWaiRequest v rq)+        Just (f, v) -> f (fromReq v (fromRequest rq))         Nothing     -> return notFound   where     notFound = responseLBS status404 [] ""  -- | Run the 'Routes' monad and return the handlers per path.-prepare :: Monad m => Routes a m b -> [(ByteString, Req -> m Response)]+prepare :: Monad m => Routes a m b -> [(ByteString, RoutingReq -> m Response)] prepare (Routes rr) =     let s = execState rr zero in     map (\g -> (_path (L.head g), select (renderfn s) g)) (normalise (routes s))@@ -184,7 +181,7 @@ -- (2) Evaluate 'Route' predicates. -- (3) Pick the first one which is 'Good', or else respond with status --     and message of the first one.-select :: Monad m => Renderer -> [Route a m] -> Req -> m Response+select :: Monad m => Renderer -> [Route a m] -> RoutingReq -> m Response select render rr req = do     let ms = filter ((method req ==) . _method) rr     if null ms@@ -207,9 +204,9 @@     evalSingle :: Monad m => [Either Error (Handler m)] -> Route a m -> [Either Error (Handler m)]     evalSingle rs r =         case _pred r of-            Pack p h -> case apply p req of-                F   m -> Left m : rs-                T d v -> Right (Handler d (h v)) : rs+            Pack p h -> case p req of+                Fail   m -> Left m : rs+                Okay d v -> Right (Handler d (h v)) : rs      closest :: Monad m => [Handler m] -> m Response     closest hh = case map _handler . sortBy (compare `on` _delta) $ hh of@@ -218,3 +215,4 @@  respond :: Renderer -> Error -> ResponseHeaders -> Response respond f e h = responseLBS (status e) h (fromMaybe mempty (f e))+
− src/Network/Wai/Routing/Tutorial.hs 
@@ -1,176 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at http://mozilla.org/MPL/2.0/.--module Network.Wai.Routing.Tutorial-  ( -- * Motivation-    -- $motivation--    -- * Introduction-    -- $introduction--    -- * Example Predicate-    -- $example--    -- * Routes-    -- $routes-  )-where--{- $motivation--The purpose of the @wai-routing@ package is to facilitate the-convenient definition of safe WAI 'Application's. Here safety-means that a handler can declare all pre-conditions which must be-fulfilled such that the handler can produce a successful response (excluding-the request body). It is then statically guaranteed that the handler will not be-invoked if any of these pre-conditions fails.---}--{- $introduction--The @wai-routing@ package defines a 'Network.Wai.Routing.Predicate.Predicate.Boolean' type-which carries \-\- in addition to actual truth values @T@ and @F@ \-\- meta-data for each case:--@-data Boolean f t-    = F f-    | T Delta t-    deriving (Eq, Show)-@--'Network.Wai.Routing.Predicate.Predicate.Delta' can in most instances be ignored, i.e. set to 0.-Its purpose is as a measure of distance for those predicates which evaluate-to @T@ but some may be \"closer\" in some way than others. An-example is for instance HTTP content-negotiations (cf.-'Network.Wai.Routing.Predicate.Accept.Accept')--In addition there is a type-class 'Network.Wai.Routing.Predicate.Predicate.Predicate' defined which-contains an evaluation function 'Network.Wai.Routing.Predicate.Predicate.apply', where the-predicate instance is applied to some value, yielding @T@ or @F@.--@-class Predicate p a where-    type FVal p-    type TVal p-    apply :: p -> a -> Boolean (FVal p) (TVal p)-@--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.-WAI related predicates are defined against 'Network.Wai.Routing.Request.Req'-which holds a regular 'Network.Wai.Request' and path capture variables.-In case predicates fail, they return a status code and an optional message.--Besides these type definitions, there are some ways to connect two-predicates to form a new one as the logical @OR@ or the-logical @AND@ of its parts. These are:--  * 'Network.Wai.Routing.Predicate.Predicate.:|:' and 'Network.Wai.Routing.Predicate.Predicate.:||:' as logical @OR@s--  * 'Network.Wai.Routing.Predicate.Predicate.:&:' as logical @AND@--In addition to evaluating to @T@ or @F@ depending on the truth values of-its parts, these connectives also propagate the meta-data and @Delta@-appropriately.--If @:&:@ evaluates to @F@ it has to combine the meta-data of both predicates,-and it uses the product type 'Network.Wai.Routing.Predicate.Predicate.:::' for this.-This type also has a data constructor with 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 @:||:@. For convenience a type-alias-@:+:@ 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 @:|:@ combinator can be used.--Finally there are 'Network.Wai.Routing.Predicate.Predicate.Const' and-'Network.Wai.Routing.Predicate.Predicate.Fail' to always evaluate to @T@ or @F@-respectively.--As an example of how these operators are used, see below in section \"Routes\".--}--{- $example--@-newtype Query = Query ByteString--instance Predicate Query Req where-    type FVal Query = Error-    type TVal Query = ByteString-    apply (Query x) r =-        case lookupQuery x r of-            []    -> F (Error 400 (Just $ \"Expected parameter '\" \<\> x \<\> \"'.\"))-            (v:_) -> T [] v-@--This is a simple example looking for the existence of a 'Req' query-parameter with the given name. In the success case, the query value is-returned.--As mentioned before, WAI predicates usually fix the type @a@ from-@Predicate@ above to 'Network.Wai.Routing.Request.Req'. The associated-types 'Network.Wai.Routing.Predicate.Predicate.FVal' and-'Network.Wai.Routing.Predicate.Predicate.TVal' denote the meta-data-types of the predicate. In this example, the meta-date type is-'Data.ByteString.ByteString'. The @F@-case is 'Network.Wai.Routing.Error.Error'-which contains a status code and an optional message.---}--{- $routes--So how are @Predicate@s used in an application?-One way is to just evaluate them against a given request, e.g.--@-someHandler :: Application-someHandler r =-    case apply (accept :&: query \"baz\") (fromWaiRequest [] r) of-        T ((_ :: Media \"text\" \"plain\") ::: bazValue) -> ...-        F (Just (Error st msg))                      -> ...-        F Nothing                                    -> ...-@--This however requires the manual construction of a 'Network.Wai.Routing.Request.Req' and-for brevity we did not provide the list of captured path parameters.-The intended application of @wai-routing@ is to declare route definitions with the-'Network.Wai.Routing.Route.Routes' monad which can be turned into a WAI @Application@-generalised from IO to arbitrary @Monad@s through 'Network.Wai.Routing.Route.route'.-This application will at runtime select the actual handler to invoke (using the @wai-route@-library).--@-sitemap :: Routes ()-sitemap = do-    get  \"\/a\" handlerA $ accept :&: (query \"name\" :|: query \"nick\") :&: query \"foo\"-    get  \"\/b\" handlerB $ accept :&: (query \"name\" :||: query \"nick\") :&: query \"foo\"-    get  \"\/c\" handlerC $ failure (Error 410 (Just \"Gone.\"))-    post \"\/d\" handlerD $ accept-    post \"\/e\" handlerE $ accept-@--Handler definitions encode their pre-conditions in their type-signature:--@-handlerA :: Media \"application\" \"json\" ::: ByteString ::: ByteString -> IO Response-handlerB :: Media \"text\" \"plain\" ::: (ByteString :+: ByteString) ::: ByteString -> IO Response-handlerC :: Media \"application\" \"json\" ::: Char -> IO Response-handlerD :: Media \"application\" \"x-protobuf\" -> IO Response-handlerE :: Media \"application\" \"xml\" -> IO Response-@--The type-declaration of a handler has to match the corresponding predicate,-i.e. the type of the predicate's @T@ meta-data value.--One thing to note is that @Fail@ works with-all @T@ meta-data types which is safe because the handler is never-invoked, or @Fail@ is used in some logical disjunction.--}-
test/TestSuite.hs view
@@ -1,13 +1,7 @@ module Main where  import Test.Tasty-import qualified Tests.Data.Predicate as Predicate-import qualified Tests.Wai.Predicate  as WaiPredicate-import qualified Tests.Wai.Route      as WaiRoute+import qualified Tests.Wai.Route as WaiRoute  main :: IO ()-main = defaultMain $ testGroup "Tests"-    [ Predicate.tests-    , WaiPredicate.tests-    , WaiRoute.tests-    ]+main = defaultMain $ testGroup "Tests" [ WaiRoute.tests ]
− test/Tests/Data/Predicate.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# OPTIONS_GHC -fno-warn-orphans  #-}-module Tests.Data.Predicate (tests) where--import Control.Applicative hiding (Const, empty)-import Network.Wai.Routing.Predicate.Predicate-import Test.QuickCheck-import Test.Tasty-import Test.Tasty.QuickCheck--tests :: TestTree-tests = testGroup "Data.Predicate"-    [ testProperty "(:&:)" testAnd-    , testProperty "(:||:)" testOr-    , testProperty "(:|:)" testOr'-    ]--testAnd :: Rand -> Rand -> Bool-testAnd a@(Rand (T d x)) b@(Rand (T w y)) = apply (a :&: b) () == T (d + w) (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 d x)) b@(Rand (T e y)) = apply (a :||: b) () == if d <= e then T d (Left x) else T e (Right y)-testOr a@(Rand (T d x)) b@(Rand (F   _)) = apply (a :||: b) () == T d (Left x)-testOr a@(Rand (F   _)) b@(Rand (T d y)) = apply (a :||: b) () == T d (Right y)-testOr a@(Rand (F   _)) b@(Rand (F   y)) = apply (a :||: b) () == F y--testOr' :: Rand -> Rand -> Bool-testOr' a@(Rand (T d x)) b@(Rand (T e y)) = apply (a :|: b) () == if d <= e then T d x else T e y-testOr' a@(Rand (T d x)) b@(Rand (F   _)) = apply (a :|: b) () == T d x-testOr' a@(Rand (F   _)) b@(Rand (T d y)) = apply (a :|: b) () == T d y-testOr' a@(Rand (F   _)) b@(Rand (F   y)) = apply (a :|: b) () == F y--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--instance Arbitrary (Boolean Int Char) where-    arbitrary =-        oneof [ T <$> (arbitrary :: Gen Delta) <*> (arbitrary :: Gen Char)-              , F <$> (arbitrary :: Gen Int)-              ]--instance Arbitrary Rand where-    arbitrary = Rand <$> (arbitrary :: Gen (Boolean Int Char))
− test/Tests/Wai/Predicate.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}--module Tests.Wai.Predicate (tests) where--import Data.ByteString (ByteString)-import Network.HTTP.Types.Status-import Network.Wai.Routing-import Test.Tasty-import Test.Tasty.HUnit-import Tests.Wai.Util--tests :: TestTree-tests = testGroup "Wai.Predicate"-    [ testCase "Accept application/json" testAcceptJson-    , testCase "Accept application/thrift " testAcceptThrift-    , testCase "Accept application/*" testAcceptAll-    , testCase "Content-Type text/plain" testContentTypePlain-    , testCase "Content-Type text/*" testContentTypeAll-    , testCase "Query" testQuery-    , testCase "QueryOpt" testQueryOpt-    ]--testAcceptJson :: IO ()-testAcceptJson = do-    let rq0 = fromWaiRequest [] . json $ request "/"-    T 0 (Media "application" "json" 1.0 []) @=? apply (accept :: Accept "application" "json") rq0--    let rq1 = fromWaiRequest [] . withHeader "Accept" "foo/bar" $ request "/"-    F (err status406 ("Expected 'Accept: application/json'.")) @=? apply (accept :: Accept "application" "json") rq1--testAcceptThrift :: IO ()-testAcceptThrift = do-    let rq0 = fromWaiRequest [] . withHeader "Accept" "application/x-thrift" $ request "/"-    T 0 (Media "application" "x-thrift" 1.0 []) @=? apply (accept :: Accept "application" "x-thrift") rq0--    let rq1 = fromWaiRequest [] . json $ request "/"-    F (err status406 ("Expected 'Accept: application/x-thrift'.")) @=? apply (accept :: Accept "application" "x-thrift") rq1--testAcceptAll :: IO ()-testAcceptAll = do-    let rq0 = fromWaiRequest [] . withHeader "Accept" "application/*" $ request "/"-    T 0 (Media "application" "*"    1.0 []) @=? apply (accept :: Accept "application" "*") rq0-    T 0 (Media "application" "json" 1.0 []) @=? apply (accept :: Accept "application" "json") rq0--testContentTypePlain :: IO ()-testContentTypePlain = do-    let rq0 = fromWaiRequest [] . withHeader "Content-Type" "text/plain" $ request "/"-    T 0 (Media "text" "plain" 1.0 []) @=? apply (contentType :: ContentType "text" "plain") rq0--    let rq1 = fromWaiRequest [] . withHeader "Content-Type" "text/html" $ request "/"-    F (err status415 ("Expected 'Content-Type: text/plain'.")) @=? apply (contentType :: ContentType "text" "plain") rq1--testContentTypeAll :: IO ()-testContentTypeAll = do-    let rq0 = fromWaiRequest [] . withHeader "Content-Type" "text/plain" $ request "/"-    T 0.5 (Media "text" "plain" 0.5 []) @=? apply (contentType :: ContentType "text" "*") rq0--testQuery :: IO ()-testQuery = do-    let rq0 = fromWaiRequest [] . withQuery "x" "y" . withQuery "x" "z" $ request "/"-    T 0 "y" @=? apply (query "x" :: Query ByteString) rq0--    let rq1 = fromWaiRequest [] $ request "/"-    F (err status400 ("Missing query 'x'.")) @=? apply (query "x" :: Query ByteString) rq1--testQueryOpt :: IO ()-testQueryOpt = do-    let rq0 = fromWaiRequest [] . withQuery "x" "y" . withQuery "x" "z" $ request "/"-    T 0 (Just "y") @=? apply (opt (query "x" :: Query ByteString)) rq0--    let rq1 = fromWaiRequest [] $ request "/"-    T 0 Nothing @=? apply (opt (query "x" :: Query ByteString)) rq1-
test/Tests/Wai/Route.hs view
@@ -9,7 +9,10 @@ import Data.String import Network.HTTP.Types import Network.Wai+import Network.Wai.Predicate+import Network.Wai.Predicate.Request import Network.Wai.Routing+import Network.Wai.Routing.Request import Test.HUnit hiding (Test) import Test.Tasty import Test.Tasty.HUnit@@ -42,7 +45,7 @@ sitemap :: Routes Int IO () sitemap = do     get "/a" handlerA $-        accept :&: (query "name" :|: query "nick") :&: query "foo"+        accept "application" "json" .&. (query "name" .|. query "nick") .&. query "foo"      attach 0 @@ -62,7 +65,7 @@     attach 3      get "/e" handlerE $-        def 0 (hdr "foo")+        def 0 (header "foo")      attach 4 @@ -76,7 +79,7 @@     attach 6      get "/h" handlerH $-        cookie "user" :&: cookie "age"+        cookie "user" .&. cookie "age"      attach 7 @@ -225,8 +228,8 @@  sitemapMedia :: Routes a IO () sitemapMedia = do-    get "/media" handlerJson   accept-    get "/media" handlerThrift accept+    get "/media" handlerJson   $ accept "application" "json"+    get "/media" handlerThrift $ accept "application" "x-thrift"  handlerJson :: Media "application" "json" -> IO Response handlerJson _ = writeText "application/json"@@ -234,8 +237,8 @@ handlerThrift :: Media "application" "x-thrift" -> IO Response handlerThrift _ = writeText "application/x-thrift" -expectMedia :: ByteString -> ByteString -> (Req -> IO Response) -> Assertion+expectMedia :: ByteString -> ByteString -> (RoutingReq -> IO Response) -> Assertion expectMedia h res m = do     let rq = defaultRequest { rawPathInfo = "/media" }-    rs <- m . fromWaiRequest [] . withHeader "Accept" h $ rq+    rs <- m . fromReq [] . fromRequest . withHeader "Accept" h $ rq     Lazy.fromStrict res @=? responseBody rs
wai-routing.cabal view
@@ -1,5 +1,5 @@ name:                wai-routing-version:             0.3.1+version:             0.4 synopsis:            Declarative routing for WAI. license:             OtherLicense license-file:        LICENSE@@ -23,14 +23,38 @@     which operate on WAI requests and have to be true or else the     handler will not be called.     .-    For details have a look at the haddock documentation of-    @Network.Wai.Routing.Tutorial@ or the @examples@ folder in the-    source distribution.-    .-    This library is a port of @snap-predicates@ which provides-    similar functionality for the snap-framework.+    Example:     .-    The routing tree construction is implemented using @wai-route@.+    >import Data.ByteString (ByteString)+    >import Data.Text (Text)+    >import Network.Wai+    >import Network.Wai.Predicate+    >import Network.Wai.Routing+    >import Network.Wai.Handler.Warp+    >+    >main :: IO ()+    >main = run 8080 (route (prepare start))+    >+    >start :: Monad m => Routes a m ()+    >start = do+    >    get "/user/:name" fetchUser $+    >        capture "name"+    >+    >    get "/user/find" findUser $+    >        query "byName" ||| query "byId"+    >+    >    delete "/user/:name" rmUser $+    >        capture "name" .&. opt (cookie "foo")+    >+    >fetchUser :: Monad m => Text -> m Response+    >fetchUser name = ...+    >+    >findUser :: Monad m => Either ByteString Word64 -> m Response+    >findUser (Left  name)  = ...+    >findUser (Right ident) = ...+    >+    >rmUser :: Monad m => Text ::: Maybe Int -> m Response+    >rmUser (name ::: foo)  = ...  source-repository head     type:             git@@ -44,36 +68,21 @@      exposed-modules:         Network.Wai.Routing-        Network.Wai.Routing.Error-        Network.Wai.Routing.MediaType         Network.Wai.Routing.Request         Network.Wai.Routing.Route-        Network.Wai.Routing.Tutorial         Network.Wai.Routing.Predicate-        Network.Wai.Routing.Predicate.Predicate-        Network.Wai.Routing.Predicate.Accept-        Network.Wai.Routing.Predicate.Capture-        Network.Wai.Routing.Predicate.Content-        Network.Wai.Routing.Predicate.Cookie-        Network.Wai.Routing.Predicate.Header-        Network.Wai.Routing.Predicate.Param-        Network.Wai.Routing.Predicate.Query -    other-modules:-        Network.Wai.Routing.Internal-        Network.Wai.Routing.Parser.MediaType-        Network.Wai.Routing.Parser.Shared-     build-depends:         attoparsec       >= 0.10  && < 0.12       , base             == 4.*       , bytestring       >= 0.9   && < 0.11-      , bytestring-from  == 0.1.*+      , bytestring-from  == 0.2.*       , cookie           == 0.4.*       , case-insensitive == 1.1.*       , http-types       == 0.8.*       , transformers     == 0.3.*       , wai              == 2.0.*+      , wai-predicates   == 0.2.*       , wai-route        == 0.1.*  test-suite wai-routing-tests@@ -85,21 +94,20 @@     ghc-prof-options: -prof -auto-all      other-modules:-        Tests.Data.Predicate-        Tests.Wai.Predicate         Tests.Wai.Route         Tests.Wai.Util      build-depends:-        base                 == 4.*-      , blaze-builder        == 0.3.*+        base             == 4.*+      , blaze-builder    == 0.3.*       , bytestring       , case-insensitive       , http-types-      , HUnit                >= 1.2-      , QuickCheck           >= 2.3-      , tasty                >= 0.3-      , tasty-hunit          >= 0.2-      , tasty-quickcheck     >= 0.3+      , HUnit            >= 1.2+      , QuickCheck       >= 2.3+      , tasty            >= 0.3+      , tasty-hunit      >= 0.2+      , tasty-quickcheck >= 0.3       , wai+      , wai-predicates   == 0.2.*       , wai-routing