wai-routing 0.1 → 0.2
raw patch · 15 files changed
+273/−95 lines, 15 files
Files
- README.md +5/−5
- examples/eval-routing.hs +5/−4
- src/Network/Wai/Routing/Predicate/Accept.hs +6/−1
- src/Network/Wai/Routing/Predicate/Capture.hs +12/−2
- src/Network/Wai/Routing/Predicate/Content.hs +6/−1
- src/Network/Wai/Routing/Predicate/Cookie.hs +12/−2
- src/Network/Wai/Routing/Predicate/Header.hs +12/−2
- src/Network/Wai/Routing/Predicate/Param.hs +14/−4
- src/Network/Wai/Routing/Predicate/Predicate.hs +87/−3
- src/Network/Wai/Routing/Predicate/Query.hs +12/−2
- src/Network/Wai/Routing/Route.hs +49/−32
- src/Network/Wai/Routing/Tutorial.hs +6/−6
- test/Tests/Wai/Predicate.hs +13/−13
- test/Tests/Wai/Route.hs +33/−17
- wai-routing.cabal +1/−1
README.md view
@@ -25,18 +25,18 @@ import Network.Wai.Handler.Warp main :: IO ()-main = run 8080 (route start)+main = run 8080 (route (prepare start)) -start :: Monad m => Routes m ()+start :: Monad m => Routes a m () start = do get "/user/:name" fetchUser $- Capture "name"+ capture "name" get "/user/find" findUser $- Query "byName" :||: Query "byId"+ query "byName" :||: query "byId" delete "/user/:name" rmUser $- Capture "name" :&: Opt (Cookie "foo")+ capture "name" :&: opt (cookie "foo") fetchUser :: Monad m => Text -> m Response fetchUser name = ...
examples/eval-routing.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-} -- Like "direct.hs" but makes use of wai-routing. @@ -27,10 +28,10 @@ _ -> fail $ "Invalid operation: " ++ show c main :: IO ()-main = run 8080 $ logStdout (route start)+main = run 8080 $ logStdout (route (prepare start)) -start :: Monad m => Routes m ()-start = get "eval" eval (Query "x" :&: Query "y" :&: Query "f")+start :: Monad m => Routes a m ()+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/Predicate/Accept.hs view
@@ -8,7 +8,8 @@ {-# LANGUAGE TypeFamilies #-} module Network.Wai.Routing.Predicate.Accept- ( Accept (..)+ ( Accept+ , accept , module Network.Wai.Routing.MediaType ) where @@ -28,6 +29,10 @@ -- | 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)
src/Network/Wai/Routing/Predicate/Capture.hs view
@@ -19,8 +19,10 @@ -- extracts from a request path whatever is given for @:name@ -- and @:street@. module Network.Wai.Routing.Predicate.Capture- ( Capture (..)- , HasCapture (..)+ ( Capture+ , HasCapture+ , capture+ , hasCapture ) where import Data.ByteString (ByteString)@@ -34,6 +36,10 @@ 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@@ -42,6 +48,10 @@ 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
src/Network/Wai/Routing/Predicate/Content.hs view
@@ -8,7 +8,8 @@ {-# LANGUAGE TypeFamilies #-} module Network.Wai.Routing.Predicate.Content- ( ContentType (..)+ ( ContentType+ , contentType , module Network.Wai.Routing.MediaType ) where @@ -28,6 +29,10 @@ -- | 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)
src/Network/Wai/Routing/Predicate/Cookie.hs view
@@ -7,8 +7,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Wai.Routing.Predicate.Cookie- ( Cookie (..)- , HasCookie (..)+ ( Cookie+ , HasCookie+ , cookie+ , hasCookie ) where import Data.ByteString (ByteString)@@ -22,6 +24,10 @@ 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@@ -29,6 +35,10 @@ 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
src/Network/Wai/Routing/Predicate/Header.hs view
@@ -7,8 +7,10 @@ {-# LANGUAGE TypeFamilies #-} module Network.Wai.Routing.Predicate.Header- ( Hdr (..)- , HasHdr (..)+ ( Hdr+ , HasHdr+ , hdr+ , hasHdr ) where import Data.ByteString (ByteString)@@ -25,6 +27,10 @@ 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@@ -33,6 +39,10 @@ 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
src/Network/Wai/Routing/Predicate/Param.hs view
@@ -6,8 +6,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Wai.Routing.Predicate.Param- ( Param (..)- , HasParam (..)+ ( Param+ , HasParam+ , param+ , hasParam ) where import Data.ByteString (ByteString)@@ -21,15 +23,23 @@ -- | @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)+ 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)+ apply (HasParam x) = apply (hasQuery x :|: hasCapture x)
src/Network/Wai/Routing/Predicate/Predicate.hs view
@@ -8,8 +8,34 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Network.Wai.Routing.Predicate.Predicate where+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)@@ -53,14 +79,23 @@ 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@@ -125,11 +160,15 @@ and (T _ _) (F f) = F f and (F f) _ = F f --- | An 'Predicate' modifier which makes the underlying predicate optional,+-- | 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)@@ -137,16 +176,61 @@ T d x -> T d (Just x) F _ -> T 0 Nothing --- | An 'Predicate' modifier which returns as 'TVal' the provided default+-- | 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'.
src/Network/Wai/Routing/Predicate/Query.hs view
@@ -7,8 +7,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Wai.Routing.Predicate.Query- ( Query (..)- , HasQuery (..)+ ( Query+ , HasQuery+ , query+ , hasQuery ) where import Data.ByteString (ByteString)@@ -22,6 +24,10 @@ 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@@ -30,6 +36,10 @@ 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
src/Network/Wai/Routing/Route.hs view
@@ -2,7 +2,6 @@ -- 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 BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}@@ -12,7 +11,7 @@ ( Routes , Renderer , route- , expand+ , prepare , renderer , addRoute , get@@ -23,6 +22,8 @@ , trace , options , connect+ , attach+ , examine ) where import Control.Applicative hiding (Const)@@ -33,7 +34,7 @@ import Data.Either import Data.Function import Data.List hiding (head, delete)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Network.HTTP.Types import Network.Wai (Request, Response, responseLBS, responseBuilder, rawPathInfo)@@ -46,9 +47,10 @@ import qualified Data.List as L import qualified Network.Wai.Route.Tree as Tree -data Route m = Route+data Route a m = Route { _method :: !Method , _path :: !ByteString+ , _meta :: Maybe a , _pred :: Pack m } @@ -69,28 +71,31 @@ -- | Set a custom render function, i.e. a function to turn 'Error's into -- 'Lazy.ByteString's.-renderer :: Renderer -> Routes m ()-renderer f = Routes . modify $ \(St !rr _) -> St rr f+renderer :: Renderer -> Routes m a ()+renderer f = Routes . modify $ \s -> s { renderfn = f } -- | The Routes monad state type.-data St m = St [Route m] Renderer+data St a m = St+ { routes :: [Route a m]+ , renderfn :: Renderer+ } -- | Initial state.-zero :: St m+zero :: St a m zero = St [] (fmap Lazy.fromStrict . message) -- | The Routes monad is used to add routing declarations -- via 'addRoute' or one of 'get', 'post', etc.-newtype Routes m a = Routes { _unroutes :: State (St m) a }+newtype Routes a m b = Routes { _unroutes :: State (St a m) b } -instance Functor (Routes m) where+instance Functor (Routes a m) where fmap = liftM -instance Applicative (Routes m) where+instance Applicative (Routes a m) where pure = return (<*>) = ap -instance Monad (Routes m) where+instance Monad (Routes a m) where return = Routes . return m >>= f = Routes $ _unroutes m >>= _unroutes . f @@ -101,9 +106,9 @@ -> ByteString -- ^ path -> (TVal p -> m Response) -- ^ handler -> p -- ^ 'Predicate'- -> Routes m ()-addRoute m r x p = Routes . modify $ \(St !rr !f) ->- St (Route m r (Pack p x) : rr) f+ -> Routes a 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 ::@@ -111,7 +116,7 @@ => ByteString -- ^ path -> (TVal p -> m Response) -- ^ handler -> p -- ^ 'Predicate'- -> Routes m ()+ -> Routes a m () get = addRoute (renderStdMethod GET) head = addRoute (renderStdMethod HEAD) post = addRoute (renderStdMethod POST)@@ -121,11 +126,23 @@ options = addRoute (renderStdMethod OPTIONS) connect = addRoute (renderStdMethod CONNECT) +-- | Add some metadata to the last route.+attach :: a -> Routes a m ()+attach a = Routes $ modify addToLast+ where+ addToLast s@(St [] _) = s+ addToLast (St (r:rr) f) = St (r { _meta = Just a } : rr) f++-- | Get back all attached metadata.+examine :: Routes a m b -> [a]+examine (Routes r) = let St rr _ = execState r zero in+ mapMaybe _meta rr+ -- | A WAI 'Application' (generalised from 'IO' to 'Monad') which -- routes requests to handlers based on predicated route declarations.-route :: Monad m => Routes m a -> Request -> m Response+route :: Monad m => [(ByteString, Req -> m Response)] -> Request -> m Response route rm rq = do- let tr = Tree.fromList $ expand rm+ let tr = Tree.fromList rm case Tree.lookup tr (Tree.segments $ rawPathInfo rq) of Just (f, v) -> f (fromWaiRequest v rq) Nothing -> return notFound@@ -133,26 +150,26 @@ notFound = responseLBS status404 [] "" -- | Run the 'Routes' monad and return the handlers per path.-expand :: Monad m => Routes m a -> [(ByteString, Req -> m Response)]-expand (Routes routes) =- let St rr f = execState routes zero in- map (\g -> (_path (L.head g), select f g)) (normalise rr)+prepare :: Monad m => Routes a m b -> [(ByteString, Req -> m Response)]+prepare (Routes rr) =+ let s = execState rr zero in+ map (\g -> (_path (L.head g), select (renderfn s) g)) (normalise (routes s)) -- | Group routes by path.-normalise :: [Route m] -> [[Route m]]+normalise :: [Route a m] -> [[Route a 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 :: [Route a m] -> [Route a m] sorted = sortBy (compare `on` _path) - grouped :: [Route m] -> [[Route m]]+ grouped :: [Route a m] -> [[Route a m]] grouped = groupBy ((==) `on` _path) - namelessPath :: Route m -> ByteString+ namelessPath :: Route a m -> ByteString namelessPath = let fun s = if s /= "" && C.head s == ':' then "<>" else s in C.intercalate "/" . map fun . C.split '/' . _path@@ -167,9 +184,9 @@ -- (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 m] -> Req -> m Response-select render routes req = do- let ms = filter ((method req ==) . _method) routes+select :: Monad m => Renderer -> [Route a m] -> Req -> m Response+select render rr req = do+ let ms = filter ((method req ==) . _method) rr if null ms then return $ respond render (Error status405 Nothing) [(allow, validMethods)] else evalAll ms@@ -178,16 +195,16 @@ allow = mk "Allow" validMethods :: ByteString- validMethods = C.intercalate "," $ nub (C.pack . show . _method <$> routes)+ validMethods = C.intercalate "," $ nub (C.pack . show . _method <$> rr) - evalAll :: Monad m => [Route m] -> m Response+ evalAll :: Monad m => [Route a m] -> m Response evalAll rs = let (n, y) = partitionEithers $ foldl' evalSingle [] rs in if null y then return $ respond render (L.head n) [] else closest y - evalSingle :: Monad m => [Either Error (Handler m)] -> Route m -> [Either Error (Handler m)]+ 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
src/Network/Wai/Routing/Tutorial.hs view
@@ -132,7 +132,7 @@ @ someHandler :: Application someHandler r =- case apply (Accept :&: Query \"baz\") (fromWaiRequest [] r) of+ case apply (accept :&: query \"baz\") (fromWaiRequest [] r) of T ((_ :: Media \"text\" \"plain\") ::: bazValue) -> ... F (Just (Error st msg)) -> ... F Nothing -> ...@@ -149,11 +149,11 @@ @ 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 $ Fail (Error 410 (Just \"Gone.\"))- post \"\/d\" handlerD $ Accept- post \"\/e\" handlerE $ Accept+ 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:
test/Tests/Wai/Predicate.hs view
@@ -26,51 +26,51 @@ testAcceptJson :: IO () testAcceptJson = do let rq0 = fromWaiRequest [] . json $ request "/"- (T 0 $ Media "application" "json" 1.0 []) @=? (apply (Accept :: Accept "application" "json") rq0)+ 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)+ 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)+ 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)+ 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+ 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)+ 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)+ 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)+ 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)+ 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)+ 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)+ 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)+ T 0 Nothing @=? apply (opt (query "x" :: Query ByteString)) rq1
test/Tests/Wai/Route.hs view
@@ -25,12 +25,12 @@ testSitemap :: IO () testSitemap = do- let routes = expand sitemap- assertEqual "Endpoints"- ["/a", "/b", "/c", "/d", "/e", "/f", "/g", "/h"]- (map fst routes)+ let routes = prepare sitemap - let handler = route sitemap+ [7,6,5,4,3,2,1,0] @=? examine sitemap+ ["/a", "/b", "/c", "/d", "/e", "/f", "/g", "/h"] @=? map fst routes++ let handler = route routes testEndpointA handler testEndpointB handler testEndpointC handler@@ -39,31 +39,47 @@ testEndpointF handler testEndpointH handler -sitemap :: Routes IO ()+sitemap :: Routes Int IO () sitemap = do get "/a" handlerA $- Accept :&: (Query "name" :|: Query "nick") :&: Query "foo"+ accept :&: (query "name" :|: query "nick") :&: query "foo" + attach 0+ get "/b" handlerB $- Query "baz"+ query "baz" + attach 1+ get "/c" handlerC $- Opt (Query "foo")+ opt (query "foo") + attach 2+ get "/d" handlerD $- Def 0 (Query "foo")+ def 0 (query "foo") + attach 3+ get "/e" handlerE $- Def 0 (Hdr "foo")+ def 0 (hdr "foo") + attach 4+ get "/f" handlerF $- Query "foo"+ query "foo" + attach 5+ get "/g" handlerG true + attach 6+ get "/h" handlerH $- Cookie "user" :&: Cookie "age"+ cookie "user" :&: cookie "age" + attach 7+ handlerA :: Media "application" "json" ::: Int ::: ByteString -> IO Response handlerA (_ ::: i ::: _) = writeText (fromString . show $ i) @@ -203,14 +219,14 @@ testMedia :: IO () testMedia = do- let [(_, h)] = expand sitemapMedia+ let [(_, h)] = prepare 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 IO ()+sitemapMedia :: Routes a IO () sitemapMedia = do- get "/media" handlerJson Accept- get "/media" handlerThrift Accept+ get "/media" handlerJson accept+ get "/media" handlerThrift accept handlerJson :: Media "application" "json" -> IO Response handlerJson _ = writeText "application/json"
wai-routing.cabal view
@@ -1,5 +1,5 @@ name: wai-routing-version: 0.1+version: 0.2 synopsis: Declarative routing for WAI. license: OtherLicense license-file: LICENSE