From b45ac07ecea3374c920f2c14dbbba13fc1af09a0 Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Sun, 17 May 2015 07:51:49 -0600 Subject: [PATCH 01/30] HasClient instance for Delete cts' () now does not care at all about content types provided --- servant-client/CHANGELOG.md | 4 ++++ servant-client/src/Servant/Client.hs | 17 +++++++++------ servant-client/test/Servant/ClientSpec.hs | 26 +++++++++++++++-------- 3 files changed, 31 insertions(+), 16 deletions(-) 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/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/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 12f06a8b..242a3620 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 From f7b2232818eda81a223b32e9618ce48b29809125 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 May 2015 12:07:44 +0200 Subject: [PATCH 02/30] Add missing servant-client test modules --- servant-client/servant-client.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 9c330ead..c18358ae 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -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 From 49289ecbb4f3bd081103aa51ae32c33d06d9c5df Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 May 2015 12:18:26 +0200 Subject: [PATCH 03/30] Add bump-versions script --- scripts/bump-versions.sh | 78 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) create mode 100755 scripts/bump-versions.sh diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh new file mode 100755 index 00000000..43391d35 --- /dev/null +++ b/scripts/bump-versions.sh @@ -0,0 +1,78 @@ +#!/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 + +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +DRY_RUN=false +POSITION="none" +SOURCES_TXT="$( dirname $DIR)/sources.txt" + +declare -a SOURCES +readarray -t SOURCES < "$SOURCES_TXT" + +usage () { + echo " bump-versions [-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 +} + +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 +} + +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 + From 0f4c73bffe1973c752cc8021fe178e0921a99c23 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Wed, 27 May 2015 11:29:08 +1000 Subject: [PATCH 04/30] Make safeLink safer (#92) --- servant/src/Servant/Utils/Links.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 8b9537af..a217e20d 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' @@ -168,7 +167,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 From 2bff26feca86acaa93647f13a1de32602dc1d554 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 May 2015 15:19:30 +0200 Subject: [PATCH 05/30] Bump attoparsec --- servant-server/servant-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 116c0a10..8aea2e55 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -41,7 +41,7 @@ library build-depends: base >= 4.7 && < 5 , aeson >= 0.7 && < 0.9 - , attoparsec >= 0.12 && < 0.13 + , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , either >= 4.3 && < 4.4 , http-types >= 0.8 && < 0.9 From 28387b7804e49d06830448537c073ac8ceda59f0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 May 2015 15:21:53 +0200 Subject: [PATCH 06/30] Update changelog --- servant-server/CHANGELOG.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 19975bba..4a1d4f33 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,8 @@ +0.4.1 +----- +* Bump attoparsec upper bound to < 0.14 +* Bump wai-app-static upper bound to < 3.2 + 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body From 35e7e386a5383edaec287758f71369a945c8f9de Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 May 2015 15:33:25 +0200 Subject: [PATCH 07/30] Update servant changelog --- servant/CHANGELOG.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 7f41460c..21dd0278 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,3 +1,8 @@ +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 From 717b18df4e759c30765bdf56f709b0050c4220d4 Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 20 May 2015 21:54:10 +0200 Subject: [PATCH 08/30] Use MonadThrow instead of Either in the signature of parseBaseUrl --- servant-client/src/Servant/Common/BaseUrl.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index eae87c42..211c414c 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -2,8 +2,10 @@ {-# LANGUAGE ViewPatterns #-} module Servant.Common.BaseUrl where +import Control.Monad.Catch (MonadThrow, throwM) import Data.List import GHC.Generics +import Network.HTTP.Client (HttpException(InvalidUrlException)) import Network.URI import Safe import Text.Read @@ -34,20 +36,20 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port -parseBaseUrl :: String -> Either String BaseUrl +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 (InvalidUrlException s "Invalid base URL") else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of From 076286c37bd421137678c5a90fb6b9b895d3845f Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Thu, 21 May 2015 18:22:12 +0200 Subject: [PATCH 09/30] Add a Exception instance for ServantError --- servant-client/src/Servant/Common/Req.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index b726e7a9..1204181b 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -55,6 +55,8 @@ data ServantError } deriving (Show) +instance Exception ServantError + data Req = Req { reqPath :: String , qs :: QueryText From 15b54cf1d0ba90591eced900a20047e18ff6b1ed Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Sat, 23 May 2015 14:55:12 +0200 Subject: [PATCH 10/30] Add AutoDeriveTypeable for ghc < 7.10 --- servant-client/src/Servant/Common/Req.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 1204181b..19d5ddce 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} From 520519bca9a61e4a0b9a4ffdf90610dcb523090c Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 27 May 2015 15:29:56 +0200 Subject: [PATCH 11/30] Remove deps on HttpException from http-client --- servant-client/src/Servant/Common/BaseUrl.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 211c414c..3862821d 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -1,11 +1,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Common.BaseUrl where +module Servant.Common.BaseUrl ( + -- * types + BaseUrl (..) + , InvalidBaseUrlException + , Scheme (..) + -- * functions + , parseBaseUrl + , showBaseUrl +) where -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (MonadThrow, throwM, Exception) import Data.List import GHC.Generics -import Network.HTTP.Client (HttpException(InvalidUrlException)) import Network.URI import Safe import Text.Read @@ -36,6 +43,9 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port +newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show +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 @@ -49,7 +59,7 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> return (BaseUrl Https host 443) _ -> if "://" `isInfixOf` s - then throwM (InvalidUrlException s "Invalid base URL") + then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of From 7976468a3255ca2734e31836a5cb292677d62b55 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 28 May 2015 11:22:43 +0200 Subject: [PATCH 12/30] Add servant bounds for servant-examples. --- servant-examples/servant-examples.cabal | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 655a4873..17f97cea 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -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 From 5de9daf5281bf2132c2a463a9cf0a422f3c2efca Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 29 May 2015 10:59:24 +0200 Subject: [PATCH 13/30] Fix outdated docs --- servant-server/example/greet.hs | 2 +- servant-server/src/Servant/Server/Internal.hs | 28 +++++++++---------- 2 files changed, 15 insertions(+), 15 deletions(-) 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/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 423e7ac1..e3282624 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -227,7 +227,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 @@ -253,7 +253,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) -- -- 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 @@ -329,7 +329,7 @@ instance -- | 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. @@ -425,7 +425,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 @@ -442,7 +442,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- | 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. @@ -523,7 +523,7 @@ instance -- | 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. @@ -603,7 +603,7 @@ instance -- | 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. @@ -696,7 +696,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) @@ -735,7 +735,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 @@ -768,7 +768,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 @@ -810,7 +810,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) @@ -849,7 +849,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 @@ -883,7 +883,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 @@ -940,7 +940,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 From 3bcbe80c378697bc3ef131fbf1b4403c42c41d80 Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 27 May 2015 22:25:08 +0200 Subject: [PATCH 14/30] Fix for GHC-7.8.x --- servant-client/src/Servant/Common/BaseUrl.hs | 8 +++++--- servant-client/src/Servant/Common/Req.hs | 5 +++-- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 3862821d..f8cc61e2 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} module Servant.Common.BaseUrl ( -- * types BaseUrl (..) @@ -12,6 +13,7 @@ module Servant.Common.BaseUrl ( import Control.Monad.Catch (MonadThrow, throwM, Exception) import Data.List +import Data.Typeable import GHC.Generics import Network.URI import Safe @@ -43,7 +45,7 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port -newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show +data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) instance Exception InvalidBaseUrlException parseBaseUrl :: MonadThrow m => String -> m BaseUrl diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 19d5ddce..ac2c3dba 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,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 @@ -54,7 +55,7 @@ data ServantError { responseContentTypeHeader :: ByteString , responseBody :: ByteString } - deriving (Show) + deriving (Show, Typeable) instance Exception ServantError From ce012da4ee2e4569c1f9a3d0c47c372dfedaae1a Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 29 May 2015 14:29:32 +0200 Subject: [PATCH 15/30] Bump 'either' upper-bound --- servant-server/CHANGELOG.md | 1 + servant-server/servant-server.cabal | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 4a1d4f33..99c329d8 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -2,6 +2,7 @@ ----- * 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 --- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 8aea2e55..d540a9e0 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -43,7 +43,7 @@ library , aeson >= 0.7 && < 0.9 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 - , either >= 4.3 && < 4.4 + , either >= 4.3 && < 4.5 , http-types >= 0.8 && < 0.9 , network-uri >= 2.6 && < 2.7 , mtl >= 2 && < 3 From 9f1cb6320673aba76e252c0724b72d380a274e19 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 29 May 2015 16:08:14 +0200 Subject: [PATCH 16/30] fix HTML content types in haddocks --- servant-blaze/src/Servant/HTML/Blaze.hs | 2 +- servant-lucid/src/Servant/HTML/Lucid.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) 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-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") From 0b3291970f75305f7d2ab734d583e621e1dc7af9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 29 May 2015 16:24:08 +0200 Subject: [PATCH 17/30] Bump to 0.4.1 --- servant-blaze/servant-blaze.cabal | 2 +- servant-client/servant-client.cabal | 2 +- servant-docs/servant-docs.cabal | 2 +- servant-examples/servant-examples.cabal | 2 +- servant-jquery/servant-jquery.cabal | 2 +- servant-lucid/servant-lucid.cabal | 2 +- servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) 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-client/servant-client.cabal b/servant-client/servant-client.cabal index c18358ae..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 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/servant-examples.cabal b/servant-examples/servant-examples.cabal index 17f97cea..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. 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-server/servant-server.cabal b/servant-server/servant-server.cabal index d540a9e0..c0a07c3b 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 diff --git a/servant/servant.cabal b/servant/servant.cabal index c376c9ac..81b476cd 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 From 939a008b676aa9e433a9737751fb68af268dbe5a Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 3 Jun 2015 06:53:34 -0400 Subject: [PATCH 18/30] Bump aeson bound --- servant-server/servant-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c0a07c3b..0bfba00a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -40,7 +40,7 @@ library Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.9 + , aeson >= 0.7 && < 0.10 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , either >= 4.3 && < 4.5 From 74a52df1a1e837d5f9f7e74db2eaa33bed76303e Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 3 Jun 2015 07:13:49 -0400 Subject: [PATCH 19/30] API.Capture: Fix haddocks --- servant/src/Servant/API/Capture.hs | 1 + 1 file changed, 1 insertion(+) 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 From f9b1e7fc5020fc9c9f0928d2baca46719596b499 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Fri, 29 May 2015 17:16:36 +0200 Subject: [PATCH 20/30] Switch server interpretation to a datatype for efficiency. Instead of directly interpreting a server as a `RoutingApplication`, this change introduces the concept of a `Router`, which is a datatype with several constructors. In particular, the type of the `route` function changes from route :: Proxy layout -> Server layout -> RoutingApplication to route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router Most important in practice is the case of the `StaticRouter` constructor in `Router`. For choices between statically known paths, we can now use a lookup table to dispatch requests rather than trying each request individually. This brings down routing complexity of a common case from O(n) to O(log n). Another important change is that the handler that is passed down by `route` is no longer of type `Server layout`, but of type `IO (RouteResult (Server layout))`. This means that API constructs can "delay" checks and failure. For example, `ReqBody` does not have to fetch the request body and feed it to the handler immediately; it can instead record these actions in the handler that is passed down. The code will only be executed at a leaf / endpoint of the API. This is desired behaviour: We prefer to save work by doing all matching on static path components first. Furthermore, we get better error codes by doing so. --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal.hs | 624 ++++++++++-------- 3 files changed, 348 insertions(+), 279 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c0a07c3b..bfb12f9b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -43,6 +43,7 @@ library , aeson >= 0.7 && < 0.9 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 , either >= 4.3 && < 4.5 , http-types >= 0.8 && < 0.9 , network-uri >= 2.6 && < 2.7 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6e28d99e..8f60583a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -108,7 +108,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 e3282624..069aab78 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 #-} @@ -14,7 +15,7 @@ module Servant.Server.Internal where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +import Control.Applicative (Applicative, (<$>)) import Data.Monoid (Monoid, mappend, mempty) #endif import Control.Monad.Trans.Either (EitherT, runEitherT) @@ -22,6 +23,7 @@ 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, (<>)) @@ -52,6 +54,68 @@ import Servant.Common.Text (FromText, fromText) import Servant.Server.Internal.ServantErr +-- | Internal representation of a router. +data Router = + WithRequest (Request -> Router) + -- ^ current request is passed to the router + | StaticRouter (M.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 + data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString @@ -120,7 +184,33 @@ instance Monoid RouteMismatch where -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a = RR { routeResult :: Either RouteMismatch a } - deriving (Eq, Show) + deriving (Eq, Show, Functor, Applicative) + +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 @@ -179,7 +269,7 @@ processedPathInfo 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 +290,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 @@ -235,15 +321,12 @@ 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) @@ -267,20 +350,19 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -290,15 +372,15 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -310,21 +392,20 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' @@ -347,20 +428,19 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- '()' ==> 204 No Content instance @@ -371,15 +451,15 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -391,21 +471,20 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -433,11 +512,10 @@ 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' @@ -461,20 +539,19 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -484,15 +561,15 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -504,21 +581,20 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -541,20 +617,19 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -564,15 +639,15 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -584,21 +659,20 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Patch' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -619,20 +693,19 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -642,15 +715,15 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -662,21 +735,20 @@ 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 action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ 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 + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -705,7 +777,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 +785,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, @@ -743,16 +813,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 @@ -776,15 +844,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 @@ -819,16 +885,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) @@ -857,16 +924,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 <> "[]") @@ -891,17 +959,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 +988,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 @@ -948,19 +1020,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 +1041,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 From 404bfdd89cc5d5949021341ad25d6126dcfdf39a Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 10:24:09 +0200 Subject: [PATCH 21/30] Add test cases for the priority of error codes. Due to the delayed treatment of checks during the server interpretation, we now have the ability to produce "better" error codes for certain APIs. This change introduces test cases for some of these situations and their new, desired results. These tests would mostly fail with the old approach to routing. --- servant-server/test/Servant/ServerSpec.hs | 49 +++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2689a4e2..ca604ae7 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -89,6 +89,7 @@ spec = do headerSpec rawSpec unionSpec + prioErrorsSpec errorsSpec responseHeadersSpec @@ -572,6 +573,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 From e83397a1db504ee4195ee3f951c27588108e335d Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 15:30:09 +0200 Subject: [PATCH 22/30] Fix the auth combinator example. This change adapt the auth combinator example to the new router code. In general, the server interpretation of user-written combinators will be affected by the new routing code. The change here also introduces a change in functionality: previously, wrong authentication triggered a "hard failure", whereas we now trigger a "soft failure", which is recoverable. For the simple example, this does not make a lot of difference. In general, I think having a soft failure is the right option to take here, although we want a more general story about the relative priorities of different error codes. --- .../auth-combinator/auth-combinator.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) 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] From eb86a821059d9f6827972afe5155614b411d5138 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 19:38:51 +0200 Subject: [PATCH 23/30] Refactoring: one module per concept. The main `Server.Internal` module was getting a bit large for my taste. It now contains just the instances. All the administrative utilities are in their own dedicated modules. --- servant-server/servant-server.cabal | 5 +- servant-server/src/Servant/Server.hs | 1 - servant-server/src/Servant/Server/Internal.hs | 240 ++---------------- .../src/Servant/Server/Internal/PathInfo.hs | 38 +++ .../src/Servant/Server/Internal/Router.hs | 72 ++++++ .../Server/Internal/RoutingApplication.hs | 145 +++++++++++ servant-server/test/Servant/ServerSpec.hs | 3 +- 7 files changed, 276 insertions(+), 228 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/PathInfo.hs create mode 100644 servant-server/src/Servant/Server/Internal/Router.hs create mode 100644 servant-server/src/Servant/Server/Internal/RoutingApplication.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index bfb12f9b..00e5193f 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -35,8 +35,11 @@ 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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8f60583a..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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 069aab78..5d0f4025 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -12,17 +12,19 @@ {-# 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 (Applicative, (<$>)) -import Data.Monoid (Monoid, mappend, mempty) +import Control.Applicative ((<$>)) #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) @@ -33,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, @@ -52,220 +51,11 @@ 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 --- | Internal representation of a router. -data Router = - WithRequest (Request -> Router) - -- ^ current request is passed to the router - | StaticRouter (M.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 - -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, Functor, Applicative) - -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 - --- | 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 :: * -> *) :: * 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..2f2355fe --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -0,0 +1,145 @@ +{-# 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. +-- * 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 + +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 ca604ae7..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 From 31b12d4bf468b9fd46f5c4b797f8ef11d0894aba Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 21:12:12 +0200 Subject: [PATCH 24/30] Refactoring: abstracting common parts of method handlers. This change makes an attempt of abstracting out some of the common functionality found in the handlers for the different request methods. There's still a bit of code duplication between the cases for headers and no headers and empty responses. But it's a significant relative improvement already. --- servant-server/src/Servant/Server/Internal.hs | 245 +++++------------- .../Server/Internal/RoutingApplication.hs | 1 - 2 files changed, 65 insertions(+), 181 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5d0f4025..02c729f3 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -120,6 +120,56 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) 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. @@ -140,19 +190,7 @@ instance type ServerT (Delete ctypes a) m = m a - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - runAction action respond $ \ 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 - | 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) @@ -162,15 +200,7 @@ instance type ServerT (Delete ctypes ()) m = m () - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" - | pathIsEmpty request && requestMethod request /= methodDelete = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouterEmpty methodDelete -- Add response headers instance @@ -182,20 +212,7 @@ instance type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - runAction action respond $ \ 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 - | 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' @@ -218,19 +235,7 @@ instance type ServerT (Get ctypes a) m = m a - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodGet = do - runAction action respond $ \ 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 - | pathIsEmpty request && requestMethod request /= methodGet = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 -- '()' ==> 204 No Content instance @@ -241,15 +246,7 @@ instance type ServerT (Get ctypes ()) m = m () - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodGet = do - runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" - | pathIsEmpty request && requestMethod request /= methodGet = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouterEmpty methodGet -- Add response headers instance @@ -261,20 +258,7 @@ instance type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodGet = do - runAction action respond $ \ 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 - | 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 @@ -329,19 +313,7 @@ instance type ServerT (Post ctypes a) m = m a - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPost = do - runAction action respond $ \ 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 - | 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) @@ -351,15 +323,7 @@ instance type ServerT (Post ctypes ()) m = m () - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPost = do - runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" - | pathIsEmpty request && requestMethod request /= methodPost = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouterEmpty methodPost -- Add response headers instance @@ -371,20 +335,7 @@ instance type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPost = do - runAction action respond $ \ 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 - | 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' @@ -407,19 +358,7 @@ instance type ServerT (Put ctypes a) m = m a - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPut = do - runAction action respond $ \ 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 - | 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) @@ -429,15 +368,7 @@ instance type ServerT (Put ctypes ()) m = m () - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPut = do - runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" - | pathIsEmpty request && requestMethod request /= methodPut = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouterEmpty methodPut -- Add response headers instance @@ -449,20 +380,7 @@ instance type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPut = do - runAction action respond $ \ 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 - | 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' @@ -483,19 +401,7 @@ instance type ServerT (Patch ctypes a) m = m a - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - runAction action respond $ \ 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 - | 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) @@ -505,15 +411,7 @@ instance type ServerT (Patch ctypes ()) m = m () - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" - | pathIsEmpty request && requestMethod request /= methodPatch = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy = methodRouterEmpty methodPatch -- Add response headers instance @@ -525,20 +423,7 @@ instance type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - route Proxy action = LeafRouter route' - where - route' request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - runAction action respond $ \ 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 - | 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 diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 2f2355fe..415fff2b 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -46,7 +46,6 @@ instance Monoid (RouteResult a) where -- 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 From fb26e134d518b8392ca65a28f23778e16f0fc38f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 4 Jun 2015 14:28:28 +0200 Subject: [PATCH 25/30] Don't render header via String --- servant/src/Servant/API/ContentTypes.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 -------------------------------------------------------------------------- From d5091a68e11c2f337c400ec7e656682fb7127777 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 4 Jun 2015 15:09:01 +0200 Subject: [PATCH 26/30] Bump string-conversions --- servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 26ee185d..277f6050 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -55,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/servant.cabal b/servant/servant.cabal index 81b476cd..fb605e11 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -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 From 8b0ade729e45e8f450d1fdd6237e025d389decab Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 5 Jun 2015 12:18:01 +0200 Subject: [PATCH 27/30] Add missing Patch case for safeLink --- servant/CHANGELOG.md | 4 ++++ servant/src/Servant/Utils/Links.hs | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 21dd0278..a640d629 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,3 +1,7 @@ +0.4.2 +----- +* Fix missing cases for `Patch` in `safeLink` + 0.4.1 ----- * Allow whitespace after parsing JSON diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index a217e20d..8238e97f 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -122,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 ) @@ -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 From aec39b546eb9f99b8c7169c8438b6ad230fc51c8 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 5 Jun 2015 14:14:26 +0200 Subject: [PATCH 28/30] Upload script and some script refactoring --- .gitignore | 10 +++---- scripts/bump-versions.sh | 21 ++------------ scripts/lib/common.sh | 31 +++++++++++++++++++++ scripts/start-sandbox.sh | 7 +---- scripts/test-all.sh | 9 +----- scripts/update-defaults-nix.sh | 7 +---- scripts/upload.sh | 51 ++++++++++++++++++++++++++++++++++ 7 files changed, 92 insertions(+), 44 deletions(-) create mode 100644 scripts/lib/common.sh create mode 100755 scripts/upload.sh 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 index 43391d35..f75a3d5e 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -16,33 +16,16 @@ set -o nounset set -o errexit -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) -DRY_RUN=false -POSITION="none" -SOURCES_TXT="$( dirname $DIR)/sources.txt" - -declare -a SOURCES -readarray -t SOURCES < "$SOURCES_TXT" +. lib/common.sh usage () { - echo " bump-versions [-d|--dry-run]" + 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 } -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 -} - if [ $# -eq 0 ] ; then echo "expecting one or more arguments. Got 0" usage diff --git a/scripts/lib/common.sh b/scripts/lib/common.sh new file mode 100644 index 00000000..d41a8988 --- /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=$( 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..1c1cab5a 100755 --- a/scripts/start-sandbox.sh +++ b/scripts/start-sandbox.sh @@ -13,12 +13,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" +. lib/common.sh prepare_sandbox () { $CABAL sandbox init diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 3e7d0465..111e4e9d 100755 --- a/scripts/test-all.sh +++ b/scripts/test-all.sh @@ -14,14 +14,7 @@ set -o nounset set -o errexit -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) -GHC_FLAGS="-Werror" -SOURCES_TXT="$( dirname $DIR)/sources.txt" -CABAL=${CABAL:-cabal} - -declare -a SOURCES -readarray -t SOURCES < "$SOURCES_TXT" - +. lib/common.sh prepare_sandbox () { $CABAL sandbox init diff --git a/scripts/update-defaults-nix.sh b/scripts/update-defaults-nix.sh index 7e85c98a..4ad7a291 100755 --- a/scripts/update-defaults-nix.sh +++ b/scripts/update-defaults-nix.sh @@ -11,12 +11,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" +. 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..fc0219f7 --- /dev/null +++ b/scripts/upload.sh @@ -0,0 +1,51 @@ +#!/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 + +. lib/common.sh + +usage () { + echo " upload.sh " + echo " Uploads all servant packages to Hackage" + exit 0 +} + + +upload_package () { + local package="$0" + local cabalFile="$0.cabal" + pushd "$package" + local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }') + local sdist="${package}-${version}.tar.gz" + cabal sdist + cabal upload --user="$USER" --password="$PASS" "$sdist" + popd +} + + +if [ $# -ne 2 ] ; then + echo "expecting two arguments." + usage +else + USER="$0" + PASS="$1" +fi + +versions_equal + +for s in ${SOURCES[@]} ; do + upload_package "$s" +done From a621b1d85482dedb27b24e3ca980f91e3965fe05 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 5 Jun 2015 15:08:52 +0200 Subject: [PATCH 29/30] Fix DIR issues --- scripts/lib/common.sh | 2 +- scripts/start-sandbox.sh | 3 ++- scripts/test-all.sh | 5 ++++- scripts/update-defaults-nix.sh | 3 ++- scripts/upload.sh | 3 ++- 5 files changed, 11 insertions(+), 5 deletions(-) diff --git a/scripts/lib/common.sh b/scripts/lib/common.sh index d41a8988..19b85d5d 100644 --- a/scripts/lib/common.sh +++ b/scripts/lib/common.sh @@ -10,7 +10,7 @@ #=============================================================================== -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )) DRY_RUN=false POSITION="none" SOURCES_TXT="$( dirname $DIR)/sources.txt" diff --git a/scripts/start-sandbox.sh b/scripts/start-sandbox.sh index 1c1cab5a..b6e88759 100755 --- a/scripts/start-sandbox.sh +++ b/scripts/start-sandbox.sh @@ -13,7 +13,8 @@ set -o nounset set -o errexit -. lib/common.sh +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +. "$DIR"/lib/common.sh prepare_sandbox () { $CABAL sandbox init diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 111e4e9d..5c78312c 100755 --- a/scripts/test-all.sh +++ b/scripts/test-all.sh @@ -14,7 +14,10 @@ set -o nounset set -o errexit -. lib/common.sh +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +. "$DIR"/lib/common.sh + +GHC_FLAGS="-Werror" prepare_sandbox () { $CABAL sandbox init diff --git a/scripts/update-defaults-nix.sh b/scripts/update-defaults-nix.sh index 4ad7a291..fb70bb82 100755 --- a/scripts/update-defaults-nix.sh +++ b/scripts/update-defaults-nix.sh @@ -11,7 +11,8 @@ set -o nounset set -o errexit -. lib/common.sh +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +. "$DIR"/lib/common.sh for s in ${SOURCES[@]} ; do echo $s diff --git a/scripts/upload.sh b/scripts/upload.sh index fc0219f7..f9898b92 100755 --- a/scripts/upload.sh +++ b/scripts/upload.sh @@ -15,7 +15,8 @@ set -o nounset set -o errexit -. lib/common.sh +DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) +. "$DIR"/lib/common.sh usage () { echo " upload.sh " From ab19ea884a2b386dc95d2b4a62cd2b48f3cc93c9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 9 Jun 2015 12:51:39 +0200 Subject: [PATCH 30/30] Fix upload script issues --- scripts/upload.sh | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/scripts/upload.sh b/scripts/upload.sh index f9898b92..91f0b665 100755 --- a/scripts/upload.sh +++ b/scripts/upload.sh @@ -26,13 +26,16 @@ usage () { upload_package () { - local package="$0" - local cabalFile="$0.cabal" + 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="${package}-${version}.tar.gz" + local sdist="dist/${package}-${version}.tar.gz" cabal sdist - cabal upload --user="$USER" --password="$PASS" "$sdist" + echo "User is: $user" + cabal upload --user="$user" --password="$pass" "$sdist" popd } @@ -40,13 +43,10 @@ upload_package () { if [ $# -ne 2 ] ; then echo "expecting two arguments." usage -else - USER="$0" - PASS="$1" fi versions_equal for s in ${SOURCES[@]} ; do - upload_package "$s" + upload_package "$s" "$1" "$2" done