packages feed

wai-routing (empty) → 0.1

raw patch · 29 files changed

+2208/−0 lines, 29 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed

Dependencies added: HUnit, QuickCheck, attoparsec, base, blaze-builder, bytestring, bytestring-from, case-insensitive, cookie, http-types, tasty, tasty-hunit, tasty-quickcheck, transformers, wai, wai-route, wai-routing

Files

+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+    means each individual or legal entity that creates, contributes to+    the creation of, or owns Covered Software.++1.2. "Contributor Version"+    means the combination of the Contributions of others (if any) used+    by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+    means Covered Software of a particular Contributor.++1.4. "Covered Software"+    means Source Code Form to which the initial Contributor has attached+    the notice in Exhibit A, the Executable Form of such Source Code+    Form, and Modifications of such Source Code Form, in each case+    including portions thereof.++1.5. "Incompatible With Secondary Licenses"+    means++    (a) that the initial Contributor has attached the notice described+        in Exhibit B to the Covered Software; or++    (b) that the Covered Software was made available under the terms of+        version 1.1 or earlier of the License, but not also under the+        terms of a Secondary License.++1.6. "Executable Form"+    means any form of the work other than Source Code Form.++1.7. "Larger Work"+    means a work that combines Covered Software with other material, in+    a separate file or files, that is not Covered Software.++1.8. "License"+    means this document.++1.9. "Licensable"+    means having the right to grant, to the maximum extent possible,+    whether at the time of the initial grant or subsequently, any and+    all of the rights conveyed by this License.++1.10. "Modifications"+    means any of the following:++    (a) any file in Source Code Form that results from an addition to,+        deletion from, or modification of the contents of Covered+        Software; or++    (b) any new file in Source Code Form that contains any Covered+        Software.++1.11. "Patent Claims" of a Contributor+    means any patent claim(s), including without limitation, method,+    process, and apparatus claims, in any patent Licensable by such+    Contributor that would be infringed, but for the grant of the+    License, by the making, using, selling, offering for sale, having+    made, import, or transfer of either its Contributions or its+    Contributor Version.++1.12. "Secondary License"+    means either the GNU General Public License, Version 2.0, the GNU+    Lesser General Public License, Version 2.1, the GNU Affero General+    Public License, Version 3.0, or any later versions of those+    licenses.++1.13. "Source Code Form"+    means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+    means an individual or a legal entity exercising rights under this+    License. For legal entities, "You" includes any entity that+    controls, is controlled by, or is under common control with You. For+    purposes of this definition, "control" means (a) the power, direct+    or indirect, to cause the direction or management of such entity,+    whether by contract or otherwise, or (b) ownership of more than+    fifty percent (50%) of the outstanding shares or beneficial+    ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+    Licensable by such Contributor to use, reproduce, make available,+    modify, display, perform, distribute, and otherwise exploit its+    Contributions, either on an unmodified basis, with Modifications, or+    as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+    for sale, have made, import, and otherwise transfer either its+    Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+    or++(b) for infringements caused by: (i) Your and any other third party's+    modifications of Covered Software, or (ii) the combination of its+    Contributions with other software (except as part of its Contributor+    Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+    its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+    Form, as described in Section 3.1, and You must inform recipients of+    the Executable Form how they can obtain a copy of such Source Code+    Form by reasonable means in a timely manner, at a charge no more+    than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+    License, or sublicense it under different terms, provided that the+    license for the Executable Form does not attempt to limit or alter+    the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+*                                                                      *+*  6. Disclaimer of Warranty                                           *+*  -------------------------                                           *+*                                                                      *+*  Covered Software is provided under this License on an "as is"       *+*  basis, without warranty of any kind, either expressed, implied, or  *+*  statutory, including, without limitation, warranties that the       *+*  Covered Software is free of defects, merchantable, fit for a        *+*  particular purpose or non-infringing. The entire risk as to the     *+*  quality and performance of the Covered Software is with You.        *+*  Should any Covered Software prove defective in any respect, You     *+*  (not any Contributor) assume the cost of any necessary servicing,   *+*  repair, or correction. This disclaimer of warranty constitutes an   *+*  essential part of this License. No use of any Covered Software is   *+*  authorized under this License except under this disclaimer.         *+*                                                                      *+************************************************************************++************************************************************************+*                                                                      *+*  7. Limitation of Liability                                          *+*  --------------------------                                          *+*                                                                      *+*  Under no circumstances and under no legal theory, whether tort      *+*  (including negligence), contract, or otherwise, shall any           *+*  Contributor, or anyone who distributes Covered Software as          *+*  permitted above, be liable to You for any direct, indirect,         *+*  special, incidental, or consequential damages of any character      *+*  including, without limitation, damages for lost profits, loss of    *+*  goodwill, work stoppage, computer failure or malfunction, or any    *+*  and all other commercial damages or losses, even if such party      *+*  shall have been informed of the possibility of such damages. This   *+*  limitation of liability shall not apply to liability for death or   *+*  personal injury resulting from such party's negligence to the       *+*  extent applicable law prohibits such limitation. Some               *+*  jurisdictions do not allow the exclusion or limitation of           *+*  incidental or consequential damages, so this exclusion and          *+*  limitation may not apply to You.                                    *+*                                                                      *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++  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/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++  This Source Code Form is "Incompatible With Secondary Licenses", as+  defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,51 @@+wai-routing enables the declaration of "routes" which handle+requests to a specific URL.++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 start)++start :: Monad m => Routes 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)  = ...+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/eval-direct.hs view
@@ -0,0 +1,63 @@+-- A contrived WAI application which does not make use of+-- wai-routing, but instead works directly on WAI Request.+-- It exposes a single route "eval" to evaluate a small+-- expression which is passed in as query parameters.+--+-- You need wai-extra whic containes the RequestLogger to+-- compile this example.+--+-- The file "eval-routing.hs" does the same but using wai-routing.++module Main (main) where++import Control.Monad+import Data.Attoparsec.ByteString.Char8+import Data.ByteString (ByteString)+import Data.ByteString.From+import Data.String+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger++import qualified Data.ByteString.Lazy as Lazy++-- The operations we want to support in expressions.+data Op = Add | Sub | Mul | Div++instance FromByteString Op where+    parser = anyChar >>= \c -> case c of+        '+' -> return Add+        '-' -> return Sub+        '*' -> return Mul+        '/' -> return Div+        _   -> fail $ "Invalid operation: " ++ show c++main :: IO ()+main = run 8080 $ logStdout start++start :: Application+start r = case pathInfo r of+    "eval":[] ->+        let x = join $ lookup "x" (queryString r)+            y = join $ lookup "y" (queryString r)+            f = join $ lookup "f" (queryString r)+        in either (respond status400 . fromString)+                  (respond status200 . fromString . show)+                  (eval f x y)+    _ -> respond status404 ""++eval :: Maybe ByteString -> Maybe ByteString -> Maybe ByteString -> Either String Int+eval (Just f) (Just x) (Just y) = do+    x' <- parseOnly parser x+    y' <- parseOnly parser y+    f' <- parseOnly parser f+    case f' of+        Add -> return (x' + y')+        Sub -> return (x' - y')+        Mul -> return (x' * y')+        Div -> return (x' `div` y')+eval _ _ _ = Left "invalid arguments"++respond :: Monad m => Status -> Lazy.ByteString -> m Response+respond s = return . responseLBS s []
+ examples/eval-routing.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TypeOperators #-}++-- Like "direct.hs" but makes use of wai-routing.++module Main (main) where++import Data.Attoparsec.ByteString.Char8+import Data.ByteString.From+import Data.String+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Routing+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger++import qualified Data.ByteString.Lazy as Lazy++-- The operations we want to support in expressions.+data Op = Add | Sub | Mul | Div++instance FromByteString Op where+    parser = anyChar >>= \c -> case c of+        '+' -> return Add+        '-' -> return Sub+        '*' -> return Mul+        '/' -> return Div+        _   -> fail $ "Invalid operation: " ++ show c++main :: IO ()+main = run 8080 $ logStdout (route start)++start :: Monad m => Routes 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 $+    case f of+        Add -> x + y+        Sub -> x - y+        Mul -> x * y+        Div -> x `div` y++respond :: Monad m => Status -> Lazy.ByteString -> m Response+respond s = return . responseLBS s []
+ src/Network/Wai/Routing.hs view
@@ -0,0 +1,15 @@+-- 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+    ( module Network.Wai.Routing.Route+    , module Network.Wai.Routing.Error+    , module Network.Wai.Routing.Predicate+    , module Network.Wai.Routing.Request+    ) where++import Network.Wai.Routing.Route+import Network.Wai.Routing.Error+import Network.Wai.Routing.Predicate+import Network.Wai.Routing.Request
+ src/Network/Wai/Routing/Error.hs view
@@ -0,0 +1,19 @@+-- 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 view
@@ -0,0 +1,37 @@+-- 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 view
@@ -0,0 +1,31 @@+-- 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 view
@@ -0,0 +1,66 @@+-- 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 view
@@ -0,0 +1,22 @@+-- 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
@@ -0,0 +1,24 @@+-- 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.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++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+
+ src/Network/Wai/Routing/Predicate/Accept.hs view
@@ -0,0 +1,63 @@+-- 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 (..)+    , 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++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 view
@@ -0,0 +1,52 @@+-- 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 (..)+    ) 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++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++instance Predicate HasCapture Req where+    type FVal HasCapture   = Error+    type TVal HasCapture   = ()+    apply (HasCapture x) r =+        if null (lookupQuery x r)+            then F (err status400 ("Missing path parameter '" <> x <> "'."))+            else T 0 ()
+ src/Network/Wai/Routing/Predicate/Content.hs view
@@ -0,0 +1,66 @@+-- 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 (..)+    , 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++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 view
@@ -0,0 +1,42 @@+-- 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 (..)+    ) 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++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++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 view
@@ -0,0 +1,44 @@+-- 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 (..)+    ) 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++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++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 view
@@ -0,0 +1,35 @@+-- 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  (..)+    ) 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++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++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 view
@@ -0,0 +1,156 @@+-- 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 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++true :: Const a ()+true = Const ()++-- | 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 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++-- | An '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++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++-- | An 'Predicate' modifier which returns as 'TVal' the provided default+-- value if the underlying predicate fails.+data Def d a = Def d a++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++-- | 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 view
@@ -0,0 +1,40 @@+-- 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 (..)+    ) 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++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++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
@@ -0,0 +1,80 @@+-- 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 #-}++-- | A wrapped WAI 'Request' which holds additional data of interest+-- only to 'Predicate' authors.+module Network.Wai.Routing.Request+    ( Req+    , GetRequest (..)+    , fromWaiRequest+    , waiRequest+    , method+    , headers+    , lookupHeader+    , 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 qualified Network.Wai as Wai++data Req = Req+    { captures :: [(ByteString, ByteString)]+    , request  :: Request+    , cookies  :: Cookies+    }++-- | 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 Predicate (GetRequest a) Req where+    type FVal (GetRequest a) = a+    type TVal (GetRequest a) = Request+    apply GetRequest r       = T 0 (request r)++fromWaiRequest :: [(ByteString, ByteString)] -> Request -> Req+fromWaiRequest ca rq =+    Req ca rq (concatMap parseCookies (getHeaders "Cookie" rq))++waiRequest :: Req -> Request+waiRequest = request++headers :: Req -> RequestHeaders+headers = Wai.requestHeaders . request++method :: Req -> Method+method = Wai.requestMethod . request++lookupHeader :: ByteString -> Req -> [ByteString]+lookupHeader name = getHeaders name . request++lookupCapture :: ByteString -> Req -> [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
@@ -0,0 +1,203 @@+-- 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 BangPatterns      #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleContexts  #-}++module Network.Wai.Routing.Route+    ( Routes+    , Renderer+    , route+    , expand+    , renderer+    , addRoute+    , get+    , Network.Wai.Routing.Route.head+    , post+    , put+    , delete+    , trace+    , options+    , connect+    ) where++import Control.Applicative hiding (Const)+import Control.Monad+import Control.Monad.Trans.State.Strict hiding (get, put)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import Data.Either+import Data.Function+import Data.List hiding (head, delete)+import Data.Maybe (fromMaybe)+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.Routing.Request++import qualified Data.ByteString.Char8  as C+import qualified Data.ByteString.Lazy   as Lazy+import qualified Data.List              as L+import qualified Network.Wai.Route.Tree as Tree++data Route m = Route+    { _method  :: !Method+    , _path    :: !ByteString+    , _pred    :: Pack m+    }++data Handler m = Handler+    { _delta   :: !Delta+    , _handler :: m Response+    }++data Pack m where+    Pack :: (Predicate p Req, FVal p ~ Error)+         => p+         -> (TVal p -> m Response)+         -> Pack m++-- | Function to turn an 'Error' value into a 'Lazy.ByteString'.+-- Clients can provide their own renderer using 'renderer'.+type Renderer = Error -> Maybe Lazy.ByteString++-- | 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++-- | The Routes monad state type.+data St m = St [Route m] Renderer++-- | Initial state.+zero :: St 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 }++instance Functor (Routes m) where+    fmap = liftM++instance Applicative (Routes m) where+    pure  = return+    (<*>) = ap++instance Monad (Routes m) where+    return  = Routes . return+    m >>= f = Routes $ _unroutes m >>= _unroutes . f++-- | 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)+         => Method+         -> 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++-- | 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 m ()+get     = addRoute (renderStdMethod GET)+head    = addRoute (renderStdMethod HEAD)+post    = addRoute (renderStdMethod POST)+put     = addRoute (renderStdMethod PUT)+delete  = addRoute (renderStdMethod DELETE)+trace   = addRoute (renderStdMethod TRACE)+options = addRoute (renderStdMethod OPTIONS)+connect = addRoute (renderStdMethod CONNECT)++-- | 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 rm rq = do+    let tr = Tree.fromList $ expand rm+    case Tree.lookup tr (Tree.segments $ rawPathInfo rq) of+        Just (f, v) -> f (fromWaiRequest v rq)+        Nothing     -> return notFound+  where+    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)++-- | Group routes by path.+normalise :: [Route m] -> [[Route m]]+normalise rr =+    let rg    = grouped . sorted $ rr+        paths = map (namelessPath . L.head) rg+        ambig = paths \\ nub paths+    in if null ambig then rg else error (ambiguityMessage ambig)+  where+    sorted :: [Route m] -> [Route m]+    sorted = sortBy (compare `on` _path)++    grouped :: [Route m] -> [[Route m]]+    grouped = groupBy ((==) `on` _path)++    namelessPath :: Route m -> ByteString+    namelessPath =+        let fun s = if s /= "" && C.head s == ':' then "<>" else s+        in C.intercalate "/" . map fun . C.split '/' . _path++    ambiguityMessage a =+        "Paths differing only in variable names are not supported.\n"  +++        "Problematic paths (with variable positions denoted by <>):\n" +++        show a++-- 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 :: Monad m => Renderer -> [Route m] -> Req -> m Response+select render routes req = do+    let ms = filter ((method req ==) . _method) routes+    if null ms+        then return $ respond render (Error status405 Nothing) [(allow, validMethods)]+        else evalAll ms+  where+    allow :: HeaderName+    allow = mk "Allow"++    validMethods :: ByteString+    validMethods = C.intercalate "," $ nub (C.pack . show . _method <$> routes)++    evalAll :: Monad m => [Route 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 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++    closest :: Monad m => [Handler m] -> m Response+    closest hh = case map _handler . sortBy (compare `on` _delta) $ hh of+        []  -> return $ responseBuilder status404 [] mempty+        h:_ -> h++respond :: Renderer -> Error -> ResponseHeaders -> Response+respond f e h = responseLBS (status e) h (fromMaybe mempty (f e))
+ src/Network/Wai/Routing/Tutorial.hs view
@@ -0,0 +1,176 @@+-- 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 $ Fail (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
@@ -0,0 +1,13 @@+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++main :: IO ()+main = defaultMain $ testGroup "Tests"+    [ Predicate.tests+    , WaiPredicate.tests+    , WaiRoute.tests+    ]
+ test/Tests/Data/Predicate.hs view
@@ -0,0 +1,54 @@+{-# 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 view
@@ -0,0 +1,76 @@+{-# 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
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Tests.Wai.Route (tests) where++import Data.ByteString (ByteString)+import Data.Monoid+import Data.String+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Routing+import Test.HUnit hiding (Test)+import Test.Tasty+import Test.Tasty.HUnit+import Tests.Wai.Util++import qualified Data.ByteString.Lazy as Lazy++tests :: TestTree+tests = testGroup "Network.Wai.Routing"+    [ testCase "Sitemap" testSitemap+    , testCase "Media Selection" testMedia+    ]++testSitemap :: IO ()+testSitemap = do+    let routes  = expand sitemap+    assertEqual "Endpoints"+        ["/a", "/b", "/c", "/d", "/e", "/f", "/g", "/h"]+        (map fst routes)++    let handler = route sitemap+    testEndpointA handler+    testEndpointB handler+    testEndpointC handler+    testEndpointD handler+    testEndpointE handler+    testEndpointF handler+    testEndpointH handler++sitemap :: Routes IO ()+sitemap = do+    get "/a" handlerA $+        Accept :&: (Query "name" :|: Query "nick") :&: Query "foo"++    get "/b" handlerB $+        Query "baz"++    get "/c" handlerC $+        Opt (Query "foo")++    get "/d" handlerD $+        Def 0 (Query "foo")++    get "/e" handlerE $+        Def 0 (Hdr "foo")++    get "/f" handlerF $+        Query "foo"++    get "/g" handlerG true++    get "/h" handlerH $+        Cookie "user" :&: Cookie "age"++handlerA :: Media "application" "json" ::: Int ::: ByteString -> IO Response+handlerA (_ ::: i ::: _) = writeText (fromString . show $ i)++handlerB :: Int -> IO Response+handlerB baz = writeText (fromString . show $ baz)++handlerC :: Maybe Int -> IO Response+handlerC foo = writeText (fromString . show $ foo)++handlerD :: Int -> IO Response+handlerD foo = writeText (fromString . show $ foo)++handlerE :: Int -> IO Response+handlerE foo = writeText (fromString . show $ foo)++handlerF :: [Int] -> IO Response+handlerF foo = writeText (fromString . show . sum $ foo)++handlerG :: () -> IO Response+handlerG = const $ writeText "all good"++handlerH :: Lazy.ByteString ::: Int -> IO Response+handlerH (user ::: age) = writeText $+    "user = " <> user <> ", age = " <> fromString (show age)++testEndpointA :: Application -> Assertion+testEndpointA f = do+    let rq = defaultRequest { rawPathInfo = "/a" }++    rs0 <- f $ withHeader "Accept" "foo/bar" rq+    status406 @=? responseStatus rs0++    rs1 <- f $ json rq+    status400 @=? responseStatus rs1++    rs2 <- f . json . withQuery "name" "x" $ rq+    status400 @=? responseStatus rs2++    rs3 <- f . json . withQuery "name" "123" . withQuery "foo" "\"z\"" $ rq+    status200 @=? responseStatus rs3+++testEndpointB :: Application -> Assertion+testEndpointB f = do+    let rq = defaultRequest { rawPathInfo = "/b" }++    rs0 <- f rq+    status400 @=? responseStatus rs0+    "Missing query 'baz'." @=? responseBody rs0++    rs1 <- f . withQuery "baz" "abc" $ rq+    status400 @=? responseStatus rs1+    "Failed reading: Invalid Int" @=? responseBody rs1++    rs2 <- f . withQuery "baz" "abc" . withQuery "baz" "123" $ rq+    status200 @=? responseStatus rs2+    "123" @=? responseBody rs2+++testEndpointC :: Application -> Assertion+testEndpointC f = do+    let rq = defaultRequest { rawPathInfo = "/c" }++    rs0 <- f rq+    status200 @=? responseStatus rs0+    "Nothing" @=? responseBody rs0++    rs1 <- f . withQuery "foo" "abc" . withQuery "foo" "123" $ rq+    status200  @=? responseStatus rs1+    "Just 123" @=? responseBody rs1++    rs2 <- f . withQuery "foo" "abc" $ rq+    status200 @=? responseStatus rs2+++testEndpointD :: Application -> Assertion+testEndpointD f = do+    let rq = defaultRequest { rawPathInfo = "/d" }++    rs0 <- f rq+    status200 @=? responseStatus rs0+    "0"       @=? responseBody rs0++    rs1 <- f . withQuery "foo" "xxx" . withQuery "foo" "42" $ rq+    status200 @=? responseStatus rs1+    "42"      @=? responseBody rs1++    rs2 <- f . withQuery "foo" "yyy" $ rq+    status200 @=? responseStatus rs2+    "0"       @=? responseBody rs2+++testEndpointE :: Application -> Assertion+testEndpointE f = do+    let rq = defaultRequest { rawPathInfo = "/e" }++    rs0 <- f rq+    status200 @=? responseStatus rs0+    "0"       @=? responseBody rs0++    rs1 <- f $ withHeader "foo" "42" rq+    status200 @=? responseStatus rs1+    "42"      @=? responseBody rs1++    rs2 <- f $ withHeader "foo" "abc" rq+    status200 @=? responseStatus rs2+    "0"       @=? responseBody rs2+++testEndpointF :: Application -> Assertion+testEndpointF f = do+    let rq = defaultRequest { rawPathInfo = "/f" }++    rs0 <- f . withQuery "foo" "1,2,3,4" $ rq+    status200 @=? responseStatus rs0+    "10"      @=? responseBody rs0+++testEndpointH :: Application -> Assertion+testEndpointH f = do+    let rq = defaultRequest { rawPathInfo = "/h" }++    rs0 <- f rq+    status400 @=? responseStatus rs0+    "Missing cookie 'user'." @=? responseBody rs0++    rs1 <- f . withHeader "Cookie" "user=joe" $ rq+    status400 @=? responseStatus rs1+    "Missing cookie 'age'." @=? responseBody rs1++    rs2 <- f . withHeader "Cookie" "user=joe; age=42" $ rq+    status200 @=? responseStatus rs2+    "user = joe, age = 42" @=? responseBody rs2++-----------------------------------------------------------------------------+-- Media Selection Tests++testMedia :: IO ()+testMedia = do+    let [(_, h)] = expand 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 = do+    get "/media" handlerJson   Accept+    get "/media" handlerThrift Accept++handlerJson :: Media "application" "json" -> IO Response+handlerJson _ = writeText "application/json"++handlerThrift :: Media "application" "x-thrift" -> IO Response+handlerThrift _ = writeText "application/x-thrift"++expectMedia :: ByteString -> ByteString -> (Req -> IO Response) -> Assertion+expectMedia h res m = do+    let rq = defaultRequest { rawPathInfo = "/media" }+    rs <- m . fromWaiRequest [] . withHeader "Accept" h $ rq+    Lazy.fromStrict res @=? responseBody rs
+ test/Tests/Wai/Util.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Tests.Wai.Util where++import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Network.Wai+import Network.Wai.Internal+import Network.HTTP.Types++import qualified Data.ByteString.Lazy     as Lazy+import qualified Blaze.ByteString.Builder as Builder++request :: ByteString -> Request+request p = defaultRequest { rawPathInfo = p }++withHeader :: CI ByteString -> ByteString -> Request -> Request+withHeader k v r = r { requestHeaders = (k, v) : requestHeaders r }++withQuery :: ByteString -> ByteString -> Request -> Request+withQuery k v r = r { queryString = (k, Just v) : queryString r }++json :: Request -> Request+json = withHeader "Accept" "application/json"++responseBody :: Response -> Lazy.ByteString+responseBody (ResponseBuilder _ _ b) = Builder.toLazyByteString b+responseBody _                       = ""++writeText :: Lazy.ByteString -> IO Response+writeText = return . responseLBS status200 []
+ wai-routing.cabal view
@@ -0,0 +1,105 @@+name:                wai-routing+version:             0.1+synopsis:            Declarative routing for WAI.+license:             OtherLicense+license-file:        LICENSE+author:              Toralf Wittner+maintainer:          Toralf Wittner <tw@dtex.org>+copyright:           (c) 2014 Toralf Wittner+stability:           experimental+category:            Web+build-type:          Simple+cabal-version:       >= 1.10++extra-source-files:+    README.md+    examples/*.hs++description:+    Enables the declaration of \"routes\" which handle requests to a+    specific URL.+    .+    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@.++source-repository head+    type:             git+    location:         git://github.com/twittner/wai-routing.git++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:+        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.*+      , cookie           == 0.4.*+      , case-insensitive == 1.1.*+      , http-types       == 0.8.*+      , transformers     == 0.3.*+      , wai              == 2.0.*+      , wai-route        == 0.1.*++test-suite wai-routing-tests+    type:             exitcode-stdio-1.0+    default-language: Haskell2010+    hs-source-dirs:   test+    main-is:          TestSuite.hs+    ghc-options:      -Wall -O2 -fwarn-tabs+    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.*+      , bytestring+      , case-insensitive+      , http-types+      , HUnit                >= 1.2+      , QuickCheck           >= 2.3+      , tasty                >= 0.3+      , tasty-hunit          >= 0.2+      , tasty-quickcheck     >= 0.3+      , wai+      , wai-routing