eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge branch 'master' into existential-error

Browse source
This commit is contained in:
Christian Marie 2015-06-12 19:56:49 +10:00
commit ad16c4f768
35 changed files with 757 additions and 516 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

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

61
scripts/bump-versions.sh Executable file
View file

@ -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

31
scripts/lib/common.sh Normal file
View file

@ -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
}

6
scripts/start-sandbox.sh
View file

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

8
scripts/test-all.sh
View file

@ -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

6
scripts/update-defaults-nix.sh
View file

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

52
scripts/upload.sh Executable file
View file

@ -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

2
servant-blaze/servant-blaze.cabal
View file

@ -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/

2
servant-blaze/src/Servant/HTML/Blaze.hs
View file

@ -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")

4
servant-client/CHANGELOG.md
View file

@ -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

5
servant-client/servant-client.cabal
View file

@ -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

17
servant-client/src/Servant/Client.hs
View file

@ -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
type Client (Delete (ct ': cts) a) = EitherT ServantError IO a
-- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
(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
type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()
HasClient (Delete cts ()) where
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
) => HasClient (Delete (ct ': cts) (Headers ls a)) where
type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
-- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
) => 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

32
servant-client/src/Servant/Common/BaseUrl.hs
View file

@ -1,8 +1,19 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
module Servant.Common.BaseUrl where
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
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

6
servant-client/src/Servant/Common/Req.hs
View file

@ -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

26
servant-client/test/Servant/ClientSpec.hs
View file

@ -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
(Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()
describe "Servant.API.Delete" $ do
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

2
servant-docs/servant-docs.cabal
View file

@ -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.

17
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -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 =
case lookup "Cookie" (requestHeaders request) of
Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header."
Just v -> do
authGranted <- isGoodCookie v
if authGranted
then route (Proxy :: Proxy rest) a request respond
else respond . succeedWith $ responseLBS status403 [] "Invalid cookie."
route Proxy a = WithRequest $ \ request ->
route (Proxy :: Proxy rest) $ do
case lookup "Cookie" (requestHeaders request) of
Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
Just v -> do
authGranted <- isGoodCookie v
if authGranted
then a
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
type PrivateAPI = Get '[JSON] [PrivateData]

24
servant-examples/servant-examples.cabal
View file

@ -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-docs
, servant-jquery
, servant-lucid
, servant-server
, servant == 0.4.*
, servant-docs == 0.4.*
, servant-jquery == 0.4.*
, servant-lucid == 0.4.*
, servant-server == 0.4.*
, text
, time
, transformers
@ -47,9 +47,9 @@ executable t8-main
aeson
, base >= 4.7 && < 5
, either
, servant
, servant-client
, servant-server
, servant == 0.4.*
, servant-client == 0.4.*
, 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-server
, servant == 0.4.*
, 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

2
servant-jquery/servant-jquery.cabal
View file

@ -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.

2
servant-lucid/servant-lucid.cabal
View file

@ -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/

2
servant-lucid/src/Servant/HTML/Lucid.hs
View file

@ -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")

6
servant-server/CHANGELOG.md
View file

@ -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

2
servant-server/example/greet.hs
View file

@ -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

16
servant-server/servant-server.cabal
View file

@ -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
, attoparsec >= 0.12 && < 0.13
, aeson >= 0.7 && < 0.10
, 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

3
servant-server/src/Servant/Server.hs
View file

@ -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

591
servant-server/src/Servant/Server/Internal.hs
View file

@ -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 Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (unfoldr)
import qualified Data.Map as M
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,
ResponseReceived, lazyRequestBody,
pathInfo, rawQueryString,
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Network.Wai (Application, lazyRequestBody,
rawQueryString, requestHeaders,
requestMethod, responseLBS)
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 pa a request $ \mResponse ->
if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse
route Proxy server = choice (route pa (extractL <$> server))
(route pb (extractR <$> server))
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
(first : rest)
-> case captured captureProxy first of
Nothing -> respond $ failWith NotFound
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
route Proxy subserver =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
(case captured captureProxy first of
Nothing -> return $ failWith NotFound
Just v -> feedTo subserver v)
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
| 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
route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
instance
#if MIN_VERSION_base(4,8,0)
@ -290,15 +200,7 @@ instance
type ServerT (Delete ctypes ()) m = m ()
route Proxy action request respond
| 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
route Proxy = methodRouterEmpty methodDelete
-- 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
| 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
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | 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
| 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
route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-- '()' ==> 204 No Content
instance
@ -371,15 +246,7 @@ instance
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| 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
route Proxy = methodRouterEmpty methodGet
-- 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
| 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
route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
-- | 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
where str = fromString $ symbolVal (Proxy :: Proxy sym)
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
| 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
route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
instance
#if MIN_VERSION_base(4,8,0)
@ -484,15 +323,7 @@ instance
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| 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
route Proxy = methodRouterEmpty methodPost
-- 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
| 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
route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-- | 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
| 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
route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
instance
#if MIN_VERSION_base(4,8,0)
@ -564,15 +368,7 @@ instance
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| 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
route Proxy = methodRouterEmpty methodPut
-- 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
| 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
route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-- | 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
| 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
route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
instance
#if MIN_VERSION_base(4,8,0)
@ -642,15 +411,7 @@ instance
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| 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
route Proxy = methodRouterEmpty methodPatch
-- 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
| 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
route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-- | 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
route (Proxy :: Proxy sublayout) (subserver param) request respond
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
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
route (Proxy :: Proxy sublayout) (subserver values) request respond
in route (Proxy :: Proxy sublayout) (feedTo subserver values)
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
route (Proxy :: Proxy sublayout) (subserver param) request respond
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
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,16 +560,17 @@ 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
(first : _)
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname querytext of
Nothing -> Nothing -- param absent from the query string
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) (subserver Nothing) request respond
route Proxy subserver = WithRequest $ \ request ->
case parsePathInfo request of
(first : _)
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname querytext of
Nothing -> Nothing -- param absent from the query string
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) (feedTo subserver param)
_ -> 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,16 +599,17 @@ 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
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
-- if sym is "foo", we look for matrix parameters
-- named "foo" or "foo[]" and call fromText on the
-- corresponding values
parameters = filter looksLikeParam matrixtext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (subserver values) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
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
-- named "foo" or "foo[]" and call fromText on the
-- corresponding values
parameters = filter looksLikeParam matrixtext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (feedTo subserver values)
_ -> 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,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname matrixtext 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
route Proxy subserver = WithRequest $ \ request ->
case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname matrixtext 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
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 =
rawApplication request (respond . succeedWith)
route Proxy rawApplication = LeafRouter $ \ request respond -> do
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,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = 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"
-- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of
Nothing -> respond . failWith $ UnsupportedMediaType
Just (Left e) -> respond . failWith $ InvalidBody e
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
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"
-- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of
Nothing -> return $ failWith $ UnsupportedMediaType
Just (Left e) -> return $ failWith $ InvalidBody e
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
(first : rest)
| first == cs (symbolVal proxyPath)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
route Proxy subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) subserver)
where proxyPath = Proxy :: Proxy path
ct_wildcard :: B.ByteString

38
servant-server/src/Servant/Server/Internal/PathInfo.hs Normal file
View file

@ -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

72
servant-server/src/Servant/Server/Internal/Router.hs Normal file
View file

@ -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

144
servant-server/src/Servant/Server/Internal/RoutingApplication.hs Normal file
View file

@ -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

52
servant-server/test/Servant/ServerSpec.hs
View file

@ -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

9
servant/CHANGELOG.md
View file

@ -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

4
servant/servant.cabal
View file

@ -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

1
servant/src/Servant/API/Capture.hs
View file

@ -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

2
servant/src/Servant/API/ContentTypes.hs
View file

@ -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
--------------------------------------------------------------------------

12
servant/src/Servant/Utils/Links.hs
View file

@ -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