diff --git a/.gitignore b/.gitignore index 3007a0c1..de16e47a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,8 @@ -dist -bin -lib -share -packages +/dist +/bin +/lib +/share +/packages *-packages.conf.d cabal-dev add-source-timestamps diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh new file mode 100755 index 00000000..f75a3d5e --- /dev/null +++ b/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 [-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 + diff --git a/scripts/lib/common.sh b/scripts/lib/common.sh new file mode 100644 index 00000000..19b85d5d --- /dev/null +++ b/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 +} diff --git a/scripts/start-sandbox.sh b/scripts/start-sandbox.sh index 7d042bd2..b6e88759 100755 --- a/scripts/start-sandbox.sh +++ b/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" -CABAL=${CABAL:-cabal} - -declare -a SOURCES -readarray -t SOURCES < "$SOURCES_TXT" +. "$DIR"/lib/common.sh prepare_sandbox () { $CABAL sandbox init diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 3e7d0465..5c78312c 100755 --- a/scripts/test-all.sh +++ b/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 diff --git a/scripts/update-defaults-nix.sh b/scripts/update-defaults-nix.sh index 7e85c98a..fb70bb82 100755 --- a/scripts/update-defaults-nix.sh +++ b/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)" -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 diff --git a/scripts/upload.sh b/scripts/upload.sh new file mode 100755 index 00000000..91f0b665 --- /dev/null +++ b/scripts/upload.sh @@ -0,0 +1,52 @@ +#!/bin/bash - +#=============================================================================== +# +# FILE: upload.sh +# +# USAGE: ./upload.sh +# +# 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 " + 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 diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index cccc3ed0..8177d980 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/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/ diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs index d13af84c..7870022d 100644 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ b/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") diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index efb268b9..b68a1e0c 100644 --- a/servant-client/CHANGELOG.md +++ b/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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 9c330ead..20794e1d 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 9505b5a0..0106318a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/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 - 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 diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index eae87c42..f8cc61e2 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -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 diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 1ff6d1cb..ffd4569f 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/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 diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index a50f55d4..763d1397 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 - (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 diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index f5991e93..b992b662 100644 --- a/servant-docs/servant-docs.cabal +++ b/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. diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index c6373fe1..d1a11439 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/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 = - 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] diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 655a4873..97d90ddc 100644 --- a/servant-examples/servant-examples.cabal +++ b/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-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 diff --git a/servant-jquery/servant-jquery.cabal b/servant-jquery/servant-jquery.cabal index 6ce90904..ebb7ec88 100644 --- a/servant-jquery/servant-jquery.cabal +++ b/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. diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 875e8597..c72807b2 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/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/ diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs index 7fa39709..f222c6ac 100644 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ b/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") diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 19975bba..99c329d8 100644 --- a/servant-server/CHANGELOG.md +++ b/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 diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 4c9df6ef..cd8bd138 100644 --- a/servant-server/example/greet.hs +++ b/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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 116c0a10..277f6050 100644 --- a/servant-server/servant-server.cabal +++ b/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 - , 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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6e28d99e..fcf02f1a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 423e7ac1..02c729f3 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 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 :: Proxy sublayout) (subserver param) request respond - - _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond + 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) (feedTo subserver param) + + _ -> 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 diff --git a/servant-server/src/Servant/Server/Internal/PathInfo.hs b/servant-server/src/Servant/Server/Internal/PathInfo.hs new file mode 100644 index 00000000..0138f72e --- /dev/null +++ b/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 + diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs new file mode 100644 index 00000000..2e0188e4 --- /dev/null +++ b/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 + diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs new file mode 100644 index 00000000..415fff2b --- /dev/null +++ b/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 + diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2689a4e2..00087d93 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 7f41460c..a640d629 100644 --- a/servant/CHANGELOG.md +++ b/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 diff --git a/servant/servant.cabal b/servant/servant.cabal index c376c9ac..fb605e11 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API/Capture.hs b/servant/src/Servant/API/Capture.hs index a40e0233..9a2e1b61 100644 --- a/servant/src/Servant/API/Capture.hs +++ b/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 diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index a9966d24..cf882dfc 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/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 -------------------------------------------------------------------------- diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 8b9537af..8238e97f 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -72,8 +72,7 @@ -- -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) -- >>> safeLink api bad_link --- --- :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