Merge branch 'master' into existential-error

.gitignore

@@ -1,8 +1,8 @@
-dist
+/dist
-bin
+/bin
-lib
+/lib
-share
+/share
-packages
+/packages
 *-packages.conf.d
 cabal-dev
 add-source-timestamps

scripts/bump-versions.sh

@@ -0,0 +1,61 @@
+#!/bin/bash -
+#===============================================================================
+#
+#          FILE: bump-versions.sh
+#
+#         USAGE: ./bump-versions.sh
+#
+#   DESCRIPTION: Bump the versions for all servant packages
+#
+#       OPTIONS: See usage
+#  REQUIREMENTS: bumper, bash >= 4
+#       CREATED: 11.05.2015 21:36
+#      REVISION:  ---
+#===============================================================================
+
+set -o nounset
+set -o errexit
+
+. lib/common.sh
+
+usage () {
+    echo " bump-versions.sh <POSITION> [-d|--dry-run]"
+    echo "             | [-h|--help]"
+    echo "    Bumps the specified positional version of all servant packages."
+    echo "    POSITION is a number between 0 and 3, inclusive."
+    exit 0
+}
+
+if [ $# -eq 0 ] ; then
+    echo "expecting one or more arguments. Got 0"
+    usage
+elif [ $# -gt 2 ] ; then
+    echo "expecting one or more arguments"
+    usage
+fi
+
+versions_equal
+
+while [ "${1:-unset}" != "unset" ] ; do
+    case "$1" in
+        -h | --help) usage ;;
+        -d | --dry-run) DRY_RUN=true
+           shift ;;
+        0) if POSITION="none" ; then POSITION=0 ; else usage ; fi
+           shift ;;
+        1) if POSITION="none" ; then POSITION=1 ; else usage ; fi
+           shift ;;
+        2) if POSITION="none" ; then POSITION=2 ; else usage ; fi
+           shift ;;
+        3) if POSITION="none" ; then POSITION=3 ; else usage ; fi
+           shift ;;
+        *) usage ;;
+   esac
+done
+
+if $DRY_RUN ; then
+   bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}")
+else
+   bumper -"$POSITION" $(join , "${SOURCES[@]}")
+fi
+

scripts/lib/common.sh

@@ -0,0 +1,31 @@
+#!/bin/bash -
+#===============================================================================
+#
+#          FILE: lib/common.sh
+#
+#   DESCRIPTION: Common functions for servant's shell scripts
+#                Meant to be sourced rather than run.
+#
+#  REQUIREMENTS: bash >= 4
+#===============================================================================
+
+
+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))
+DRY_RUN=false
+POSITION="none"
+SOURCES_TXT="$( dirname $DIR)/sources.txt"
+CABAL=${CABAL:-cabal}
+
+declare -a SOURCES
+readarray -t SOURCES < "$SOURCES_TXT"
+
+join () { local IFS="$1"; shift; echo "$*"; }
+
+versions_equal () {
+    local NUM=$(find . -name 'servant*.cabal' | xargs grep "^version:" | awk '{ print $2 }' | uniq -c | wc -l)
+    if [ 1 -eq $NUM ] ; then
+        return 0
+    else
+        echo "versions of packages are not all the same!" && exit 1
+    fi
+}

scripts/start-sandbox.sh

@@ -14,11 +14,7 @@ set -o nounset
 set -o errexit
 
 DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
-SOURCES_TXT="$( dirname $DIR)/sources.txt"
+. "$DIR"/lib/common.sh
-CABAL=${CABAL:-cabal}
-
-declare -a SOURCES
-readarray -t SOURCES < "$SOURCES_TXT"
 
 prepare_sandbox () {
     $CABAL sandbox init

scripts/test-all.sh

@@ -15,13 +15,9 @@ set -o nounset
 set -o errexit
 
 DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
+. "$DIR"/lib/common.sh
+
 GHC_FLAGS="-Werror"
-SOURCES_TXT="$( dirname $DIR)/sources.txt"
-CABAL=${CABAL:-cabal}
-
-declare -a SOURCES
-readarray -t SOURCES < "$SOURCES_TXT"
-
 
 prepare_sandbox () {
     $CABAL sandbox init

scripts/update-defaults-nix.sh

@@ -12,11 +12,7 @@ set -o nounset
 set -o errexit
 
 DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
-BASE_DIR="$( dirname $DIR)"
+. "$DIR"/lib/common.sh
-SOURCES_TXT="$BASE_DIR/sources.txt"
-
-declare -a SOURCES
-readarray -t SOURCES < "$SOURCES_TXT"
 
 for s in ${SOURCES[@]} ; do
     echo $s

scripts/upload.sh

@@ -0,0 +1,52 @@
+#!/bin/bash -
+#===============================================================================
+#
+#          FILE: upload.sh
+#
+#         USAGE: ./upload.sh <USER> <PASSWORD>
+#
+#   DESCRIPTION: Uploads all servant packages to Hackage
+#
+#  REQUIREMENTS: cabal, bash >= 4
+#        AUTHOR: Julian K. Arni
+#       CREATED: 05.06.2015 13:05
+#===============================================================================
+
+set -o nounset
+set -o errexit
+
+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
+. "$DIR"/lib/common.sh
+
+usage () {
+    echo " upload.sh <USER> <PASSWORD>"
+    echo "    Uploads all servant packages to Hackage"
+    exit 0
+}
+
+
+upload_package () {
+    local package="$1"
+    local user="$2"
+    local pass="$3"
+    local cabalFile="$package.cabal"
+    pushd "$package"
+    local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }')
+    local sdist="dist/${package}-${version}.tar.gz"
+    cabal sdist
+    echo "User is: $user"
+    cabal upload --user="$user" --password="$pass" "$sdist"
+    popd
+}
+
+
+if [ $# -ne 2 ] ; then
+    echo "expecting two arguments."
+    usage
+fi
+
+versions_equal
+
+for s in ${SOURCES[@]} ; do
+    upload_package "$s" "$1" "$2"
+done

servant-blaze/servant-blaze.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                servant-blaze
-version:             0.4.0.0
+version:             0.4.1
 synopsis:            Blaze-html support for servant
 -- description:
 homepage:            http://haskell-servant.github.io/

servant-blaze/src/Servant/HTML/Blaze.hs

@@ -25,7 +25,7 @@ import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 
 data HTML deriving Typeable
 
--- | @text/plain;charset=utf-8@
+-- | @text/html;charset=utf-8@
 instance Accept HTML where
     contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
 

servant-client/CHANGELOG.md

@@ -1,3 +1,7 @@
+0.4.1
+-----
+* The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided.
+
 0.4
 ---
 * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant-client/servant-client.cabal

@@ -1,5 +1,5 @@
 name:                servant-client
-version:             0.4.0
+version:             0.4.1
 synopsis: automatical derivation of querying functions for servant webservices
 description:
   This library lets you derive automatically Haskell functions that
@@ -56,6 +56,9 @@ test-suite spec
   default-language: Haskell2010
   hs-source-dirs: test
   main-is: Spec.hs
+  other-modules:
+      Servant.ClientSpec
+    , Servant.Common.BaseUrlSpec
   build-depends:
       base == 4.*
     , aeson

servant-client/src/Servant/Client.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
 #if !MIN_VERSION_base(4,8,0)
 {-# LANGUAGE OverlappingInstances #-}
 #endif
@@ -126,8 +127,9 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLE #-}
 #endif
-  (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where
+  -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
-  type Client (Delete (ct ': cts) a) = EitherT ServantError IO a
+  (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
+  type Client (Delete cts' a) = EitherT ServantError IO a
   clientWithRoute Proxy req baseurl =
     snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
 
@@ -137,8 +139,8 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-  HasClient (Delete (ct ': cts) ()) where
+  HasClient (Delete cts ()) where
-  type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()
+  type Client (Delete cts ()) = EitherT ServantError IO ()
   clientWithRoute Proxy req baseurl =
     void $ performRequestNoBody H.methodDelete req [204] baseurl
 
@@ -148,9 +150,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-  ( MimeUnrender ct a, BuildHeadersTo ls
+  -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
-  ) => HasClient (Delete (ct ': cts) (Headers ls a)) where
+  ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
-  type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
+  ) => HasClient (Delete cts' (Headers ls a)) where
+  type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl = do
     (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
     return $ Headers { getResponse = resp

servant-client/src/Servant/Common/BaseUrl.hs

@@ -1,8 +1,19 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE ViewPatterns       #-}
-module Servant.Common.BaseUrl where
+module Servant.Common.BaseUrl (
+  -- * types
+    BaseUrl (..)
+  , InvalidBaseUrlException
+  , Scheme (..)
+  -- * functions
+  , parseBaseUrl
+  , showBaseUrl
+) where
 
+import Control.Monad.Catch (MonadThrow, throwM, Exception)
 import Data.List
+import Data.Typeable
 import GHC.Generics
 import Network.URI
 import Safe
@@ -34,20 +45,23 @@ showBaseUrl (BaseUrl urlscheme host port) =
         (Https, 443) -> ""
         _ -> ":" ++ show port
 
-parseBaseUrl :: String -> Either String BaseUrl
+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
+instance Exception InvalidBaseUrlException
+
+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
 parseBaseUrl s = case parseURI (removeTrailingSlash s) of
   -- This is a rather hacky implementation and should be replaced with something
   -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
   Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
-    Right (BaseUrl Http host port)
+    return (BaseUrl Http host port)
   Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
-    Right (BaseUrl Http host 80)
+    return (BaseUrl Http host 80)
   Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
-    Right (BaseUrl Https host port)
+    return (BaseUrl Https host port)
   Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
-    Right (BaseUrl Https host 443)
+    return (BaseUrl Https host 443)
   _ -> if "://" `isInfixOf` s
-    then Left ("invalid base url: " ++ s)
+    then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
     else parseBaseUrl ("http://" ++ s)
  where
   removeTrailingSlash str = case lastMay str of

servant-client/src/Servant/Common/Req.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,6 +19,7 @@ import Data.String.Conversions
 import Data.Proxy
 import Data.Text (Text)
 import Data.Text.Encoding
+import Data.Typeable
 import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Client.TLS
 import Network.HTTP.Media
@@ -53,7 +55,9 @@ data ServantError
   | ConnectionError
     { connectionError           :: String
     }
-  deriving (Show)
+  deriving (Show, Typeable)
+
+instance Exception ServantError
 
 data Req = Req
   { reqPath   :: String

servant-client/test/Servant/ClientSpec.hs

@@ -80,7 +80,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
 type Api =
        "get" :> Get '[JSON] Person
-  :<|> "delete" :> Delete '[JSON] ()
+  :<|> "deleteEmpty" :> Delete '[] ()
   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
   :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@@ -98,6 +98,7 @@ type Api =
             ReqBody '[JSON] [(String, [Rational])] :>
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
+  :<|> "deleteContentType" :> Delete '[JSON] ()
 api :: Proxy Api
 api = Proxy
 
@@ -123,6 +124,7 @@ server = serve api (
   :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
   :<|> (\ a b c d -> return (a, b, c, d))
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
+  :<|> return ()
  )
 
 withServer :: (BaseUrl -> IO a) -> IO a
@@ -148,7 +150,7 @@ withFailServer action = withWaiDaemon (return failServer) action
 spec :: IO ()
 spec = withServer $ \ baseUrl -> do
   let getGet :: EitherT ServantError IO Person
-      getDelete :: EitherT ServantError IO ()
+      getDeleteEmpty :: EitherT ServantError IO ()
       getCapture :: String -> EitherT ServantError IO Person
       getBody :: Person -> EitherT ServantError IO Person
       getQueryParam :: Maybe String -> EitherT ServantError IO Person
@@ -161,8 +163,9 @@ spec = withServer $ \ baseUrl -> do
       getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
       getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
       getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)
+      getDeleteContentType :: EitherT ServantError IO ()
       (     getGet
-       :<|> getDelete
+       :<|> getDeleteEmpty
        :<|> getCapture
        :<|> getBody
        :<|> getQueryParam
@@ -174,15 +177,20 @@ spec = withServer $ \ baseUrl -> do
        :<|> getRawSuccess
        :<|> getRawFailure
        :<|> getMultiple
-       :<|> getRespHeaders)
+       :<|> getRespHeaders
+       :<|> getDeleteContentType)
          = client api baseUrl
 
   hspec $ do
     it "Servant.API.Get" $ do
       (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice
 
-    it "Servant.API.Delete" $ do
+    describe "Servant.API.Delete" $ do
-      (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()
+      it "allows empty content type" $ do
+        (Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right ()
+
+      it "allows content type" $ do
+        (Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right ()
 
     it "Servant.API.Capture" $ do
       (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
@@ -274,11 +282,11 @@ spec = withServer $ \ baseUrl -> do
 failSpec :: IO ()
 failSpec = withFailServer $ \ baseUrl -> do
   let getGet :: EitherT ServantError IO Person
-      getDelete :: EitherT ServantError IO ()
+      getDeleteEmpty :: EitherT ServantError IO ()
       getCapture :: String -> EitherT ServantError IO Person
       getBody :: Person -> EitherT ServantError IO Person
       (     getGet
-       :<|> getDelete
+       :<|> getDeleteEmpty
        :<|> getCapture
        :<|> getBody
        :<|> _ )
@@ -289,7 +297,7 @@ failSpec = withFailServer $ \ baseUrl -> do
   hspec $ do
     context "client returns errors appropriately" $ do
       it "reports FailureResponse" $ do
-        Left res <- runEitherT getDelete
+        Left res <- runEitherT getDeleteEmpty
         case res of
           FailureResponse (Status 404 "Not Found") _ _ -> return ()
           _ -> fail $ "expected 404 response, but got " <> show res

servant-docs/servant-docs.cabal

@@ -1,5 +1,5 @@
 name:                servant-docs
-version:             0.4.0
+version:             0.4.1
 synopsis:            generate API docs for your servant webservice
 description:
   Library for generating API docs from a servant API definition.

servant-examples/auth-combinator/auth-combinator.hs

@@ -28,14 +28,15 @@ data AuthProtected
 instance HasServer rest => HasServer (AuthProtected :> rest) where
   type ServerT (AuthProtected :> rest) m = ServerT rest m
 
-  route Proxy a request respond =
+  route Proxy a = WithRequest $ \ request ->
+    route (Proxy :: Proxy rest) $ do
       case lookup "Cookie" (requestHeaders request) of
-      Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header."
+        Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
         Just v  -> do
           authGranted <- isGoodCookie v
           if authGranted
-          then route (Proxy :: Proxy rest) a request respond
+            then a
-          else respond . succeedWith $ responseLBS status403 [] "Invalid cookie."
+            else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
 
 type PrivateAPI = Get '[JSON] [PrivateData]
 

servant-examples/servant-examples.cabal

@@ -1,5 +1,5 @@
 name:                servant-examples
-version:             0.4
+version:             0.4.1
 synopsis:            Example programs for servant
 description:         Example programs for servant,
                      showcasing solutions to common needs.
@@ -26,11 +26,11 @@ executable tutorial
     , js-jquery
     , lucid
     , random
-    , servant
+    , servant == 0.4.*
-    , servant-docs
+    , servant-docs == 0.4.*
-    , servant-jquery
+    , servant-jquery == 0.4.*
-    , servant-lucid
+    , servant-lucid == 0.4.*
-    , servant-server
+    , servant-server == 0.4.*
     , text
     , time
     , transformers
@@ -47,9 +47,9 @@ executable t8-main
       aeson
     , base >= 4.7 && < 5
     , either
-    , servant
+    , servant == 0.4.*
-    , servant-client
+    , servant-client == 0.4.*
-    , servant-server
+    , servant-server == 0.4.*
     , wai
 
 executable hackage
@@ -70,8 +70,8 @@ executable wai-middleware
   build-depends:
       aeson >= 0.8
     , base >= 4.7 && < 5
-    , servant
+    , servant == 0.4.*
-    , servant-server
+    , servant-server == 0.4.*
     , text
     , wai
     , wai-extra
@@ -86,7 +86,7 @@ executable auth-combinator
     , base >= 4.7 && < 5
     , bytestring
     , http-types
-    , servant
+    , servant == 0.4.*
     , servant-server == 0.4.*
     , text
     , wai

servant-jquery/servant-jquery.cabal

@@ -1,5 +1,5 @@
 name:                servant-jquery
-version:             0.4.0
+version:             0.4.1
 synopsis:            Automatically derive (jquery) javascript functions to query servant webservices
 description:
   Automatically derive jquery-based javascript functions to query servant webservices.

servant-lucid/servant-lucid.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                servant-lucid
-version:             0.4.0.0
+version:             0.4.1
 synopsis:            Servant support for lucid
 -- description:
 homepage:            http://haskell-servant.github.io/

servant-lucid/src/Servant/HTML/Lucid.hs

@@ -24,7 +24,7 @@ import           Servant.API        (Accept (..), MimeRender (..))
 
 data HTML deriving Typeable
 
--- | @text/plain;charset=utf-8@
+-- | @text/html;charset=utf-8@
 instance Accept HTML where
     contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
 

servant-server/CHANGELOG.md

@@ -1,3 +1,9 @@
+0.4.1
+-----
+* Bump attoparsec upper bound to < 0.14
+* Bump wai-app-static upper bound to < 3.2
+* Bump either upper bound to < 4.5
+
 0.4
 ---
 * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant-server/example/greet.hs

@@ -44,7 +44,7 @@ testApi = Proxy
 -- There's one handler per endpoint, which, just like in the type
 -- that represents the API, are glued together using :<|>.
 --
--- Each handler runs in the 'EitherT (Int, String) IO' monad.
+-- Each handler runs in the 'EitherT ServantErr IO' monad.
 server :: Server TestApi
 server = helloH :<|> postGreetH :<|> deleteGreetH
 

servant-server/servant-server.cabal

@@ -1,5 +1,5 @@
 name:                servant-server
-version:             0.4.0
+version:             0.4.1
 synopsis:            A family of combinators for defining webservices APIs and serving them
 description:
   A family of combinators for defining webservices APIs and serving them
@@ -35,15 +35,19 @@ library
     Servant
     Servant.Server
     Servant.Server.Internal
-    Servant.Server.Internal.ServantErr
     Servant.Server.Internal.Enter
+    Servant.Server.Internal.PathInfo
+    Servant.Server.Internal.Router
+    Servant.Server.Internal.RoutingApplication
+    Servant.Server.Internal.ServantErr
     Servant.Utils.StaticFiles
   build-depends:
         base               >= 4.7  && < 5
-      , aeson              >= 0.7  && < 0.9
+      , aeson              >= 0.7  && < 0.10
-      , attoparsec         >= 0.12 && < 0.13
+      , attoparsec         >= 0.12 && < 0.14
       , bytestring         >= 0.10 && < 0.11
-      , either             >= 4.3  && < 4.4
+      , containers         >= 0.5  && < 0.6
+      , either             >= 4.3  && < 4.5
       , http-types         >= 0.8  && < 0.9
       , network-uri        >= 2.6  && < 2.7
       , mtl                >= 2    && < 3
@@ -51,7 +55,7 @@ library
       , safe               >= 0.3  && < 0.4
       , servant            == 0.4.*
       , split              >= 0.2  && < 0.3
-      , string-conversions >= 0.3  && < 0.4
+      , string-conversions >= 0.3  && < 0.5
       , system-filepath    >= 0.4  && < 0.5
       , filepath           >= 1
       , text               >= 1.2  && < 1.3

servant-server/src/Servant/Server.hs

@@ -81,7 +81,6 @@ import           Data.Proxy                         (Proxy)
 import           Network.Wai                        (Application)
 import           Servant.Server.Internal
 import           Servant.Server.Internal.Enter
-import           Servant.Server.Internal.ServantErr
 
 
 -- * Implementing Servers
@@ -108,7 +107,7 @@ import           Servant.Server.Internal.ServantErr
 -- > main = Network.Wai.Handler.Warp.run 8080 app
 --
 serve :: HasServer layout => Proxy layout -> Server layout -> Application
-serve p server = toApplication (route p server)
+serve p server = toApplication (runRouter (route p (return (RR (Right server)))))
 
 
 -- Documentation

servant-server/src/Servant/Server/Internal.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -11,17 +12,20 @@
 {-# LANGUAGE OverlappingInstances #-}
 #endif
 
-module Servant.Server.Internal where
+module Servant.Server.Internal
+  ( module Servant.Server.Internal
+  , module Servant.Server.Internal.PathInfo
+  , module Servant.Server.Internal.Router
+  , module Servant.Server.Internal.RoutingApplication
+  , module Servant.Server.Internal.ServantErr
+  ) where
 
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative         ((<$>))
-import           Data.Monoid                 (Monoid, mappend, mempty)
 #endif
-import           Control.Monad.Trans.Either  (EitherT, runEitherT)
+import           Control.Monad.Trans.Either  (EitherT)
 import qualified Data.ByteString             as B
-import qualified Data.ByteString.Lazy        as BL
+import qualified Data.Map                    as M
-import           Data.IORef                  (newIORef, readIORef, writeIORef)
-import           Data.List                   (unfoldr)
 import           Data.Maybe                  (catMaybes, fromMaybe)
 import           Data.String                 (fromString)
 import           Data.String.Conversions     (cs, (<>))
@@ -31,12 +35,9 @@ import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
 import           Data.Typeable
 import           GHC.TypeLits                (KnownSymbol, symbolVal)
 import           Network.HTTP.Types          hiding (Header, ResponseHeaders)
-import           Network.Wai                 (Application, Request, Response,
+import           Network.Wai                 (Application, lazyRequestBody,
-                                              ResponseReceived, lazyRequestBody,
+                                              rawQueryString, requestHeaders,
-                                              pathInfo, rawQueryString,
+                                              requestMethod, responseLBS)
-                                              requestBody, requestHeaders,
-                                              requestMethod, responseLBS,
-                                              strictRequestBody)
 import           Servant.API                 ((:<|>) (..), (:>), Capture,
                                                Delete, Get, Header,
                                               MatrixFlag, MatrixParam, MatrixParams,
@@ -50,136 +51,15 @@ import           Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
                                               getHeaders)
 import           Servant.Common.Text         (FromText, fromText)
 
+import           Servant.Server.Internal.PathInfo
+import           Servant.Server.Internal.Router
+import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
 
-data ReqBodyState = Uncalled
-                  | Called !B.ByteString
-                  | Done !B.ByteString
-
-
-toApplication :: RoutingApplication -> Application
-toApplication ra request respond = do
-  reqBodyRef <- newIORef Uncalled
-  -- We may need to consume the requestBody more than once.  In order to
-  -- maintain the illusion that 'requestBody' works as expected,
-  -- 'ReqBodyState' is introduced, and the complete body is memoized and
-  -- returned as many times as requested with empty "Done" marker chunks in
-  -- between.
-  -- See https://github.com/haskell-servant/servant/issues/3
-  let memoReqBody = do
-          ior <- readIORef reqBodyRef
-          case ior of
-            Uncalled -> do
-                r <- BL.toStrict <$> strictRequestBody request
-                writeIORef reqBodyRef $ Done r
-                return r
-            Called bs -> do
-                writeIORef reqBodyRef $ Done bs
-                return bs
-            Done bs -> do
-                writeIORef reqBodyRef $ Called bs
-                return B.empty
-
-  ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
- where
-  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
-  routingRespond (Left NotFound) =
-    respond $ responseLBS notFound404 [] "not found"
-  routingRespond (Left WrongMethod) =
-    respond $ responseLBS methodNotAllowed405 [] "method not allowed"
-  routingRespond (Left (InvalidBody err)) =
-    respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
-  routingRespond (Left UnsupportedMediaType) =
-    respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
-  routingRespond (Left (HttpError status body)) =
-    respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
-  routingRespond (Right response) =
-    respond response
-
--- Note that the ordering of the constructors has great significance! It
--- determines the Ord instance and, consequently, the monoid instance.
--- * Route mismatch
-data RouteMismatch =
-    NotFound           -- ^ the usual "not found" error
-  | WrongMethod        -- ^ a more informative "you just got the HTTP method wrong" error
-  | UnsupportedMediaType -- ^ request body has unsupported media type
-  | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
-  | HttpError Status (Maybe BL.ByteString)  -- ^ an even even more informative arbitrary HTTP response code error.
-  deriving (Eq, Ord, Show)
-
-instance Monoid RouteMismatch where
-  mempty = NotFound
-  -- The following isn't great, since it picks @InvalidBody@ based on
-  -- alphabetical ordering, but any choice would be arbitrary.
-  --
-  -- "As one judge said to the other, 'Be just and if you can't be just, be
-  -- arbitrary'" -- William Burroughs
-  mappend = max
-
-
--- | A wrapper around @'Either' 'RouteMismatch' a@.
-newtype RouteResult a =
-  RR { routeResult :: Either RouteMismatch a }
-  deriving (Eq, Show)
-
-failWith :: RouteMismatch -> RouteResult a
-failWith = RR . Left
-
-succeedWith :: a -> RouteResult a
-succeedWith = RR . Right
-
-isMismatch :: RouteResult a -> Bool
-isMismatch (RR (Left _)) = True
-isMismatch _             = False
-
--- | Like `null . pathInfo`, but works with redundant trailing slashes.
-pathIsEmpty :: Request -> Bool
-pathIsEmpty = f . processedPathInfo
-  where
-    f []   = True
-    f [""] = True
-    f _    = False
-
--- | If we get a `Right`, it has precedence over everything else.
---
--- This in particular means that if we could get several 'Right's,
--- only the first we encounter would be taken into account.
-instance Monoid (RouteResult a) where
-  mempty = RR $ Left mempty
-
-  RR (Left x)  `mappend` RR (Left y)  = RR $ Left (x <> y)
-  RR (Left _)  `mappend` RR (Right y) = RR $ Right y
-  r            `mappend` _            = r
-
-type RoutingApplication =
-     Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-  -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
-
-splitMatrixParameters :: Text -> (Text, Text)
-splitMatrixParameters = T.break (== ';')
-
-parsePathInfo :: Request -> [Text]
-parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
-  where mergePairs = concat . unfoldr pairToList
-        pairToList []          = Nothing
-        pairToList ((a, b):xs) = Just ([a, b], xs)
-
--- | Returns a processed pathInfo from the request.
---
--- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
--- processed, so routing works as intended. Therefor this function should be used to access
--- the pathInfo for routing purposes.
-processedPathInfo :: Request -> [Text]
-processedPathInfo r =
-  case pinfo of
-    (x:xs) | T.head x == ';' -> xs
-    _                        -> pinfo
-  where pinfo = parsePathInfo r
-
 class HasServer layout where
   type ServerT layout (m :: * -> *) :: *
 
-  route :: Proxy layout -> Server layout -> RoutingApplication
+  route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
 
 type Server layout = ServerT layout (EitherT ServantErr IO)
 
@@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
 
   type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
 
-  route Proxy (a :<|> b) request respond =
+  route Proxy server = choice (route pa (extractL <$> server))
-    route pa a request $ \mResponse ->
+                              (route pb (extractR <$> server))
-      if isMismatch mResponse
-        then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
-        else respond mResponse
-
     where pa = Proxy :: Proxy a
           pb = Proxy :: Proxy b
 
@@ -227,7 +103,7 @@ captured _ = fromText
 -- >
 -- > server :: Server MyApi
 -- > server = getBook
--- >   where getBook :: Text -> EitherT (Int, String) IO Book
+-- >   where getBook :: Text -> EitherT ServantErr IO Book
 -- >         getBook isbn = ...
 instance (KnownSymbol capture, FromText a, HasServer sublayout)
       => HasServer (Capture capture a :> sublayout) where
@@ -235,25 +111,72 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
   type ServerT (Capture capture a :> sublayout) m =
      a -> ServerT sublayout m
 
-  route Proxy subserver request respond = case processedPathInfo request of
+  route Proxy subserver =
-    (first : rest)
+    DynamicRouter $ \ first ->
-      -> case captured captureProxy first of
+      route (Proxy :: Proxy sublayout)
-           Nothing  -> respond $ failWith NotFound
+            (case captured captureProxy first of
-           Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
+               Nothing  -> return $ failWith NotFound
-                         pathInfo = rest
+               Just v   -> feedTo subserver v)
-                       } respond
-    _ -> respond $ failWith NotFound
-
     where captureProxy = Proxy :: Proxy (Capture capture a)
 
 
+methodRouter :: (AllCTRender ctypes a)
+             => Method -> Proxy ctypes -> Status
+             -> IO (RouteResult (EitherT ServantErr IO a))
+             -> Router
+methodRouter method proxy status action = LeafRouter route'
+  where
+    route' request respond
+      | pathIsEmpty request && requestMethod request == method = do
+          runAction action respond $ \ output -> do
+            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
+            case handleAcceptH proxy (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS status [ ("Content-Type" , cs contentT)] body
+      | pathIsEmpty request && requestMethod request /= method =
+          respond $ failWith WrongMethod
+      | otherwise = respond $ failWith NotFound
+
+methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
+                    => Method -> Proxy ctypes -> Status
+                    -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
+                    -> Router
+methodRouterHeaders method proxy status action = LeafRouter route'
+  where
+    route' request respond
+      | pathIsEmpty request && requestMethod request == method = do
+        runAction action respond $ \ output -> do
+          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status ( ("Content-Type" , cs contentT) : headers) body
+      | pathIsEmpty request && requestMethod request /= method =
+          respond $ failWith WrongMethod
+      | otherwise = respond $ failWith NotFound
+
+methodRouterEmpty :: Method
+                  -> IO (RouteResult (EitherT ServantErr IO ()))
+                  -> Router
+methodRouterEmpty method action = LeafRouter route'
+  where
+    route' request respond
+      | pathIsEmpty request && requestMethod request == method = do
+          runAction action respond $ \ () ->
+            succeedWith $ responseLBS noContent204 [] ""
+      | pathIsEmpty request && requestMethod request /= method =
+          respond $ failWith WrongMethod
+      | otherwise = respond $ failWith NotFound
+
 -- | If you have a 'Delete' endpoint in your API,
 -- the handler for this endpoint is meant to delete
 -- a resource.
 --
 -- The code of the handler will, just like
 -- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
--- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
+-- 'Servant.API.Put.Put', run in @EitherT ServantErr IO ()@.
 -- The 'Int' represents the status code and the 'String' a message
 -- to be returned. You can use 'Control.Monad.Trans.Either.left' to
 -- painlessly error out if the conditions for a successful deletion
@@ -267,20 +190,7 @@ instance
 
   type ServerT (Delete ctypes a) m = m a
 
-  route Proxy action request respond
+  route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodDelete = do
-        e <- runEitherT action
-        respond $ case e of
-          Right output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> succeedWith $
-                responseLBS status200 [ ("Content-Type" , cs contentT)] body
-          Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodDelete =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 instance
 #if MIN_VERSION_base(4,8,0)
@@ -290,15 +200,7 @@ instance
 
   type ServerT (Delete ctypes ()) m = m ()
 
-  route Proxy action request respond
+  route Proxy = methodRouterEmpty methodDelete
-    | pathIsEmpty request && requestMethod request == methodDelete = do
-        e <- runEitherT action
-        respond . succeedWith $ case e of
-          Right () -> responseLBS noContent204 [] ""
-          Left err -> responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodDelete =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- Add response headers
 instance
@@ -310,26 +212,12 @@ instance
 
   type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
 
-  route Proxy action request respond
+  route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodDelete = do
-      e <- runEitherT action
-      respond $ case e of
-        Right output -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders output
-          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
-            Nothing -> failWith UnsupportedMediaType
-            Just (contentT, body) -> succeedWith $
-              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
-        Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodDelete =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- | When implementing the handler for a 'Get' endpoint,
 -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
 -- and 'Servant.API.Put.Put', the handler code runs in the
--- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
 -- the status code and the 'String' a message, returned in case of
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- to quickly fail if some conditions are not met.
@@ -347,20 +235,7 @@ instance
 
   type ServerT (Get ctypes a) m = m a
 
-  route Proxy action request respond
+  route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodGet = do
-        e <- runEitherT action
-        respond $ case e of
-          Right output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> succeedWith $
-                responseLBS ok200 [ ("Content-Type" , cs contentT)] body
-          Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodGet =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- '()' ==> 204 No Content
 instance
@@ -371,15 +246,7 @@ instance
 
   type ServerT (Get ctypes ()) m = m ()
 
-  route Proxy action request respond
+  route Proxy = methodRouterEmpty methodGet
-    | pathIsEmpty request && requestMethod request == methodGet = do
-        e <- runEitherT action
-        respond . succeedWith $ case e of
-          Right () -> responseLBS noContent204 [] ""
-          Left err -> responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodGet =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- Add response headers
 instance
@@ -391,21 +258,7 @@ instance
 
   type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
 
-  route Proxy action request respond
+  route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodGet = do
-      e <- runEitherT action
-      respond $ case e of
-        Right output -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders output
-          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
-            Nothing -> failWith UnsupportedMediaType
-            Just (contentT, body) -> succeedWith $
-              responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
-        Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodGet =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- | If you use 'Header' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
@@ -425,7 +278,7 @@ instance
 -- >
 -- > server :: Server MyApi
 -- > server = viewReferer
--- >   where viewReferer :: Referer -> EitherT (Int, String) IO referer
+-- >   where viewReferer :: Referer -> EitherT ServantErr IO referer
 -- >         viewReferer referer = return referer
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (Header sym a :> sublayout) where
@@ -433,16 +286,15 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type ServerT (Header sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
 
-  route Proxy subserver request respond = do
+  route Proxy subserver = WithRequest $ \ request ->
     let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
-    route (Proxy :: Proxy sublayout) (subserver mheader) request respond
+    in  route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
-
     where str = fromString $ symbolVal (Proxy :: Proxy sym)
 
 -- | When implementing the handler for a 'Post' endpoint,
 -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
 -- and 'Servant.API.Put.Put', the handler code runs in the
--- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
 -- the status code and the 'String' a message, returned in case of
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- to quickly fail if some conditions are not met.
@@ -461,20 +313,7 @@ instance
 
   type ServerT (Post ctypes a) m = m a
 
-  route Proxy action request respond
+  route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
-    | pathIsEmpty request && requestMethod request == methodPost = do
-        e <- runEitherT action
-        respond $ case e of
-          Right output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> succeedWith $
-                responseLBS status201 [ ("Content-Type" , cs contentT)] body
-          Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPost =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 instance
 #if MIN_VERSION_base(4,8,0)
@@ -484,15 +323,7 @@ instance
 
   type ServerT (Post ctypes ()) m = m ()
 
-  route Proxy action request respond
+  route Proxy = methodRouterEmpty methodPost
-    | pathIsEmpty request && requestMethod request == methodPost = do
-        e <- runEitherT action
-        respond . succeedWith $ case e of
-          Right () -> responseLBS noContent204 [] ""
-          Left err -> responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPost =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- Add response headers
 instance
@@ -504,26 +335,12 @@ instance
 
   type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
 
-  route Proxy action request respond
+  route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-    | pathIsEmpty request && requestMethod request == methodPost = do
-      e <- runEitherT action
-      respond $ case e of
-        Right output -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders output
-          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
-            Nothing -> failWith UnsupportedMediaType
-            Just (contentT, body) -> succeedWith $
-              responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
-        Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPost =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- | When implementing the handler for a 'Put' endpoint,
 -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
 -- and 'Servant.API.Post.Post', the handler code runs in the
--- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
 -- the status code and the 'String' a message, returned in case of
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- to quickly fail if some conditions are not met.
@@ -541,20 +358,7 @@ instance
 
   type ServerT (Put ctypes a) m = m a
 
-  route Proxy action request respond
+  route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodPut = do
-        e <- runEitherT action
-        respond $ case e of
-          Right output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> succeedWith $
-                responseLBS status200 [ ("Content-Type" , cs contentT)] body
-          Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPut =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 instance
 #if MIN_VERSION_base(4,8,0)
@@ -564,15 +368,7 @@ instance
 
   type ServerT (Put ctypes ()) m = m ()
 
-  route Proxy action request respond
+  route Proxy = methodRouterEmpty methodPut
-    | pathIsEmpty request && requestMethod request == methodPut = do
-        e <- runEitherT action
-        respond . succeedWith $ case e of
-          Right () -> responseLBS noContent204 [] ""
-          Left err -> responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPut =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- Add response headers
 instance
@@ -584,26 +380,12 @@ instance
 
   type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
 
-  route Proxy action request respond
+  route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodPut = do
-      e <- runEitherT action
-      respond $ case e of
-        Right output -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders output
-          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
-            Nothing -> failWith UnsupportedMediaType
-            Just (contentT, body) -> succeedWith $
-              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
-        Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPut =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- | When implementing the handler for a 'Patch' endpoint,
 -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
 -- and 'Servant.API.Put.Put', the handler code runs in the
--- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- @EitherT ServantErr IO@ monad, where the 'Int' represents
 -- the status code and the 'String' a message, returned in case of
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- to quickly fail if some conditions are not met.
@@ -619,20 +401,7 @@ instance
 
   type ServerT (Patch ctypes a) m = m a
 
-  route Proxy action request respond
+  route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodPatch = do
-        e <- runEitherT action
-        respond $ case e of
-          Right output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> succeedWith $
-                responseLBS status200 [ ("Content-Type" , cs contentT)] body
-          Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPatch =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 instance
 #if MIN_VERSION_base(4,8,0)
@@ -642,15 +411,7 @@ instance
 
   type ServerT (Patch ctypes ()) m = m ()
 
-  route Proxy action request respond
+  route Proxy = methodRouterEmpty methodPatch
-    | pathIsEmpty request && requestMethod request == methodPatch = do
-        e <- runEitherT action
-        respond . succeedWith $ case e of
-          Right () -> responseLBS noContent204 [] ""
-          Left err -> responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPatch =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- Add response headers
 instance
@@ -662,21 +423,7 @@ instance
 
   type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
 
-  route Proxy action request respond
+  route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-    | pathIsEmpty request && requestMethod request == methodPatch = do
-      e <- runEitherT action
-      respond $ case e of
-        Right outpatch -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders outpatch
-          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
-            Nothing -> failWith UnsupportedMediaType
-            Just (contentT, body) -> succeedWith $
-              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
-        Left err -> succeedWith $ responseServantErr err
-    | pathIsEmpty request && requestMethod request /= methodPatch =
-        respond $ failWith WrongMethod
-    | otherwise = respond $ failWith NotFound
 
 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
@@ -696,7 +443,7 @@ instance
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
--- >   where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
+-- >   where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
 -- >         getBooksBy Nothing       = ...return all books...
 -- >         getBooksBy (Just author) = ...return books by the given author...
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
@@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type ServerT (QueryParam sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
 
-  route Proxy subserver request respond = do
+  route Proxy subserver = WithRequest $ \ request ->
     let querytext = parseQueryText $ rawQueryString request
         param =
           case lookup paramname querytext of
@@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
             Just Nothing  -> Nothing -- param present with no value -> Nothing
             Just (Just v) -> fromText v -- if present, we try to convert to
                                         -- the right type
-
+    in route (Proxy :: Proxy sublayout) (feedTo subserver param)
-    route (Proxy :: Proxy sublayout) (subserver param) request respond
-
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -735,7 +480,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
--- >   where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
+-- >   where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
 -- >         getBooksBy authors = ...return all books by these authors...
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (QueryParams sym a :> sublayout) where
@@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type ServerT (QueryParams sym a :> sublayout) m =
     [a] -> ServerT sublayout m
 
-  route Proxy subserver request respond = do
+  route Proxy subserver = WithRequest $ \ request ->
     let querytext = parseQueryText $ rawQueryString request
         -- if sym is "foo", we look for query string parameters
         -- named "foo" or "foo[]" and call fromText on the
         -- corresponding values
         parameters = filter looksLikeParam querytext
         values = catMaybes $ map (convert . snd) parameters
-
+    in  route (Proxy :: Proxy sublayout) (feedTo subserver values)
-    route (Proxy :: Proxy sublayout) (subserver values) request respond
-
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
           convert Nothing = Nothing
@@ -768,7 +511,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 -- >
 -- > server :: Server MyApi
 -- > server = getBooks
--- >   where getBooks :: Bool -> EitherT (Int, String) IO [Book]
+-- >   where getBooks :: Bool -> EitherT ServantErr IO [Book]
 -- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (QueryFlag sym :> sublayout) where
@@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)
   type ServerT (QueryFlag sym :> sublayout) m =
     Bool -> ServerT sublayout m
 
-  route Proxy subserver request respond = do
+  route Proxy subserver = WithRequest $ \ request ->
     let querytext = parseQueryText $ rawQueryString request
         param = case lookup paramname querytext of
           Just Nothing  -> True  -- param is there, with no value
           Just (Just v) -> examine v -- param with a value
           Nothing       -> False -- param not in the query string
-
+    in  route (Proxy :: Proxy sublayout) (feedTo subserver param)
-    route (Proxy :: Proxy sublayout) (subserver param) request respond
-
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False
@@ -810,7 +551,7 @@ parseMatrixText = parseQueryText
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
--- >   where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
+-- >   where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
 -- >         getBooksBy Nothing       = ...return all books...
 -- >         getBooksBy (Just author) = ...return books by the given author...
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
@@ -819,7 +560,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type ServerT (MatrixParam sym a :> sublayout) m =
     Maybe a -> ServerT sublayout m
 
-  route Proxy subserver request respond = case parsePathInfo request of
+  route Proxy subserver = WithRequest $ \ request ->
+    case parsePathInfo request of
       (first : _)
         -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
                   param = case lookup paramname querytext of
@@ -827,8 +569,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
                     Just Nothing  -> Nothing -- param present with no value -> Nothing
                     Just (Just v) -> fromText v -- if present, we try to convert to
                                           -- the right type
-            route (Proxy :: Proxy sublayout) (subserver param) request respond
+              route (Proxy :: Proxy sublayout) (feedTo subserver param)
-    _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
+      _   -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)
 
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
@@ -849,7 +591,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
--- >   where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
+-- >   where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
 -- >         getBooksBy authors = ...return all books by these authors...
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (MatrixParams sym a :> sublayout) where
@@ -857,7 +599,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type ServerT (MatrixParams sym a :> sublayout) m =
     [a] -> ServerT sublayout m
 
-  route Proxy subserver request respond = case parsePathInfo request of
+  route Proxy subserver = WithRequest $ \ request ->
+    case parsePathInfo request of
       (first : _)
         -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
                   -- if sym is "foo", we look for matrix parameters
@@ -865,8 +608,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
                   -- corresponding values
                   parameters = filter looksLikeParam matrixtext
                   values = catMaybes $ map (convert . snd) parameters
-            route (Proxy :: Proxy sublayout) (subserver values) request respond
+              route (Proxy :: Proxy sublayout) (feedTo subserver values)
-    _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
+      _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
 
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@@ -883,7 +626,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 -- >
 -- > server :: Server MyApi
 -- > server = getBooks
--- >   where getBooks :: Bool -> EitherT (Int, String) IO [Book]
+-- >   where getBooks :: Bool -> EitherT ServantErr IO [Book]
 -- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (MatrixFlag sym :> sublayout) where
@@ -891,7 +634,8 @@ instance (KnownSymbol sym, HasServer sublayout)
   type ServerT (MatrixFlag sym :> sublayout) m =
     Bool -> ServerT sublayout m
 
-  route Proxy subserver request respond =  case parsePathInfo request of
+  route Proxy subserver = WithRequest $ \ request ->
+    case parsePathInfo request of
       (first : _)
         -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
                   param = case lookup paramname matrixtext of
@@ -899,9 +643,9 @@ instance (KnownSymbol sym, HasServer sublayout)
                     Just (Just v) -> examine v -- param with a value
                     Nothing       -> False -- param not in the query string
   
-            route (Proxy :: Proxy sublayout) (subserver param) request respond
+              route (Proxy :: Proxy sublayout) (feedTo subserver param)
   
-    _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
+      _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
 
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
@@ -919,8 +663,11 @@ instance HasServer Raw where
 
   type ServerT Raw m = Application
 
-  route Proxy rawApplication request respond =
+  route Proxy rawApplication = LeafRouter $ \ request respond -> do
-    rawApplication request (respond . succeedWith)
+    r <- rawApplication
+    case r of
+      RR (Left err)  -> respond $ failWith err
+      RR (Right app) -> app request (respond . succeedWith)
 
 -- | If you use 'ReqBody' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
@@ -940,7 +687,7 @@ instance HasServer Raw where
 -- >
 -- > server :: Server MyApi
 -- > server = postBook
--- >   where postBook :: Book -> EitherT (Int, String) IO Book
+-- >   where postBook :: Book -> EitherT ServantErr IO Book
 -- >         postBook book = ...insert into your db...
 instance ( AllCTUnrender list a, HasServer sublayout
          ) => HasServer (ReqBody list a :> sublayout) where
@@ -948,7 +695,8 @@ instance ( AllCTUnrender list a, HasServer sublayout
   type ServerT (ReqBody list a :> sublayout) m =
     a -> ServerT sublayout m
 
-  route Proxy subserver request respond = do
+  route Proxy subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy sublayout) $ do
       -- See HTTP RFC 2616, section 7.2.1
       -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
       -- See also "W3C Internet Media Type registration, consistency of use"
@@ -958,9 +706,9 @@ instance ( AllCTUnrender list a, HasServer sublayout
       mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
              <$> lazyRequestBody request
       case mrqbody of
-      Nothing -> respond . failWith $ UnsupportedMediaType
+        Nothing -> return $ failWith $ UnsupportedMediaType
-      Just (Left e) -> respond . failWith $ InvalidBody e
+        Just (Left e) -> return $ failWith $ InvalidBody e
-      Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
+        Just (Right v) -> feedTo subserver v
 
 -- | Make sure the incoming request starts with @"/path"@, strip it and
 -- pass the rest of the request path to @sublayout@.
@@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
 
   type ServerT (path :> sublayout) m = ServerT sublayout m
 
-  route Proxy subserver request respond = case processedPathInfo request of
+  route Proxy subserver = StaticRouter $
-    (first : rest)
+    M.singleton (cs (symbolVal proxyPath))
-      | first == cs (symbolVal proxyPath)
+                (route (Proxy :: Proxy sublayout) subserver)
-      -> route (Proxy :: Proxy sublayout) subserver request{
-           pathInfo = rest
-         } respond
-    _ -> respond $ failWith NotFound
-
     where proxyPath = Proxy :: Proxy path
 
 ct_wildcard :: B.ByteString

servant-server/src/Servant/Server/Internal/PathInfo.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings    #-}
+module Servant.Server.Internal.PathInfo where
+
+import           Data.List                   (unfoldr)
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Network.Wai                 (Request, pathInfo)
+
+-- | Like `null . pathInfo`, but works with redundant trailing slashes.
+pathIsEmpty :: Request -> Bool
+pathIsEmpty = f . processedPathInfo
+  where
+    f []   = True
+    f [""] = True
+    f _    = False
+
+
+splitMatrixParameters :: Text -> (Text, Text)
+splitMatrixParameters = T.break (== ';')
+
+parsePathInfo :: Request -> [Text]
+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
+  where mergePairs = concat . unfoldr pairToList
+        pairToList []          = Nothing
+        pairToList ((a, b):xs) = Just ([a, b], xs)
+
+-- | Returns a processed pathInfo from the request.
+--
+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
+-- processed, so routing works as intended. Therefor this function should be used to access
+-- the pathInfo for routing purposes.
+processedPathInfo :: Request -> [Text]
+processedPathInfo r =
+  case pinfo of
+    (x:xs) | T.head x == ';' -> xs
+    _                        -> pinfo
+  where pinfo = parsePathInfo r
+

servant-server/src/Servant/Server/Internal/Router.hs

@@ -0,0 +1,72 @@
+module Servant.Server.Internal.Router where
+
+import           Data.Map                    (Map)
+import qualified Data.Map                    as M
+import           Data.Monoid                 ((<>))
+import           Data.Text                   (Text)
+import           Network.Wai                 (Request, pathInfo)
+import           Servant.Server.Internal.PathInfo
+import           Servant.Server.Internal.RoutingApplication
+
+-- | Internal representation of a router.
+data Router =
+    WithRequest   (Request -> Router)
+      -- ^ current request is passed to the router
+  | StaticRouter  (Map Text Router)
+      -- ^ first path component used for lookup and removed afterwards
+  | DynamicRouter (Text -> Router)
+      -- ^ first path component used for lookup and removed afterwards
+  | LeafRouter    RoutingApplication
+      -- ^ to be used for routes that match an empty path
+  | Choice        Router Router
+      -- ^ left-biased choice between two routers
+
+-- | Smart constructor for the choice between routers.
+-- We currently optimize the following cases:
+--
+--   * Two static routers can be joined by joining their maps.
+--   * Two dynamic routers can be joined by joining their codomains.
+--   * Two 'WithRequest' routers can be joined by passing them
+--     the same request and joining their codomains.
+--   * A 'WithRequest' router can be joined with anything else by
+--     passing the same request to both but ignoring it in the
+--     component that does not need it.
+--
+choice :: Router -> Router -> Router
+choice (StaticRouter table1) (StaticRouter table2) =
+  StaticRouter (M.unionWith choice table1 table2)
+choice (DynamicRouter fun1)  (DynamicRouter fun2)  =
+  DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
+choice (WithRequest router1) (WithRequest router2) =
+  WithRequest (\ request -> choice (router1 request) (router2 request))
+choice (WithRequest router1) router2 =
+  WithRequest (\ request -> choice (router1 request) router2)
+choice router1 (WithRequest router2) =
+  WithRequest (\ request -> choice router1 (router2 request))
+choice router1 router2 = Choice router1 router2
+
+-- | Interpret a router as an application.
+runRouter :: Router -> RoutingApplication
+runRouter (WithRequest router) request respond =
+  runRouter (router request) request respond
+runRouter (StaticRouter table) request respond =
+  case processedPathInfo request of
+    first : rest
+      | Just router <- M.lookup first table
+      -> let request' = request { pathInfo = rest }
+         in  runRouter router request' respond
+    _ -> respond $ failWith NotFound
+runRouter (DynamicRouter fun)  request respond =
+  case processedPathInfo request of
+    first : rest
+      -> let request' = request { pathInfo = rest }
+         in  runRouter (fun first) request' respond
+    _ -> respond $ failWith NotFound
+runRouter (LeafRouter app)     request respond = app request respond
+runRouter (Choice r1 r2)       request respond =
+  runRouter r1 request $ \ mResponse1 ->
+    if isMismatch mResponse1
+      then runRouter r2 request $ \ mResponse2 ->
+             respond (mResponse1 <> mResponse2)
+      else respond mResponse1
+

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeOperators              #-}
+module Servant.Server.Internal.RoutingApplication where
+
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative         (Applicative, (<$>))
+import           Data.Monoid                 (Monoid, mappend, mempty)
+#endif
+import           Control.Monad.Trans.Either  (EitherT, runEitherT)
+import qualified Data.ByteString             as B
+import qualified Data.ByteString.Lazy        as BL
+import           Data.IORef                  (newIORef, readIORef, writeIORef)
+import           Data.Maybe                  (fromMaybe)
+import           Data.Monoid                 ((<>))
+import           Data.String                 (fromString)
+import           Network.HTTP.Types          hiding (Header, ResponseHeaders)
+import           Network.Wai                 (Application, Request, Response,
+                                              ResponseReceived,
+                                              requestBody,
+                                              responseLBS,
+                                              strictRequestBody)
+import           Servant.API                 ((:<|>) (..))
+import           Servant.Server.Internal.ServantErr
+
+type RoutingApplication =
+     Request -- ^ the request, the field 'pathInfo' may be modified by url routing
+  -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
+
+-- | A wrapper around @'Either' 'RouteMismatch' a@.
+newtype RouteResult a =
+  RR { routeResult :: Either RouteMismatch a }
+  deriving (Eq, Show, Functor, Applicative)
+
+-- | If we get a `Right`, it has precedence over everything else.
+--
+-- This in particular means that if we could get several 'Right's,
+-- only the first we encounter would be taken into account.
+instance Monoid (RouteResult a) where
+  mempty = RR $ Left mempty
+
+  RR (Left x)  `mappend` RR (Left y)  = RR $ Left (x <> y)
+  RR (Left _)  `mappend` RR (Right y) = RR $ Right y
+  r            `mappend` _            = r
+
+-- Note that the ordering of the constructors has great significance! It
+-- determines the Ord instance and, consequently, the monoid instance.
+data RouteMismatch =
+    NotFound           -- ^ the usual "not found" error
+  | WrongMethod        -- ^ a more informative "you just got the HTTP method wrong" error
+  | UnsupportedMediaType -- ^ request body has unsupported media type
+  | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
+  | HttpError Status (Maybe BL.ByteString)  -- ^ an even even more informative arbitrary HTTP response code error.
+  deriving (Eq, Ord, Show)
+
+instance Monoid RouteMismatch where
+  mempty = NotFound
+  -- The following isn't great, since it picks @InvalidBody@ based on
+  -- alphabetical ordering, but any choice would be arbitrary.
+  --
+  -- "As one judge said to the other, 'Be just and if you can't be just, be
+  -- arbitrary'" -- William Burroughs
+  mappend = max
+
+data ReqBodyState = Uncalled
+                  | Called !B.ByteString
+                  | Done !B.ByteString
+
+toApplication :: RoutingApplication -> Application
+toApplication ra request respond = do
+  reqBodyRef <- newIORef Uncalled
+  -- We may need to consume the requestBody more than once.  In order to
+  -- maintain the illusion that 'requestBody' works as expected,
+  -- 'ReqBodyState' is introduced, and the complete body is memoized and
+  -- returned as many times as requested with empty "Done" marker chunks in
+  -- between.
+  -- See https://github.com/haskell-servant/servant/issues/3
+  let memoReqBody = do
+          ior <- readIORef reqBodyRef
+          case ior of
+            Uncalled -> do
+                r <- BL.toStrict <$> strictRequestBody request
+                writeIORef reqBodyRef $ Done r
+                return r
+            Called bs -> do
+                writeIORef reqBodyRef $ Done bs
+                return bs
+            Done bs -> do
+                writeIORef reqBodyRef $ Called bs
+                return B.empty
+
+  ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
+ where
+  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
+  routingRespond (Left NotFound) =
+    respond $ responseLBS notFound404 [] "not found"
+  routingRespond (Left WrongMethod) =
+    respond $ responseLBS methodNotAllowed405 [] "method not allowed"
+  routingRespond (Left (InvalidBody err)) =
+    respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
+  routingRespond (Left UnsupportedMediaType) =
+    respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
+  routingRespond (Left (HttpError status body)) =
+    respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
+  routingRespond (Right response) =
+    respond response
+
+runAction :: IO (RouteResult (EitherT ServantErr IO a))
+          -> (RouteResult Response -> IO r)
+          -> (a -> RouteResult Response)
+          -> IO r
+runAction action respond k = do
+  r <- action
+  go r
+  where
+    go (RR (Right a))  = do
+      e <- runEitherT a
+      respond $ case e of
+        Right x  -> k x
+        Left err -> succeedWith $ responseServantErr err
+    go (RR (Left err)) = respond $ failWith err
+
+feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
+feedTo f x = (($ x) <$>) <$> f
+
+extractL :: RouteResult (a :<|> b) -> RouteResult a
+extractL (RR (Right (a :<|> _))) = RR (Right a)
+extractL (RR (Left err))         = RR (Left err)
+
+extractR :: RouteResult (a :<|> b) -> RouteResult b
+extractR (RR (Right (_ :<|> b))) = RR (Right b)
+extractR (RR (Left err))         = RR (Left err)
+
+failWith :: RouteMismatch -> RouteResult a
+failWith = RR . Left
+
+succeedWith :: a -> RouteResult a
+succeedWith = RR . Right
+
+isMismatch :: RouteResult a -> Bool
+isMismatch (RR (Left _)) = True
+isMismatch _             = False
+

servant-server/test/Servant/ServerSpec.hs

@@ -42,7 +42,8 @@ import           Servant.API                ((:<|>) (..), (:>),
                                              Post, Put, QueryFlag, QueryParam,
                                              QueryParams, Raw, ReqBody)
 import           Servant.Server             (Server, serve, ServantErr(..), err404)
-import           Servant.Server.Internal    (RouteMismatch (..))
+import           Servant.Server.Internal.RoutingApplication
+                                            (RouteMismatch (..))
 
 
 -- * test data types
@@ -89,6 +90,7 @@ spec = do
   headerSpec
   rawSpec
   unionSpec
+  prioErrorsSpec
   errorsSpec
   responseHeadersSpec
 
@@ -572,6 +574,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
         Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
           `shouldRespondWith` 415
 
+type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
+
+prioErrorsApi :: Proxy PrioErrorsApi
+prioErrorsApi = Proxy
+
+-- | Test the relative priority of error responses from the server.
+--
+-- In particular, we check whether matching continues even if a 'ReqBody'
+-- or similar construct is encountered early in a path. We don't want to
+-- see a complaint about the request body unless the path actually matches.
+--
+prioErrorsSpec :: Spec
+prioErrorsSpec = describe "PrioErrors" $ do
+  let server = return . age
+  with (return $ serve prioErrorsApi server) $ do
+    let check (mdescr, method) path (cdescr, ctype, body) resp =
+          it fulldescr $
+            Test.Hspec.Wai.request method path [(hContentType, ctype)] body
+              `shouldRespondWith` resp
+          where
+            fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
+                     ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
+
+        get' = ("GET", methodGet)
+        put' = ("PUT", methodPut)
+
+        txt   = ("text"        , "text/plain;charset=utf8"      , "42"        )
+        ijson = ("invalid json", "application/json;charset=utf8", "invalid"   )
+        vjson = ("valid json"  , "application/json;charset=utf8", encode alice)
+
+    check get' "/"    txt   404
+    check get' "/bar" txt   404
+    check get' "/foo" txt   415
+    check put' "/"    txt   404
+    check put' "/bar" txt   404
+    check put' "/foo" txt   405
+    check get' "/"    ijson 404
+    check get' "/bar" ijson 404
+    check get' "/foo" ijson 400
+    check put' "/"    ijson 404
+    check put' "/bar" ijson 404
+    check put' "/foo" ijson 405
+    check get' "/"    vjson 404
+    check get' "/bar" vjson 404
+    check get' "/foo" vjson 200
+    check put' "/"    vjson 404
+    check put' "/bar" vjson 404
+    check put' "/foo" vjson 405
 
 -- | Test server error functionality.
 errorsSpec :: Spec

servant/CHANGELOG.md

@@ -1,3 +1,12 @@
+0.4.2
+-----
+* Fix missing cases for `Patch` in `safeLink`
+
+0.4.1
+-----
+* Allow whitespace after parsing JSON
+* Stricter matching for `safeLink` for `Capture`
+
 0.4
 ---
 * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant/servant.cabal

@@ -1,5 +1,5 @@
 name:                servant
-version:             0.4.0
+version:             0.4.1
 synopsis:            A family of combinators for defining webservices APIs
 description:
   A family of combinators for defining webservices APIs and serving them
@@ -55,7 +55,7 @@ library
     , http-media >= 0.4 && < 0.7
     , http-types == 0.8.*
     , text >= 1 && < 2
-    , string-conversions >= 0.3 && < 0.4
+    , string-conversions >= 0.3 && < 0.5
     , network-uri >= 2.6
   hs-source-dirs: src
   default-language: Haskell2010

servant/src/Servant/API/Capture.hs

@@ -9,6 +9,7 @@ import           GHC.TypeLits  (Symbol)
 -- | Capture a value from the request path under a certain type @a@.
 --
 -- Example:
+--
 -- >>>            -- GET /books/:isbn
 -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
 data Capture (sym :: Symbol) a

servant/src/Servant/API/ContentTypes.hs

@@ -166,7 +166,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
     handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
       where pctyps = Proxy :: Proxy ctyps
             amrs = allMimeRender pctyps val
-            lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
+            lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
 
 
 --------------------------------------------------------------------------

servant/src/Servant/Utils/Links.hs

@@ -72,8 +72,7 @@
 --
 -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
 -- >>> safeLink api bad_link
--- <BLANKLINE>
+-- ...
--- <interactive>:64:1:
 --     Could not deduce (Or
 --                         (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
 --                         (IsElem'
@@ -123,6 +122,7 @@ import Servant.API.Header ( Header )
 import Servant.API.Get ( Get )
 import Servant.API.Post ( Post )
 import Servant.API.Put ( Put )
+import Servant.API.Patch ( Patch )
 import Servant.API.Delete ( Delete )
 import Servant.API.Sub ( type (:>) )
 import Servant.API.Raw ( Raw )
@@ -168,7 +168,8 @@ type family IsElem endpoint api :: Constraint where
     IsElem (e :> sa) (e :> sb)              = IsElem sa sb
     IsElem sa (Header x :> sb)              = IsElem sa sb
     IsElem sa (ReqBody y x :> sb)           = IsElem sa sb
-    IsElem (e :> sa) (Capture x y :> sb)    = IsElem sa sb
+    IsElem (Capture z y :> sa) (Capture x y :> sb)
+                                            = IsElem sa sb
     IsElem sa (QueryParam x y :> sb)        = IsElem sa sb
     IsElem sa (QueryParams x y :> sb)       = IsElem sa sb
     IsElem sa (QueryFlag x :> sb)           = IsElem sa sb
@@ -178,6 +179,7 @@ type family IsElem endpoint api :: Constraint where
     IsElem (Get ct typ) (Get ct' typ)       = IsSubList ct ct'
     IsElem (Post ct typ) (Post ct' typ)     = IsSubList ct ct'
     IsElem (Put ct typ) (Put ct' typ)       = IsSubList ct ct'
+    IsElem (Patch ct typ) (Patch ct' typ)   = IsSubList ct ct'
     IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
     IsElem e e                              = ()
     IsElem e a                              = IsElem' e a
@@ -352,6 +354,10 @@ instance HasLink (Put y r) where
     type MkLink (Put y r) = URI
     toLink _ = linkURI
 
+instance HasLink (Patch y r) where
+    type MkLink (Patch y r) = URI
+    toLink _ = linkURI
+
 instance HasLink (Delete y r) where
     type MkLink (Delete y r) = URI
     toLink _ = linkURI