From 3467eba44f1e1fc66f77fc3d089cfb19f9c4b5f2 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 20 Feb 2016 13:36:50 +0100 Subject: [PATCH 01/74] servant-server: Bump transformers upper 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 79f3c934..05c4f31b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -62,7 +62,7 @@ library , system-filepath >= 0.4 && < 0.5 , filepath >= 1 , text >= 1.2 && < 1.3 - , transformers >= 0.3 && < 0.5 + , transformers >= 0.3 && < 0.6 , transformers-compat>= 0.4 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 From c6e51260f0780428a9b770d41f24bf1570ae2277 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 20 Feb 2016 13:37:02 +0100 Subject: [PATCH 02/74] ContentTypes: Add constraints GHC 8.0 seems to want these. --- 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 61bf1ce9..dda31e0d 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -170,7 +170,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) instance OVERLAPPABLE_ - (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where + (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val From 933a2c4445150da454591a58835fcc2f7e0d7a51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 5 Apr 2016 17:51:25 +0800 Subject: [PATCH 03/74] re-export `ClientM` from `Servant.Client`. --- servant-client/src/Servant/Client.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index cb6837ce..ee27846c 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -19,6 +19,7 @@ module Servant.Client , AuthenticateReq(..) , client , HasClient(..) + , ClientM , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl From 4224c20bffc96ccef17a4d7048d0a87d4324162e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 6 Apr 2016 10:59:49 +0800 Subject: [PATCH 04/74] some formatting and refactoring --- .../src/Servant/Server/Internal/BasicAuth.hs | 12 +++++------ servant-server/test/Servant/ServerSpec.hs | 20 ++++++++++++------- servant/src/Servant/API/BasicAuth.hs | 7 ++++--- servant/src/Servant/API/Experimental/Auth.hs | 5 ++--- 4 files changed, 25 insertions(+), 19 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs index f941f401..2f430417 100644 --- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.BasicAuth where @@ -15,9 +15,9 @@ import GHC.Generics import Network.HTTP.Types (Header) import Network.Wai (Request, requestHeaders) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) -import Servant.Server.Internal.RoutingApplication -import Servant.Server.Internal.ServantErr +import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ServantErr -- * Basic Auth diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 5499c804..2e066582 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -546,16 +546,16 @@ type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal basicAuthApi :: Proxy BasicAuthAPI basicAuthApi = Proxy + basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = - let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) -> + let basicHandler = BasicAuthCheck $ \(BasicAuthData usr pass) -> if usr == "servant" && pass == "server" - then return (Authorized ()) - else return Unauthorized - ) + then return (Authorized ()) + else return Unauthorized in basicHandler :. EmptyContext basicAuthSpec :: Spec @@ -564,10 +564,13 @@ basicAuthSpec = do with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do context "Basic Authentication" $ do - it "returns with 401 with bad password" $ do + it "returns 401 with bad password" $ do get "/basic" `shouldRespondWith` 401 + it "returns 200 with the right password" $ do - THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200 + let validCredentials = [("Authorization", "Basic c2VydmFudDpzZXJ2ZXI=")] + THW.request methodGet "/basic" validCredentials "" + `shouldRespondWith` 200 -- }}} ------------------------------------------------------------------------------ @@ -575,14 +578,16 @@ basicAuthSpec = do ------------------------------------------------------------------------------ type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal + authApi :: Proxy GenAuthAPI authApi = Proxy + authServer :: Server GenAuthAPI authServer = const (return tweety) type instance AuthServerData (AuthProtect "auth") = () -genAuthContext :: Context '[ AuthHandler Request () ] +genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = let authHandler = (\req -> if elem ("Auth", "secret") (requestHeaders req) @@ -599,6 +604,7 @@ genAuthSpec = do context "Custom Auth Protection" $ do it "returns 401 when missing headers" $ do get "/auth" `shouldRespondWith` 401 + it "returns 200 with the right header" $ do THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs index cc38ddb3..307c21aa 100644 --- a/servant/src/Servant/API/BasicAuth.hs +++ b/servant/src/Servant/API/BasicAuth.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} + module Servant.API.BasicAuth where import Data.ByteString (ByteString) import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import GHC.TypeLits (Symbol) -- | Combinator for . diff --git a/servant/src/Servant/API/Experimental/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs index ce330287..fa79bfc7 100644 --- a/servant/src/Servant/API/Experimental/Auth.hs +++ b/servant/src/Servant/API/Experimental/Auth.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where import Data.Typeable (Typeable) @@ -11,4 +11,3 @@ import Data.Typeable (Typeable) -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE. data AuthProtect (tag :: k) deriving (Typeable) - From 14ff2197268c02cb47b311abae1d4591f1b34704 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 6 Apr 2016 11:16:18 +0800 Subject: [PATCH 05/74] fix error status bug in basic auth Fixes #440. --- .../src/Servant/Server/Internal/BasicAuth.hs | 4 ++-- servant-server/test/Servant/ServerSpec.hs | 19 ++++++++++++++++--- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs index 2f430417..fcd678b5 100644 --- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -64,6 +64,6 @@ runBasicAuth req realm (BasicAuthCheck ba) = Just e -> ba e >>= \res -> case res of BadPassword -> plzAuthenticate NoSuchUser -> plzAuthenticate - Unauthorized -> return $ Fail err403 + Unauthorized -> return $ FailFatal err403 Authorized usr -> return $ Route usr - where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] } + where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2e066582..31bdadd1 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -30,6 +30,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, + imATeaPot418, parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, @@ -542,13 +543,17 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $ -- * Basic Authentication {{{ ------------------------------------------------------------------------------ -type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal +type BasicAuthAPI = + BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal + :<|> Raw basicAuthApi :: Proxy BasicAuthAPI basicAuthApi = Proxy basicAuthServer :: Server BasicAuthAPI -basicAuthServer = const (return jerry) +basicAuthServer = + const (return jerry) :<|> + (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -564,14 +569,22 @@ basicAuthSpec = do with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do context "Basic Authentication" $ do - it "returns 401 with bad password" $ do + it "returns 401 when no credentials given" $ do get "/basic" `shouldRespondWith` 401 + it "returns 403 when invalid credentials given" $ do + let invalid = [("Authorization", "Basic bbbbbbbbbDpzZXJ2ZXI=")] -- fixme: how do I create basic auth tokens? + THW.request methodGet "/basic" invalid "" + `shouldRespondWith` 403 + it "returns 200 with the right password" $ do let validCredentials = [("Authorization", "Basic c2VydmFudDpzZXJ2ZXI=")] THW.request methodGet "/basic" validCredentials "" `shouldRespondWith` 200 + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 + -- }}} ------------------------------------------------------------------------------ -- * General Authentication {{{ From 6df3429b6860f3e4b21d1382f6c50b0bec9c0d96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 6 Apr 2016 15:24:30 +0800 Subject: [PATCH 06/74] refactored basic auth test cases --- servant-server/servant-server.cabal | 1 + servant-server/test/Servant/ServerSpec.hs | 10 ++++++---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 5ba00c65..0dfbfe14 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -111,6 +111,7 @@ test-suite spec base == 4.* , base-compat , aeson + , base64-bytestring , bytestring , bytestring-conversion , directory diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 31bdadd1..b3f021e1 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -19,8 +19,10 @@ import Control.Applicative ((<$>)) import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) +import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Conversion () import Data.Char (toUpper) +import Data.Monoid import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) @@ -569,17 +571,17 @@ basicAuthSpec = do with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do context "Basic Authentication" $ do + let basicAuthHeaders user password = + [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))] it "returns 401 when no credentials given" $ do get "/basic" `shouldRespondWith` 401 it "returns 403 when invalid credentials given" $ do - let invalid = [("Authorization", "Basic bbbbbbbbbDpzZXJ2ZXI=")] -- fixme: how do I create basic auth tokens? - THW.request methodGet "/basic" invalid "" + THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" `shouldRespondWith` 403 it "returns 200 with the right password" $ do - let validCredentials = [("Authorization", "Basic c2VydmFudDpzZXJ2ZXI=")] - THW.request methodGet "/basic" validCredentials "" + THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") "" `shouldRespondWith` 200 it "plays nice with subsequent Raw endpoints" $ do From 8a0c3a9497bc77f52b03473ed55e55169cfa0370 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 6 Apr 2016 13:45:44 +0200 Subject: [PATCH 07/74] Add test: Gen Auth properly supports Raw endpoints --- servant-server/test/Servant/ServerSpec.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index b3f021e1..b101d19e 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -593,12 +593,14 @@ basicAuthSpec = do ------------------------------------------------------------------------------ type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal + :<|> Raw -authApi :: Proxy GenAuthAPI -authApi = Proxy +genAuthApi :: Proxy GenAuthAPI +genAuthApi = Proxy -authServer :: Server GenAuthAPI -authServer = const (return tweety) +genAuthServer :: Server GenAuthAPI +genAuthServer = const (return tweety) + :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -614,7 +616,7 @@ genAuthContext = genAuthSpec :: Spec genAuthSpec = do describe "Servant.API.Auth" $ do - with (return (serveWithContext authApi genAuthContext authServer)) $ do + with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do context "Custom Auth Protection" $ do it "returns 401 when missing headers" $ do @@ -623,6 +625,9 @@ genAuthSpec = do it "returns 200 with the right header" $ do THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ From 285f47e252c7036c54b5eccc97da688e7fe9dd98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 4 Apr 2016 16:54:27 +0800 Subject: [PATCH 08/74] sources.txt: prefer servant-server and servant-client I think both for the release script and for CI it makes sense to prefer these two packages. --- sources.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sources.txt b/sources.txt index 2d3f8107..14089dbb 100644 --- a/sources.txt +++ b/sources.txt @@ -1,10 +1,10 @@ servant -servant-cassava +servant-server servant-client +servant-cassava servant-docs servant-foreign servant-js -servant-server servant-blaze servant-lucid servant-mock From c2c9bef5715bdfb1819f54e00127a62f2fdc44ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 7 Apr 2016 18:24:29 +0800 Subject: [PATCH 09/74] version bump --- doc/tutorial/tutorial.cabal | 2 +- servant-blaze/servant-blaze.cabal | 2 +- servant-cassava/servant-cassava.cabal | 2 +- servant-client/servant-client.cabal | 2 +- servant-docs/servant-docs.cabal | 2 +- servant-foreign/servant-foreign.cabal | 2 +- servant-js/servant-js.cabal | 2 +- servant-lucid/servant-lucid.cabal | 2 +- servant-mock/servant-mock.cabal | 2 +- servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 2 +- 11 files changed, 11 insertions(+), 11 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index e475ffaf..47c507d2 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,5 +1,5 @@ name: tutorial -version: 0.6 +version: 0.6.1 synopsis: The servant tutorial homepage: http://haskell-servant.github.io/ license: BSD3 diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index f51c49cf..5a811621 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.6 +version: 0.6.1 synopsis: Blaze-html support for servant -- description: homepage: http://haskell-servant.github.io/ diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index ccb37b07..868013b6 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.6 +version: 0.6.1 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.github.io/ diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 044511c6..3f982751 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.6 +version: 0.6.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 878aa802..084c5167 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.6 +version: 0.6.1 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 45673dbc..1ce0859e 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.6 +version: 0.6.1 synopsis: Helpers for generating clients for servant APIs in any programming language description: Helper types and functions for generating client functions for servant APIs in any programming language diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 660efbec..64e937e3 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -1,5 +1,5 @@ name: servant-js -version: 0.6 +version: 0.6.1 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 325cbb73..7619022b 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.6 +version: 0.6.1 synopsis: Servant support for lucid -- description: homepage: http://haskell-servant.github.io/ diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 3806b79d..aa877c04 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -1,5 +1,5 @@ name: servant-mock -version: 0.6 +version: 0.6.1 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 0dfbfe14..690b9fb3 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.6 +version: 0.6.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 51e1ce3b..8c013bbe 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.6 +version: 0.6.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them From 8bf81190b2ff8581d7dad028bb48f3600f3e1eaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 7 Apr 2016 18:04:36 +0800 Subject: [PATCH 10/74] add one more auth test just to clarify on how to use it properly --- .../src/Servant/Server/Experimental/Auth.hs | 1 - servant-server/test/Servant/ServerSpec.hs | 14 ++++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index 1cc698fc..d40bbd20 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -63,4 +63,3 @@ instance ( HasServer api context where authHandler = unAuthHandler (getContextEntry context) authCheck = fmap (either FailFatal Route) . runExceptT . authHandler - diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index b101d19e..942484b1 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -52,7 +52,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (ServantErr (..), Server, err401, err404, +import Servant.Server (ServantErr (..), Server, err401, err403, err404, serve, serveWithContext, Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) @@ -606,11 +606,10 @@ type instance AuthServerData (AuthProtect "auth") = () genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = - let authHandler = (\req -> - if elem ("Auth", "secret") (requestHeaders req) - then return () - else throwE err401 - ) + let authHandler = \req -> case lookup "Auth" (requestHeaders req) of + Just "secret" -> return () + Just _ -> throwE err403 + Nothing -> throwE err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec @@ -622,6 +621,9 @@ genAuthSpec = do it "returns 401 when missing headers" $ do get "/auth" `shouldRespondWith` 401 + it "returns 403 on wrong passwords" $ do + THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 + it "returns 200 with the right header" $ do THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 From 21822be75ada544e68ac12f514d2ab691ceab826 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 8 Apr 2016 14:49:51 +0800 Subject: [PATCH 11/74] update servant-server's changelog for 0.6.1 --- servant-server/CHANGELOG.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 8b1c25e2..67db6cd0 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,11 @@ +0.6.1 +----- + +* If servers use the `BasicAuth` combinator and receive requests with missing or + invalid credentials, the resulting error responses (401 and 403) could be + overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal` + and the error responses can't be overwritten anymore. + 0.6 --- From f484483d8455ecb38c1a64e999e875a024dca937 Mon Sep 17 00:00:00 2001 From: Luke Cycon Date: Fri, 8 Apr 2016 12:06:44 -0700 Subject: [PATCH 12/74] Re-export `throwE` from module `Servant` Fixes #442 --- servant-server/src/Servant.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-server/src/Servant.hs b/servant-server/src/Servant.hs index 96fd219f..ed24756d 100644 --- a/servant-server/src/Servant.hs +++ b/servant-server/src/Servant.hs @@ -10,8 +10,10 @@ module Servant ( module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), + throwError ) where +import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server From 23fb5e1f568e8810b1e2906d7688d65035508048 Mon Sep 17 00:00:00 2001 From: Jonathan Date: Sun, 10 Apr 2016 11:03:48 -0500 Subject: [PATCH 13/74] Fix code example in haddock of servant-mock The example in the haddock does not coincide with the example code in servant-mock/example/main.hs --- servant-mock/src/Servant/Mock.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 9e9fed8a..8bf9a56e 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -52,7 +52,7 @@ -- @ -- main :: IO () -- main = Network.Wai.Handler.Warp.run 8080 $ --- 'serve' myAPI ('mock' myAPI) +-- 'serve' myAPI ('mock' myAPI Proxy) -- @ module Servant.Mock ( HasMock(..) ) where @@ -90,7 +90,7 @@ class HasServer api context => HasMock api context where -- -- let's say we will start with the frontend, -- -- and hence need a placeholder server -- server :: Server API - -- server = mock api + -- server = mock api Proxy -- @ -- -- What happens here is that @'Server' API@ From ba57d2000895ca223825f785f1cebe2c9d76ebef Mon Sep 17 00:00:00 2001 From: Andrew Gibiansky Date: Tue, 5 Apr 2016 17:30:50 -0700 Subject: [PATCH 14/74] Add ReflectMethod instances for OPTIONS, TRACE, and CONNECT --- servant/src/Servant/API/Verbs.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 1369d9f3..1b898ea6 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -14,7 +14,9 @@ import GHC.Generics (Generic) import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut) + methodPatch, methodPost, methodPut, + methodTrace, methodConnect, + methodOptions) -- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For -- convenience, type synonyms for each verb with a 200 response code are @@ -167,3 +169,12 @@ instance ReflectMethod 'PATCH where instance ReflectMethod 'HEAD where reflectMethod _ = methodHead + +instance ReflectMethod 'OPTIONS where + reflectMethod _ = methodOptions + +instance ReflectMethod 'TRACE where + reflectMethod _ = methodTrace + +instance ReflectMethod 'CONNECT where + reflectMethod _ = methodConnect From 8c778825c71dd6a5d594fada9f855d47a3897f58 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 7 Apr 2016 13:45:15 +0200 Subject: [PATCH 15/74] Improvements and visualization of router structure. * Improves how Routers are built, in particular via the `choice` smart constructors. Static lookups are now used more often. * We now have test cases making sure that certain routers have the same structure. * The router structure can now be visualized for debugging purposes as a tree. The new functions `layout` and `layoutWithContext` do this. --- servant-server/CHANGELOG.md | 9 + servant-server/src/Servant/Server.hs | 72 +++++ servant-server/src/Servant/Server/Internal.hs | 31 +- .../src/Servant/Server/Internal/Router.hs | 170 ++++++++-- .../Server/Internal/RoutingApplication.hs | 25 -- .../test/Servant/Server/RouterSpec.hs | 295 ++++++++++++++++++ servant-server/test/Servant/ServerSpec.hs | 34 +- 7 files changed, 527 insertions(+), 109 deletions(-) create mode 100644 servant-server/test/Servant/Server/RouterSpec.hs diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 67db6cd0..173a84b9 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,12 @@ +0.7 +--- + +* The `Router` type has been changed. There are now more situations where + servers will make use of static lookups to efficiently route the request + to the correct endpoint. Functions `layout` and `layoutWithContext` have + been added to visualize the router layout for debugging purposes. Test + cases for expected router layouts have been added. + 0.6.1 ----- diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8eff9c66..54797c6b 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -18,6 +18,10 @@ module Servant.Server HasServer(..) , Server + -- * Debugging the server layout + , layout + , layoutWithContext + -- * Enter -- $enterDoc @@ -93,6 +97,7 @@ module Servant.Server ) where import Data.Proxy (Proxy) +import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter @@ -131,6 +136,73 @@ serveWithContext p context server = toApplication (runRouter (route p context d) d = Delayed r r r r (\ _ _ _ -> Route server) r = return (Route ()) +-- | The function 'layout' produces a textual description of the internal +-- router layout for debugging purposes. Note that the router layout is +-- determined just by the API, not by the handlers. +-- +-- This function makes certain assumptions about the well-behavedness of +-- the 'HasServer' instances of the combinators which should be ok for the +-- core servant constructions, but might not be satisfied for some other +-- combinators provided elsewhere. It is possible that the function may +-- crash for these. +-- +-- Example: +-- +-- For the following API +-- +-- > type API = +-- > "a" :> "d" :> Get '[JSON] () +-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool +-- > :<|> "c" :> Put '[JSON] Bool +-- > :<|> "a" :> "e" :> Get '[JSON] Int +-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool +-- > :<|> Raw +-- +-- we get the following output: +-- +-- > / +-- > ├─ a/ +-- > │ ├─ d/ +-- > │ │ └─• +-- > │ └─ e/ +-- > │ └─• +-- > ├─ b/ +-- > │ └─ / +-- > │ ├─• +-- > │ ┆ +-- > │ └─• +-- > ├─ c/ +-- > │ └─• +-- > ┆ +-- > └─ +-- +-- Explanation of symbols: +-- +-- [@├@] Normal lines reflect static branching via a table. +-- +-- [@a/@] Nodes reflect static path components. +-- +-- [@─•@] Leaves reflect endpoints. +-- +-- [@\/@] This is a delayed capture of a path component. +-- +-- [@\@] This is a part of the API we do not know anything about. +-- +-- [@┆@] Dashed lines suggest a dynamic choice between the part above +-- and below. If there is a success for fatal failure in the first part, +-- that one takes precedence. If both parts fail, the \"better\" error +-- code will be returned. +-- +layout :: (HasServer layout '[]) => Proxy layout -> Text +layout p = layoutWithContext p EmptyContext + +-- | Variant of 'layout' that takes an additional 'Context'. +layoutWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Text +layoutWithContext p context = routerLayout (route p context d) + where + d = Delayed r r r r (\ _ _ _ -> FailFatal err501) + r = return (Route ()) -- Documentation diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 1733f246..dbf89dd2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -26,11 +26,9 @@ import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure, - lazyRequestBody, pathInfo, + lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) @@ -161,26 +159,23 @@ methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status -> Delayed (ExceptT ServantErr IO a) -> Router -methodRouter method proxy status action = LeafRouter route' +methodRouter method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request - | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status -> Delayed (ExceptT ServantErr IO (Headers h v)) -> Router -methodRouterHeaders method proxy status action = LeafRouter route' +methodRouterHeaders method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH @@ -188,7 +183,6 @@ methodRouterHeaders method proxy status action = LeafRouter route' let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request - | otherwise = respond $ Fail err404 instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status @@ -359,7 +353,7 @@ instance HasServer Raw context where type ServerT Raw m = Application - route Proxy _ rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = RawRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -416,9 +410,10 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy context subserver = StaticRouter $ - M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) context subserver) + route Proxy context subserver = + pathRouter + (cs (symbolVal proxyPath)) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where @@ -465,12 +460,6 @@ instance ( KnownSymbol realm -- * helpers -pathIsEmpty :: Request -> Bool -pathIsEmpty = go . pathInfo - where go [] = True - go [""] = True - go _ = False - ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 6f4ebfbb..04b661a3 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Data.Map (Map) import qualified Data.Map as M +import Data.Monoid import Data.Text (Text) +import qualified Data.Text as T import Network.Wai (Request, Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -13,36 +16,46 @@ type Router = Router' RoutingApplication -- | Internal representation of a router. data Router' a = - WithRequest (Request -> Router) + WithRequest (Request -> Router' a) -- ^ 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 a - -- ^ to be used for routes that match an empty path - | Choice Router Router + | StaticRouter (Map Text (Router' a)) [a] + -- ^ the map contains routers for subpaths (first path component used + -- for lookup and removed afterwards), the list contains handlers + -- for the empty path, to be tried in order + | DynamicRouter (Text -> Router' a) + -- ^ first path component passed to the function and removed afterwards + | RawRouter a + -- ^ to be used for routes we do not know anything about + | Choice (Router' a) (Router' a) -- ^ left-biased choice between two routers deriving Functor --- | Apply a transformation to the response of a `Router`. -tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router -tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) +-- | Smart constructor for a single static path component. +pathRouter :: Text -> Router' a -> Router' a +pathRouter t r = StaticRouter (M.singleton t r) [] + +-- | Smart constructor for a leaf, i.e., a router that expects +-- the empty path. +-- +leafRouter :: a -> Router' a +leafRouter l = StaticRouter M.empty [l] -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- --- * Two static routers can be joined by joining their maps. +-- * Two static routers can be joined by joining their maps +-- and concatenating their leaf-lists. -- * 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 nodes can be reordered. -- choice :: Router -> Router -> Router -choice (StaticRouter table1) (StaticRouter table2) = - StaticRouter (M.unionWith choice table1 table2) +choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = + StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) choice (DynamicRouter fun1) (DynamicRouter fun2) = DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) choice (WithRequest router1) (WithRequest router2) = @@ -51,39 +64,136 @@ choice (WithRequest router1) router2 = WithRequest (\ request -> choice (router1 request) router2) choice router1 (WithRequest router2) = WithRequest (\ request -> choice router1 (router2 request)) +choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 +-- | Datatype used for representing and debugging the +-- structure of a router. Abstracts from the functions +-- being used in the actual router and the handlers at +-- the leaves. +-- +-- Two 'Router's can be structurally compared by computing +-- their 'RouterStructure' using 'routerStructure' and +-- then testing for equality, see 'sameStructure'. +-- +data RouterStructure = + WithRequestStructure RouterStructure + | StaticRouterStructure (Map Text RouterStructure) Int + | DynamicRouterStructure RouterStructure + | RawRouterStructure + | ChoiceStructure RouterStructure RouterStructure + deriving (Eq, Show) + +-- | Compute the structure of a router. +-- +-- Assumes that the request or text being passed +-- in 'WithRequest' or 'DynamicRouter' does not +-- affect the structure of the underlying tree. +-- +routerStructure :: Router' a -> RouterStructure +routerStructure (WithRequest f) = + WithRequestStructure $ + routerStructure (f (error "routerStructure: dummy request")) +routerStructure (StaticRouter m ls) = + StaticRouterStructure (fmap routerStructure m) (length ls) +routerStructure (DynamicRouter f) = + DynamicRouterStructure $ + routerStructure (f (error "routerStructure: dummy text")) +routerStructure (RawRouter _) = + RawRouterStructure +routerStructure (Choice r1 r2) = + ChoiceStructure + (routerStructure r1) + (routerStructure r2) + +-- | Compare the structure of two routers. +-- +sameStructure :: Router' a -> Router' b -> Bool +sameStructure r1 r2 = + routerStructure r1 == routerStructure r2 + +-- | Provide a textual representation of the +-- structure of a router. +-- +routerLayout :: Router' a -> Text +routerLayout router = + T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) + where + mkRouterLayout :: Bool -> RouterStructure -> [Text] + mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r + mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n + mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c RawRouterStructure = + if c then ["├─ "] else ["└─ "] + mkRouterLayout c (ChoiceStructure r1 r2) = + mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2 + + mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text] + mkSubTrees _ [] 0 = [] + mkSubTrees c [] n = + concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c]) + mkSubTrees c [(t, r)] 0 = + mkSubTree c t (mkRouterLayout False r) + mkSubTrees c ((t, r) : trs) n = + mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n + + mkLeaf :: Bool -> [Text] + mkLeaf True = ["├─•","┆"] + mkLeaf False = ["└─•"] + + mkSubTree :: Bool -> Text -> [Text] -> [Text] + mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children + mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children + +-- | Apply a transformation to the response of a `Router`. +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router +tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) + -- | Interpret a router as an application. runRouter :: Router -> RoutingApplication runRouter (WithRequest router) request respond = runRouter (router request) request respond -runRouter (StaticRouter table) request respond = +runRouter (StaticRouter table ls) request respond = case pathInfo request of - first : rest - | Just router <- M.lookup first table + [] -> runChoice ls request respond + -- This case is to handle trailing slashes. + [""] -> runChoice ls request respond + first : rest | Just router <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouter router request' respond _ -> respond $ Fail err404 runRouter (DynamicRouter fun) request respond = case pathInfo request of + [] -> respond $ Fail err404 + -- This case is to handle trailing slashes. + [""] -> respond $ Fail err404 first : rest -> let request' = request { pathInfo = rest } in runRouter (fun first) request' respond - _ -> respond $ Fail err404 -runRouter (LeafRouter app) request respond = app request respond +runRouter (RawRouter app) request respond = app request respond runRouter (Choice r1 r2) request respond = - runRouter r1 request $ \ mResponse1 -> case mResponse1 of - Fail _ -> runRouter r2 request $ \ mResponse2 -> - respond (highestPri mResponse1 mResponse2) - _ -> respond mResponse1 - where - highestPri (Fail e1) (Fail e2) = - if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) - then Fail e2 - else Fail e1 - highestPri (Fail _) y = y - highestPri x _ = x + runChoice [runRouter r1, runRouter r2] request respond +-- | Try a list of routing applications in order. +-- We stop as soon as one fails fatally or succeeds. +-- If all fail normally, we pick the "best" error. +-- +runChoice :: [RoutingApplication] -> RoutingApplication +runChoice [] _request respond = respond (Fail err404) +runChoice [r] request respond = r request respond +runChoice (r : rs) request respond = + r request $ \ response1 -> + case response1 of + Fail _ -> runChoice rs request $ \ response2 -> + respond $ highestPri response1 response2 + _ -> respond response1 + where + highestPri (Fail e1) (Fail e2) = + if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) + then Fail e2 + else Fail e1 + highestPri (Fail _) y = y + highestPri x _ = x -- Priority on HTTP codes. -- diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 7d0c4341..56754c1f 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -35,31 +35,6 @@ toApplication ra request respond = ra request routingRespond routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v --- We currently mix up the order in which we perform checks --- and the priority with which errors are reported. --- --- For example, we perform Capture checks prior to method checks, --- and therefore get 404 before 405. --- --- However, we also perform body checks prior to method checks --- now, and therefore get 415 before 405, which is wrong. --- --- If we delay Captures, but perform method checks eagerly, we --- end up potentially preferring 405 over 404, which is also bad. --- --- So in principle, we'd like: --- --- static routes (can cause 404) --- delayed captures (can cause 404) --- methods (can cause 405) --- authentication and authorization (can cause 401, 403) --- delayed body (can cause 415, 400) --- accept header (can cause 406) --- --- According to the HTTP decision diagram, the priority order --- between HTTP status codes is as follows: --- - -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs new file mode 100644 index 00000000..7ebd1a75 --- /dev/null +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.RouterSpec (spec) where + +import Control.Monad (unless) +import Data.Proxy (Proxy(..)) +import Data.Text (unpack) +import Network.HTTP.Types (Status (..)) +import Network.Wai (Application, responseBuilder) +import Network.Wai.Internal (Response (ResponseBuilder)) +import Test.Hspec +import Test.Hspec.Wai (get, shouldRespondWith, with) +import Servant.API +import Servant.Server +import Servant.Server.Internal + +spec = describe "Servant.Server.Internal.Router" $ do + routerSpec + distributivitySpec + +routerSpec :: Spec +routerSpec = do + let app' :: Application + app' = toApplication $ runRouter router' + + router', router :: Router + router' = tweakResponse (fmap twk) router + router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b + + describe "tweakResponse" . with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + +distributivitySpec :: Spec +distributivitySpec = + describe "choice" $ do + it "distributes endpoints through static paths" $ do + endpoint `shouldHaveSameStructureAs` endpointRef + it "distributes nested routes through static paths" $ do + static `shouldHaveSameStructureAs` staticRef + it "distributes nested routes through dynamic paths" $ do + dynamic `shouldHaveSameStructureAs` dynamicRef + it "properly reorders permuted static paths" $ do + permute `shouldHaveSameStructureAs` permuteRef + it "properly reorders permuted static paths in the presence of Raw in end" $ do + permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef + it "properly reorders permuted static paths in the presence of Raw in beginning" $ do + permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef + it "properly reorders permuted static paths in the presence of Raw in middle" $ do + permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef + it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do + permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do + permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do + permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef + it "properly handles mixing static paths at different levels" $ do + level `shouldHaveSameStructureAs` levelRef + +shouldHaveSameStructureAs :: + (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation +shouldHaveSameStructureAs p1 p2 = + unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ + expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) + +makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router +makeTrivialRouter p = route p EmptyContext d + where + d = Delayed r r r r (\ _ _ _ -> FailFatal err501) + r = return (Route ()) + +type End = Get '[JSON] () + +-- The latter version looks more efficient, +-- but the former should be compiled to the +-- same layout: + +type Endpoint = "a" :> End :<|> "a" :> End +type EndpointRef = "a" :> (End :<|> End) + +endpoint :: Proxy Endpoint +endpoint = Proxy + +endpointRef :: Proxy EndpointRef +endpointRef = Proxy + +-- Again, the latter version looks more efficient, +-- but the former should be compiled to the same +-- layout: + +type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End +type StaticRef = "a" :> ("b" :> End :<|> "c" :> End) + +static :: Proxy Static +static = Proxy + +staticRef :: Proxy StaticRef +staticRef = Proxy + +-- Even for dynamic path components, we expect the +-- router to simplify the layout, because captures +-- are delayed and only actually performed once +-- reaching an endpoint. So the former version and +-- the latter should be compiled to the same router +-- structure: + +type Dynamic = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "bar" Bool :> "c" :> End + :<|> "a" :> Capture "baz" Char :> "d" :> End + +type DynamicRef = + "a" :> Capture "anything" () :> + ("b" :> End :<|> "c" :> End :<|> "d" :> End) + +dynamic :: Proxy Dynamic +dynamic = Proxy + +dynamicRef :: Proxy DynamicRef +dynamicRef = Proxy + +-- A more complicated example of static route reordering. +-- All the permuted paths should be correctly grouped, +-- so both 'Permute' and 'PermuteRef' should compile to +-- the same layout: + +type Permute = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permute :: Proxy Permute +permute = Proxy + +permuteRef :: Proxy PermuteRef +permuteRef = Proxy + +-- Adding a 'Raw' in one of the ends should have minimal +-- effect on the grouping. + +type PermuteRawEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> Raw + +type PermuteRawEndRef = PermuteRef :<|> Raw + +type PermuteRawBegin = + Raw + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawBeginRef = Raw :<|> PermuteRef + +permuteRawBegin :: Proxy PermuteRawBegin +permuteRawBegin = Proxy + +permuteRawBeginRef :: Proxy PermuteRawBeginRef +permuteRawBeginRef = Proxy + +permuteRawEnd :: Proxy PermuteRawEnd +permuteRawEnd = Proxy + +permuteRawEndRef :: Proxy PermuteRawEndRef +permuteRawEndRef = Proxy + +-- Adding a 'Raw' in the middle will disrupt grouping, +-- because we commute things past a 'Raw'. But the two +-- halves should still be grouped. + +type PermuteRawMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> Raw + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawMiddleRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> "a" :> "c" :> End + :<|> Raw + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permuteRawMiddle :: Proxy PermuteRawMiddle +permuteRawMiddle = Proxy + +permuteRawMiddleRef :: Proxy PermuteRawMiddleRef +permuteRawMiddleRef = Proxy + +-- Adding an endpoint at the top-level in various places +-- is also somewhat critical for grouping, but it should +-- not disrupt grouping at all, even if it is placed in +-- the middle. + +type PermuteEndEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> End + +type PermuteEndBegin = + End + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndRef = PermuteRef :<|> End + +permuteEndEnd :: Proxy PermuteEndEnd +permuteEndEnd = Proxy + +permuteEndBegin :: Proxy PermuteEndBegin +permuteEndBegin = Proxy + +permuteEndMiddle :: Proxy PermuteEndMiddle +permuteEndMiddle = Proxy + +permuteEndRef :: Proxy PermuteEndRef +permuteEndRef = Proxy + +-- An API with routes on different nesting levels that +-- is composed out of different fragments should still +-- be reordered correctly. + +type LevelFragment1 = + "a" :> "b" :> End + :<|> "a" :> End + +type LevelFragment2 = + "b" :> End + :<|> "a" :> "c" :> End + :<|> End + +type Level = LevelFragment1 :<|> LevelFragment2 + +type LevelRef = + "a" :> ("b" :> End :<|> "c" :> End :<|> End) + :<|> "b" :> End + :<|> End + +level :: Proxy Level +level = Proxy + +levelRef :: Proxy LevelRef +levelRef = Proxy diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 942484b1..d210ca55 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -13,9 +13,6 @@ module Servant.ServerSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) @@ -36,8 +33,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType, parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, - responseBuilder, responseLBS) -import Network.Wai.Internal (Response (ResponseBuilder)) + responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) @@ -66,11 +62,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Server.Internal.RoutingApplication - (toApplication, RouteResult(..)) -import Servant.Server.Internal.Router - (tweakResponse, runRouter, - Router, Router'(LeafRouter)) import Servant.Server.Internal.Context (NamedContext(..)) @@ -94,7 +85,6 @@ spec = do rawSpec alternativeSpec responseHeadersSpec - routerSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -482,28 +472,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 --- }}} ------------------------------------------------------------------------------- --- * routerSpec {{{ ------------------------------------------------------------------------------- -routerSpec :: Spec -routerSpec = do - describe "Servant.Server.Internal.Router" $ do - let app' :: Application - app' = toApplication $ runRouter router' - - router', router :: Router - router' = tweakResponse (twk <$>) router - router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - - twk :: Response -> Response - twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b - twk b = b - - describe "tweakResponse" . with (return app') $ do - it "calls f on route result" $ do - get "" `shouldRespondWith` 202 - -- }}} ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ From aa71099ffd515daebe2d9c6521b84334d091c9a0 Mon Sep 17 00:00:00 2001 From: Jonathan Date: Mon, 11 Apr 2016 08:54:38 -0500 Subject: [PATCH 16/74] Update Mock.hs --- servant-mock/src/Servant/Mock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 8bf9a56e..881d9e84 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -36,7 +36,7 @@ -- and call 'mock', which has the following type: -- -- @ --- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api +-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api -- @ -- -- What this says is, given some API type @api@ that it knows it can From 353c1798e10284f8a682151c1e584705abbf66e1 Mon Sep 17 00:00:00 2001 From: Luke Cycon Date: Mon, 11 Apr 2016 11:19:18 -0700 Subject: [PATCH 17/74] Update some docs and the changelogs --- doc/tutorial/Authentication.lhs | 11 ++++++----- servant-docs/CHANGELOG.md | 5 +++++ servant-server/CHANGELOG.md | 5 +++++ servant/CHANGELOG.md | 5 +++++ 4 files changed, 21 insertions(+), 5 deletions(-) diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index b9117e55..b699b46a 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -44,7 +44,7 @@ You can use this combinator to protect an API as follows: module Authentication where -import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT) import Data.Aeson (ToJSON) import Data.ByteString (ByteString) import Data.Map (Map, fromList) @@ -59,6 +59,7 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, Get, JSON) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant (throwError) import Servant.Server (BasicAuthCheck (BasicAuthCheck), BasicAuthResult( Authorized , Unauthorized @@ -173,7 +174,7 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`: ```haskell -- | We need to supply our handlers with the right Context. In this case, -- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value --- tagged with "foo-tag" This context is then supplied to 'server' and threaded +-- tagged with "foo-tag" This context is then supplied to 'server' and threaded -- to the BasicAuth HasServer handlers. basicAuthServerContext :: Context (BasicAuthCheck User ': '[]) basicAuthServerContext = authCheck :. EmptyContext @@ -274,7 +275,7 @@ database = fromList [ ("key1", Account "Anne Briggs") -- This is our bespoke (and bad) authentication logic. lookupAccount :: ByteString -> ExceptT ServantErr IO Account lookupAccount key = case Map.lookup key database of - Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) + Nothing -> throwError (err403 { errBody = "Invalid Cookie" }) Just usr -> return usr ``` @@ -289,7 +290,7 @@ method: authHandler :: AuthHandler Request Account authHandler = let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of - Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just authCookieKey -> lookupAccount authCookieKey in mkAuthHandler handler ``` @@ -329,7 +330,7 @@ We now construct the `Context` for our server, allowing us to instantiate a value of type `Server AuthGenAPI`, in addition to the server value: ```haskell --- | The context that will be made available to request handlers. We supply the +-- | The context that will be made available to request handlers. We supply the -- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance -- of 'AuthProtect' can extract the handler and run it on the request. genAuthServerContext :: Context (AuthHandler Request Account ': '[]) diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 44ce0696..555fb8b1 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Export `throwError` from module `Servant` + 0.5 ---- diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 8b1c25e2..64498f6a 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Export `throwError` from module `Servant` + 0.6 --- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index efeecf66..fc147054 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Export `throwError` from module `Servant` + 0.5 ---- From b84016e19101683d8dfa641e43ece5110a6612a6 Mon Sep 17 00:00:00 2001 From: Luke Cycon Date: Mon, 11 Apr 2016 21:54:04 -0700 Subject: [PATCH 18/74] Sort out this changelog situation --- servant-docs/CHANGELOG.md | 2 +- servant/CHANGELOG.md | 5 ----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 555fb8b1..3fed9973 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,7 +1,7 @@ HEAD ---- -* Export `throwError` from module `Servant` +* Use `throwError` instead of `throwE` in documentation 0.5 ---- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index fc147054..efeecf66 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,8 +1,3 @@ -HEAD ----- - -* Export `throwError` from module `Servant` - 0.5 ---- From 21546991af2a62d834faf766c83c9095554330ca Mon Sep 17 00:00:00 2001 From: Luke Cycon Date: Thu, 7 Apr 2016 14:34:23 -0700 Subject: [PATCH 19/74] Introduce a `Handler` alias for `ExceptT ServantErr IO` Fixes #434 --- doc/tutorial/Authentication.lhs | 21 +++-- doc/tutorial/Server.lhs | 86 +++++++++---------- servant-client/test/Servant/ClientSpec.hs | 2 +- servant-mock/src/Servant/Mock.hs | 4 +- servant-server/example/greet.hs | 2 +- servant-server/src/Servant/Server.hs | 1 + .../src/Servant/Server/Experimental/Auth.hs | 9 +- servant-server/src/Servant/Server/Internal.hs | 19 ++-- .../Server/Internal/RoutingApplication.hs | 4 +- .../src/Servant/Server/Internal/ServantErr.hs | 63 +++++++------- .../test/Servant/Server/Internal/EnterSpec.hs | 2 +- .../test/Servant/Server/StreamingSpec.hs | 4 +- .../test/Servant/Server/UsingContextSpec.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 13 +-- 14 files changed, 115 insertions(+), 117 deletions(-) diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index b699b46a..5b1c8d19 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -44,7 +44,6 @@ You can use this combinator to protect an API as follows: module Authentication where -import Control.Monad.Trans.Except (ExceptT) import Data.Aeson (ToJSON) import Data.ByteString (ByteString) import Data.Map (Map, fromList) @@ -66,7 +65,7 @@ import Servant.Server (BasicAuthCheck (BasicAuthCheck), ), Context ((:.), EmptyContext), err401, err403, errBody, Server, - ServantErr, serveWithContext) + serveWithContext, Handler) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Servant.Server.Experimental.Auth() @@ -118,22 +117,22 @@ or dictated the structure of a response (e.g. a `Capture` param is pulled from the request path). Now consider an API resource protected by basic authentication. Once the required `WWW-Authenticate` header is checked, we need to verify the username and password. But how? One solution would be to force an -API author to provide a function of type `BasicAuthData -> ExceptT ServantErr IO User` +API author to provide a function of type `BasicAuthData -> Handler User` and servant should use this function to authenticate a request. Unfortunately this didn't work prior to `0.5` because all of servant's machinery was engineered around the idea that each combinator can extract information from only the request. We cannot extract the function -`BasicAuthData -> ExceptT ServantErr IO User` from a request! Are we doomed? +`BasicAuthData -> Handler User` from a request! Are we doomed? Servant `0.5` introduced `Context` to handle this. The type machinery is beyond the scope of this tutorial, but the idea is simple: provide some data to the `serve` function, and that data is propagated to the functions that handle each combinator. Using `Context`, we can supply a function of type -`BasicAuthData -> ExceptT ServantErr IO User` to the `BasicAuth` combinator +`BasicAuthData -> Handler User` to the `BasicAuth` combinator handler. This will allow the handler to check authentication and return a `User` to downstream handlers if successful. -In practice we wrap `BasicAuthData -> ExceptT ServantErr IO` into a slightly +In practice we wrap `BasicAuthData -> Handler` into a slightly different function to better capture the semantics of basic authentication: ``` haskell ignore @@ -247,7 +246,7 @@ your feedback! ### What is Generalized Authentication? **TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints -you want protected and then supply a function `Request -> ExceptT IO ServantErr user` +you want protected and then supply a function `Request -> Handler user` which we run anytime a request matches a protected endpoint. It precisely solves the "I just need to protect these endpoints with a function that does some complicated business logic" and nothing more. Behind the scenes we use a type @@ -273,19 +272,19 @@ database = fromList [ ("key1", Account "Anne Briggs") -- | A method that, when given a password, will return a Account. -- This is our bespoke (and bad) authentication logic. -lookupAccount :: ByteString -> ExceptT ServantErr IO Account +lookupAccount :: ByteString -> Handler Account lookupAccount key = case Map.lookup key database of Nothing -> throwError (err403 { errBody = "Invalid Cookie" }) Just usr -> return usr ``` For generalized authentication, servant exposes the `AuthHandler` type, -which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's +which is used to wrap the `Request -> Handler user` logic. Let's create a value of type `AuthHandler Request Account` using the above `lookupAccount` method: ```haskell --- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account +-- | The auth handler wraps a function from Request -> Handler Account -- we look for a Cookie and pass the value of the cookie to `lookupAccount`. authHandler :: AuthHandler Request Account authHandler = @@ -380,7 +379,7 @@ forward: 2. choose a application-specific data type used by your server when authentication is successful (in our case this was `User`). 3. Create a value of `AuthHandler Request User` which encapsulates the -authentication logic (`Request -> ExceptT IO ServantErr User`). This function +authentication logic (`Request -> Handler User`). This function will be executed everytime a request matches a protected route. 4. Provide an instance of the `AuthServerData` type family, specifying your application-specific data type returned when authentication is successful (in diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index bd84b8a0..af3fe17d 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -111,11 +111,11 @@ corresponding API type. The first thing to know about the `Server` type family is that behind the scenes it will drive the routing, letting you focus only on the business logic. The second thing to know is that for each endpoint, your handlers will -by default run in the `ExceptT ServantErr IO` monad. This is overridable very +by default run in the `Handler` monad. This is overridable very easily, as explained near the end of this guide. Third thing, the type of the value returned in that monad must be the same as the second argument of the HTTP method combinator used for the corresponding endpoint. In our case, it -means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well, +means we must provide a handler of type `Handler [User]`. Well, we have a monad, let's just `return` our list: ``` haskell @@ -269,15 +269,15 @@ server3 = position :<|> hello :<|> marketing - where position :: Int -> Int -> ExceptT ServantErr IO Position + where position :: Int -> Int -> Handler Position position x y = return (Position x y) - hello :: Maybe String -> ExceptT ServantErr IO HelloMessage + hello :: Maybe String -> Handler HelloMessage hello mname = return . HelloMessage $ case mname of Nothing -> "Hello, anonymous coward" Just n -> "Hello, " ++ n - marketing :: ClientInfo -> ExceptT ServantErr IO Email + marketing :: ClientInfo -> Handler Email marketing clientinfo = return (emailForClient clientinfo) ``` @@ -307,7 +307,7 @@ $ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo. For reference, here's a list of some combinators from **servant**: - > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO `. + > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `Handler `. > - `Capture "something" a` becomes an argument of type `a`. > - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. > - `QueryFlag "something"` gets turned into an argument of type `Bool`. @@ -601,11 +601,10 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons # or just point your browser to http://localhost:8081/persons ``` -## The `ExceptT ServantErr IO` monad +## The `Handler` monad -At the heart of the handlers is the monad they run in, namely `ExceptT -ServantErr IO` -([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)). +At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO` +([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)), which is aliased as `Handler`. One might wonder: why this monad? The answer is that it is the simplest monad with the following properties: @@ -621,7 +620,7 @@ Let's recall some definitions. newtype ExceptT e m a = ExceptT (m (Either e a)) ``` -In short, this means that a handler of type `ExceptT ServantErr IO a` is simply +In short, this means that a handler of type `Handler a` is simply equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO action that either returns an error or a result. @@ -688,7 +687,7 @@ module. If you want to use these values but add a body or some headers, just use record update syntax: ``` haskell -failingHandler :: ExceptT ServantErr IO () +failingHandler :: Handler () failingHandler = throwError myerr where myerr :: ServantErr @@ -826,11 +825,11 @@ However, you have to be aware that this has an effect on the type of the corresponding `Server`: ``` haskell ignore -Server UserAPI3 = (Int -> ExceptT ServantErr IO User) - :<|> (Int -> ExceptT ServantErr IO ()) +Server UserAPI3 = (Int -> Handler User) + :<|> (Int -> Handler ()) -Server UserAPI4 = Int -> ( ExceptT ServantErr IO User - :<|> ExceptT ServantErr IO () +Server UserAPI4 = Int -> ( Handler User + :<|> Handler () ) ``` @@ -842,10 +841,10 @@ computations in `ExceptT`, with no arguments. In other words: server8 :: Server UserAPI3 server8 = getUser :<|> deleteUser - where getUser :: Int -> ExceptT ServantErr IO User + where getUser :: Int -> Handler User getUser _userid = error "..." - deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser :: Int -> Handler () deleteUser _userid = error "..." -- notice how getUser and deleteUser @@ -854,10 +853,10 @@ server8 = getUser :<|> deleteUser server9 :: Server UserAPI4 server9 userid = getUser userid :<|> deleteUser userid - where getUser :: Int -> ExceptT ServantErr IO User + where getUser :: Int -> Handler User getUser = error "..." - deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser :: Int -> Handler () deleteUser = error "..." ``` @@ -905,23 +904,23 @@ type UsersAPI = usersServer :: Server UsersAPI usersServer = getUsers :<|> newUser :<|> userOperations - where getUsers :: ExceptT ServantErr IO [User] + where getUsers :: Handler [User] getUsers = error "..." - newUser :: User -> ExceptT ServantErr IO () + newUser :: User -> Handler () newUser = error "..." userOperations userid = viewUser userid :<|> updateUser userid :<|> deleteUser userid where - viewUser :: Int -> ExceptT ServantErr IO User + viewUser :: Int -> Handler User viewUser = error "..." - updateUser :: Int -> User -> ExceptT ServantErr IO () + updateUser :: Int -> User -> Handler () updateUser = error "..." - deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser :: Int -> Handler () deleteUser = error "..." ``` @@ -940,23 +939,23 @@ data Product = Product { productId :: Int } productsServer :: Server ProductsAPI productsServer = getProducts :<|> newProduct :<|> productOperations - where getProducts :: ExceptT ServantErr IO [Product] + where getProducts :: Handler [Product] getProducts = error "..." - newProduct :: Product -> ExceptT ServantErr IO () + newProduct :: Product -> Handler () newProduct = error "..." productOperations productid = viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid where - viewProduct :: Int -> ExceptT ServantErr IO Product + viewProduct :: Int -> Handler Product viewProduct = error "..." - updateProduct :: Int -> Product -> ExceptT ServantErr IO () + updateProduct :: Int -> Product -> Handler () updateProduct = error "..." - deleteProduct :: Int -> ExceptT ServantErr IO () + deleteProduct :: Int -> Handler () deleteProduct = error "..." ``` @@ -985,11 +984,11 @@ type APIFor a i = -- Build the appropriate 'Server' -- given the handlers of the right type. -serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's - -> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a' - -> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' - -> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id - -> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id +serverFor :: Handler [a] -- handler for listing of 'a's + -> (a -> Handler ()) -- handler for adding an 'a' + -> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i' + -> (i -> a -> Handler ()) -- updating an 'a' with given id + -> (i -> Handler ()) -- deleting an 'a' given its id -> Server (APIFor a i) serverFor = error "..." -- implementation left as an exercise. contact us on IRC @@ -998,12 +997,11 @@ serverFor = error "..." ## Using another monad for your handlers -Remember how `Server` turns combinators for HTTP methods into `ExceptT -ServantErr IO`? Well, actually, there's more to that. `Server` is actually a +Remember how `Server` turns combinators for HTTP methods into `Handler`? Well, actually, there's more to that. `Server` is actually a simple type synonym. ``` haskell ignore -type Server api = ServerT api (ExceptT ServantErr IO) +type Server api = ServerT api Handler ``` `ServerT` is the actual type family that computes the required types for the @@ -1036,12 +1034,11 @@ listToMaybeNat = Nat listToMaybe -- from Data.Maybe (`Nat` comes from "natural transformation", in case you're wondering.) -So if you want to write handlers using another monad/type than `ExceptT -ServantErr IO`, say the `Reader String` monad, the first thing you have to +So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to prepare is a function: ``` haskell ignore -readerToHandler :: Reader String :~> ExceptT ServantErr IO +readerToHandler :: Reader String :~> Handler ``` Let's start with `readerToHandler'`. We obviously have to run the `Reader` @@ -1050,10 +1047,10 @@ from that and can then just `return` it into `ExceptT`. We can then just wrap that function with the `Nat` constructor to make it have the fancier type. ``` haskell -readerToHandler' :: forall a. Reader String a -> ExceptT ServantErr IO a +readerToHandler' :: forall a. Reader String a -> Handler a readerToHandler' r = return (runReader r "hi") -readerToHandler :: Reader String :~> ExceptT ServantErr IO +readerToHandler :: Reader String :~> Handler readerToHandler = Nat readerToHandler' ``` @@ -1077,8 +1074,7 @@ readerServerT = a :<|> b ``` We unfortunately can't use `readerServerT` as an argument of `serve`, because -`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT -ServantErr IO`. But there's a simple solution to this. +`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this. ### Enter `enter` diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2263e9e2..17048593 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -355,7 +355,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a, + WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => Proxy api -> WrappedApi diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 881d9e84..bb999386 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -97,8 +97,8 @@ class HasServer api context => HasMock api context where -- actually "means" 2 request handlers, of the following types: -- -- @ - -- getUser :: ExceptT ServantErr IO User - -- getBook :: ExceptT ServantErr IO Book + -- getUser :: Handler User + -- getBook :: Handler Book -- @ -- -- So under the hood, 'mock' uses the 'IO' bit to generate diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 3fda367d..67819eb0 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 'ExceptT ServantErr IO' monad. +-- Each handler runs in the 'Handler' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 54797c6b..b2cf7a66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -17,6 +17,7 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) , Server + , Handler -- * Debugging the server layout , layout diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index d40bbd20..86d4dc03 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -12,8 +12,7 @@ module Servant.Server.Experimental.Auth where -import Control.Monad.Trans.Except (ExceptT, - runExceptT) +import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -28,7 +27,7 @@ import Servant.Server.Internal (HasContextEntry, import Servant.Server.Internal.Router (Router' (WithRequest)) import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), addAuthCheck) -import Servant.Server.Internal.ServantErr (ServantErr) +import Servant.Server.Internal.ServantErr (ServantErr, Handler) -- * General Auth @@ -42,11 +41,11 @@ type family AuthServerData a :: * -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler - { unAuthHandler :: r -> ExceptT ServantErr IO usr } + { unAuthHandler :: r -> Handler usr } deriving (Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr +mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr mkAuthHandler = AuthHandler -- | Known orphan instance. diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index dbf89dd2..eb3ca19c 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -22,7 +22,6 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServantErr ) where -import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL @@ -73,7 +72,7 @@ class HasServer layout context where route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router -type Server layout = ServerT layout (ExceptT ServantErr IO) +type Server layout = ServerT layout Handler -- * Instances @@ -112,7 +111,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont -- > -- > server :: Server MyApi -- > server = getBook --- > where getBook :: Text -> ExceptT ServantErr IO Book +-- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) => HasServer (Capture capture a :> sublayout) context where @@ -157,7 +156,7 @@ acceptCheck proxy accH methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO a) + -> Delayed (Handler a) -> Router methodRouter method proxy status action = leafRouter route' where @@ -171,7 +170,7 @@ methodRouter method proxy status action = leafRouter route' methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO (Headers h v)) + -> Delayed (Handler (Headers h v)) -> Router methodRouterHeaders method proxy status action = leafRouter route' where @@ -223,7 +222,7 @@ instance OVERLAPPING_ -- > -- > server :: Server MyApi -- > server = viewReferer --- > where viewReferer :: Referer -> ExceptT ServantErr IO referer +-- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (Header sym a :> sublayout) context where @@ -254,7 +253,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) @@ -291,7 +290,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (QueryParams sym a :> sublayout) context where @@ -322,7 +321,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > -- > server :: Server MyApi -- > server = getBooks --- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] +-- > where getBooks :: Bool -> Handler [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... instance (KnownSymbol sym, HasServer sublayout context) => HasServer (QueryFlag sym :> sublayout) context where @@ -379,7 +378,7 @@ instance HasServer Raw context where -- > -- > server :: Server MyApi -- > server = postBook --- > where postBook :: Book -> ExceptT ServantErr IO Book +-- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer sublayout context ) => HasServer (ReqBody list a :> sublayout) context where diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 56754c1f..99def4b8 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -8,7 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (runExceptT) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () @@ -222,7 +222,7 @@ runDelayed Delayed{..} = -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. -runAction :: Delayed (ExceptT ServantErr IO a) +runAction :: Delayed (Handler a) -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 4e646a7a..b60f042c 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -4,6 +4,7 @@ module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) +import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) @@ -18,6 +19,8 @@ data ServantErr = ServantErr { errHTTPCode :: Int instance Exception ServantErr +type Handler = ExceptT ServantErr IO + responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where @@ -27,7 +30,7 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr @@ -41,7 +44,7 @@ err300 = ServantErr { errHTTPCode = 300 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err301 -- err301 :: ServantErr @@ -55,7 +58,7 @@ err301 = ServantErr { errHTTPCode = 301 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err302 -- err302 :: ServantErr @@ -69,7 +72,7 @@ err302 = ServantErr { errHTTPCode = 302 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err303 -- err303 :: ServantErr @@ -83,7 +86,7 @@ err303 = ServantErr { errHTTPCode = 303 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err304 -- err304 :: ServantErr @@ -97,7 +100,7 @@ err304 = ServantErr { errHTTPCode = 304 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err305 -- err305 :: ServantErr @@ -111,7 +114,7 @@ err305 = ServantErr { errHTTPCode = 305 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err307 -- err307 :: ServantErr @@ -125,7 +128,7 @@ err307 = ServantErr { errHTTPCode = 307 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr @@ -139,7 +142,7 @@ err400 = ServantErr { errHTTPCode = 400 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr @@ -153,7 +156,7 @@ err401 = ServantErr { errHTTPCode = 401 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr @@ -167,7 +170,7 @@ err402 = ServantErr { errHTTPCode = 402 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err403 { errBody = "Please login first." } -- err403 :: ServantErr @@ -181,7 +184,7 @@ err403 = ServantErr { errHTTPCode = 403 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr @@ -195,7 +198,7 @@ err404 = ServantErr { errHTTPCode = 404 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr @@ -209,7 +212,7 @@ err405 = ServantErr { errHTTPCode = 405 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err406 -- err406 :: ServantErr @@ -223,7 +226,7 @@ err406 = ServantErr { errHTTPCode = 406 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err407 -- err407 :: ServantErr @@ -237,7 +240,7 @@ err407 = ServantErr { errHTTPCode = 407 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr @@ -251,7 +254,7 @@ err409 = ServantErr { errHTTPCode = 409 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr @@ -265,7 +268,7 @@ err410 = ServantErr { errHTTPCode = 410 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err411 -- err411 :: ServantErr @@ -279,7 +282,7 @@ err411 = ServantErr { errHTTPCode = 411 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr @@ -293,7 +296,7 @@ err412 = ServantErr { errHTTPCode = 412 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr @@ -307,7 +310,7 @@ err413 = ServantErr { errHTTPCode = 413 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr @@ -321,7 +324,7 @@ err414 = ServantErr { errHTTPCode = 414 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr @@ -335,7 +338,7 @@ err415 = ServantErr { errHTTPCode = 415 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr @@ -349,7 +352,7 @@ err416 = ServantErr { errHTTPCode = 416 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr @@ -363,7 +366,7 @@ err417 = ServantErr { errHTTPCode = 417 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr @@ -377,7 +380,7 @@ err500 = ServantErr { errHTTPCode = 500 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr @@ -391,7 +394,7 @@ err501 = ServantErr { errHTTPCode = 501 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr @@ -405,7 +408,7 @@ err502 = ServantErr { errHTTPCode = 502 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr @@ -419,7 +422,7 @@ err503 = ServantErr { errHTTPCode = 503 -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr @@ -433,7 +436,7 @@ err504 = ServantErr { errHTTPCode = 504 -- -- Example usage: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 8b450377..1591e987 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -34,7 +34,7 @@ combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> ExceptT ServantErr IO +fReader :: Reader String :~> Handler fReader = generalizeNat C.. (runReaderTNat "hi") readerServer :: Server ReaderAPI diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs index 3752df49..ed289257 100644 --- a/servant-server/test/Servant/Server/StreamingSpec.hs +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -9,7 +9,7 @@ module Servant.Server.StreamingSpec where import Control.Concurrent -import Control.Exception +import Control.Exception hiding (Handler) import Control.Monad.IO.Class import Control.Monad.Trans.Except import qualified Data.ByteString as Strict @@ -66,7 +66,7 @@ spec = do -- - receives the first chunk -- - notifies serverReceivedFirstChunk -- - receives the rest of the request - let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent + let handler :: Lazy.ByteString -> Handler NoContent handler input = liftIO $ do let prefix = Lazy.take 3 input prefix `shouldBe` "foo" diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs index 33b04125..1f9c3328 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -25,7 +25,7 @@ spec = do type OneEntryAPI = ExtractFromContext :> Get '[JSON] String -testServer :: String -> ExceptT ServantErr IO String +testServer :: String -> Handler String testServer s = return s oneEntryApp :: Application diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index d210ca55..5b4154d7 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -14,7 +14,7 @@ module Servant.ServerSpec where import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Except (throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Conversion () @@ -48,8 +48,9 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (ServantErr (..), Server, err401, err403, err404, - serve, serveWithContext, Context((:.), EmptyContext)) +import Servant.Server (ServantErr (..), Server, Handler, err401, err403, + err404, serve, serveWithContext, + Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import qualified Test.Hspec.Wai as THW @@ -180,7 +181,7 @@ verbSpec = describe "Servant.API.Verb" $ do type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> ExceptT ServantErr IO Animal +captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety @@ -336,11 +337,11 @@ headerApi = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> ExceptT ServantErr IO () + let expectsInt :: Maybe Int -> Handler () expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> ExceptT ServantErr IO () + let expectsString :: Maybe String -> Handler () expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" From d4c6f67cf09f9eeb625ac7391b31ff3c2cd716a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 12 Apr 2016 13:58:00 +0800 Subject: [PATCH 20/74] servant-server: update changelog --- servant-server/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 1414998f..85a6d9e1 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -7,6 +7,7 @@ been added to visualize the router layout for debugging purposes. Test cases for expected router layouts have been added. * Export `throwError` from module `Servant` +* Add `Handler` type synonym 0.6.1 ----- From b1a6d8884565f5d577f3b8f7378208c20f8b2417 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Sat, 9 Apr 2016 15:42:57 +0200 Subject: [PATCH 21/74] Revise the Router type to allow proper sharing. We've previously used functions in the Router type to provide information for subrouters. But this accesses the Requests too early, and breaks sharing of the router structure in general, causing the Router or large parts of the Router to be recomputed on every request. We now do not use functions anymore, and properly compute all static parts of the router first, and gain access to the request only in Delayed. This also turns the code used within Delayed into a proper monad now called DelayedIO, making some of the code using it a bit nicer. --- servant-server/CHANGELOG.md | 9 +- servant-server/src/Servant/Server.hs | 22 +- .../src/Servant/Server/Experimental/Auth.hs | 18 +- servant-server/src/Servant/Server/Internal.hs | 111 ++++----- .../src/Servant/Server/Internal/BasicAuth.hs | 11 +- .../src/Servant/Server/Internal/Router.hs | 151 ++++++------ .../Server/Internal/RoutingApplication.hs | 222 ++++++++++-------- .../test/Servant/Server/RouterSpec.hs | 12 +- .../UsingContextSpec/TestCombinators.hs | 3 +- servant-server/test/Servant/ServerSpec.hs | 2 +- 10 files changed, 292 insertions(+), 269 deletions(-) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 85a6d9e1..736c36bd 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,10 +1,11 @@ 0.7 --- -* The `Router` type has been changed. There are now more situations where - servers will make use of static lookups to efficiently route the request - to the correct endpoint. Functions `layout` and `layoutWithContext` have - been added to visualize the router layout for debugging purposes. Test +* The `Router` type has been changed. Static router tables should now + be properly shared between requests, drastically increasing the + number of situations where servers will be able to route requests + efficiently. Functions `layout` and `layoutWithContext` have been + added to visualize the router layout for debugging purposes. Test cases for expected router layouts have been added. * Export `throwError` from module `Servant` * Add `Handler` type synonym diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b2cf7a66..bbba7c1b 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -132,21 +132,13 @@ serve p = serveWithContext p EmptyContext serveWithContext :: (HasServer layout context) => Proxy layout -> Context context -> Server layout -> Application -serveWithContext p context server = toApplication (runRouter (route p context d)) - where - d = Delayed r r r r (\ _ _ _ -> Route server) - r = return (Route ()) +serveWithContext p context server = + toApplication (runRouter (route p context (emptyDelayed (Route server)))) -- | The function 'layout' produces a textual description of the internal -- router layout for debugging purposes. Note that the router layout is -- determined just by the API, not by the handlers. -- --- This function makes certain assumptions about the well-behavedness of --- the 'HasServer' instances of the combinators which should be ok for the --- core servant constructions, but might not be satisfied for some other --- combinators provided elsewhere. It is possible that the function may --- crash for these. --- -- Example: -- -- For the following API @@ -168,7 +160,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d) -- > │ └─ e/ -- > │ └─• -- > ├─ b/ --- > │ └─ / +-- > │ └─ / -- > │ ├─• -- > │ ┆ -- > │ └─• @@ -185,7 +177,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d) -- -- [@─•@] Leaves reflect endpoints. -- --- [@\/@] This is a delayed capture of a path component. +-- [@\/@] This is a delayed capture of a path component. -- -- [@\@] This is a part of the API we do not know anything about. -- @@ -200,10 +192,8 @@ layout p = layoutWithContext p EmptyContext -- | Variant of 'layout' that takes an additional 'Context'. layoutWithContext :: (HasServer layout context) => Proxy layout -> Context context -> Text -layoutWithContext p context = routerLayout (route p context d) - where - d = Delayed r r r r (\ _ _ _ -> FailFatal err501) - r = return (Route ()) +layoutWithContext p context = + routerLayout (route p context (emptyDelayed (FailFatal err501))) -- Documentation diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index 86d4dc03..fd38ff1e 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -12,6 +12,7 @@ module Servant.Server.Experimental.Auth where +import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) @@ -24,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry, HasServer, ServerT, getContextEntry, route) -import Servant.Server.Internal.Router (Router' (WithRequest)) -import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), - addAuthCheck) -import Servant.Server.Internal.ServantErr (ServantErr, Handler) +import Servant.Server.Internal.RoutingApplication (addAuthCheck, + delayedFailFatal, + DelayedIO, + withRequest) +import Servant.Server.Internal.ServantErr (Handler) -- * General Auth @@ -57,8 +59,10 @@ instance ( HasServer api context type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where + authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) - authCheck = fmap (either FailFatal Route) . runExceptT . authHandler + authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag)) + authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index eb3ca19c..2d378c9d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -22,6 +22,7 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServantErr ) where +import Control.Monad.Trans (liftIO) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL @@ -70,7 +71,11 @@ import Servant.Server.Internal.ServantErr class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router + route :: + Proxy layout + -> Context context + -> Delayed env (Server layout) + -> Router env type Server layout = ServerT layout Handler @@ -92,7 +97,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) - (route pb context ((\ (_ :<|> b) -> b) <$> server)) + (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -120,12 +125,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) a -> ServerT sublayout m route Proxy context d = - DynamicRouter $ \ first -> + CaptureRouter $ route (Proxy :: Proxy sublayout) context - (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of - Nothing -> return $ Fail err400 - Just v -> return $ Route v + (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of + Nothing -> delayedFail err400 + Just v -> return v ) allowedMethodHead :: Method -> Request -> Bool @@ -144,41 +149,41 @@ processMethodRouter handleA status method headers request = case handleA of bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) -methodCheck :: Method -> Request -> IO (RouteResult ()) +methodCheck :: Method -> Request -> DelayedIO () methodCheck method request - | allowedMethod method request = return $ Route () - | otherwise = return $ Fail err405 + | allowedMethod method request = return () + | otherwise = delayedFail err405 -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) +acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ FailFatal err406 + | canHandleAcceptH proxy (AcceptHeader accH) = return () + | otherwise = delayedFailFatal err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status - -> Delayed (Handler a) - -> Router + -> Delayed env (Handler a) + -> Router env methodRouter method proxy status action = leafRouter route' where - route' request respond = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status - -> Delayed (Handler (Headers h v)) - -> Router + -> Delayed env (Handler (Headers h v)) + -> Router env methodRouterHeaders method proxy status action = leafRouter route' where - route' request respond = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request @@ -230,8 +235,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) + route Proxy context subserver = + let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) @@ -262,10 +267,10 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = - case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = + case lookup paramname (querytext r) of Nothing -> Nothing -- param absent from the query string Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to @@ -298,13 +303,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values - parameters = filter looksLikeParam querytext - values = mapMaybe (convert . snd) parameters + parameters r = filter looksLikeParam (querytext r) + values r = mapMaybe (convert . snd) (parameters r) in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") @@ -329,9 +334,9 @@ instance (KnownSymbol sym, HasServer sublayout context) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = case lookup paramname (querytext r) 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 @@ -352,8 +357,8 @@ instance HasServer Raw context where type ServerT Raw m = Application - route Proxy _ rawApplication = RawRouter $ \ request respond -> do - r <- runDelayed rawApplication + route Proxy _ rawApplication = RawRouter $ \ env request respond -> do + r <- runDelayed rawApplication env request case r of Route app -> app request (respond . Route) Fail a -> respond $ Fail a @@ -386,10 +391,10 @@ instance ( AllCTUnrender list a, HasServer sublayout context type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = + route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck) where - bodyCheck request = do + bodyCheck = withRequest $ \ request -> 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" @@ -397,11 +402,11 @@ instance ( AllCTUnrender list a, HasServer sublayout context let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) - <$> lazyRequestBody request + <$> liftIO (lazyRequestBody request) case mrqbody of - Nothing -> return $ FailFatal err415 - Just (Left e) -> return $ FailFatal err400 { errBody = cs e } - Just (Right v) -> return $ Route v + Nothing -> delayedFailFatal err415 + Just (Left e) -> delayedFailFatal err400 { errBody = cs e } + Just (Right v) -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. @@ -418,28 +423,28 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver remoteHost) instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ secure req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ vault req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver vault) instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver httpVersion) -- | Basic Authentication instance ( KnownSymbol realm @@ -450,12 +455,12 @@ instance ( KnownSymbol realm type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context - authCheck req = runBasicAuth req realm basicAuthContext + authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext -- * helpers diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs index fcd678b5..1fed931b 100644 --- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -6,6 +6,7 @@ module Servant.Server.Internal.BasicAuth where import Control.Monad (guard) +import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.Monoid ((<>)) @@ -57,13 +58,13 @@ decodeBAHdr req = do -- | Run and check basic authentication, returning the appropriate http error per -- the spec. -runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr) +runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr runBasicAuth req realm (BasicAuthCheck ba) = case decodeBAHdr req of Nothing -> plzAuthenticate - Just e -> ba e >>= \res -> case res of + Just e -> liftIO (ba e) >>= \res -> case res of BadPassword -> plzAuthenticate NoSuchUser -> plzAuthenticate - Unauthorized -> return $ FailFatal err403 - Authorized usr -> return $ Route usr - where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } + Unauthorized -> delayedFailFatal err403 + Authorized usr -> return usr + where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 04b661a3..3b69c04c 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where @@ -8,36 +10,41 @@ import qualified Data.Map as M import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import Network.Wai (Request, Response, pathInfo) +import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -type Router = Router' RoutingApplication +type Router env = Router' env RoutingApplication -- | Internal representation of a router. -data Router' a = - WithRequest (Request -> Router' a) - -- ^ current request is passed to the router - | StaticRouter (Map Text (Router' a)) [a] +-- +-- The first argument describes an environment type that is +-- expected as extra input by the routers at the leaves. The +-- environment is filled while running the router, with path +-- components that can be used to process captures. +-- +data Router' env a = + StaticRouter (Map Text (Router' env a)) [env -> a] -- ^ the map contains routers for subpaths (first path component used -- for lookup and removed afterwards), the list contains handlers -- for the empty path, to be tried in order - | DynamicRouter (Text -> Router' a) - -- ^ first path component passed to the function and removed afterwards - | RawRouter a + | CaptureRouter (Router' (Text, env) a) + -- ^ first path component is passed to the child router in its + -- environment and removed afterwards + | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about - | Choice (Router' a) (Router' a) + | Choice (Router' env a) (Router' env a) -- ^ left-biased choice between two routers deriving Functor -- | Smart constructor for a single static path component. -pathRouter :: Text -> Router' a -> Router' a +pathRouter :: Text -> Router' env a -> Router' env a pathRouter t r = StaticRouter (M.singleton t r) [] -- | Smart constructor for a leaf, i.e., a router that expects -- the empty path. -- -leafRouter :: a -> Router' a +leafRouter :: (env -> a) -> Router' env a leafRouter l = StaticRouter M.empty [l] -- | Smart constructor for the choice between routers. @@ -46,40 +53,27 @@ leafRouter l = StaticRouter M.empty [l] -- * Two static routers can be joined by joining their maps -- and concatenating their leaf-lists. -- * 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 nodes can be reordered. -- -choice :: Router -> Router -> Router +choice :: Router' env a -> Router' env a -> Router' env a choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) -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 (CaptureRouter router1) (CaptureRouter router2) = + CaptureRouter (choice router1 router2) choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 -- | Datatype used for representing and debugging the --- structure of a router. Abstracts from the functions --- being used in the actual router and the handlers at --- the leaves. +-- structure of a router. Abstracts from the handlers +-- at the leaves. -- -- Two 'Router's can be structurally compared by computing -- their 'RouterStructure' using 'routerStructure' and -- then testing for equality, see 'sameStructure'. -- data RouterStructure = - WithRequestStructure RouterStructure - | StaticRouterStructure (Map Text RouterStructure) Int - | DynamicRouterStructure RouterStructure + StaticRouterStructure (Map Text RouterStructure) Int + | CaptureRouterStructure RouterStructure | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show) @@ -87,18 +81,15 @@ data RouterStructure = -- | Compute the structure of a router. -- -- Assumes that the request or text being passed --- in 'WithRequest' or 'DynamicRouter' does not +-- in 'WithRequest' or 'CaptureRouter' does not -- affect the structure of the underlying tree. -- -routerStructure :: Router' a -> RouterStructure -routerStructure (WithRequest f) = - WithRequestStructure $ - routerStructure (f (error "routerStructure: dummy request")) +routerStructure :: Router' env a -> RouterStructure routerStructure (StaticRouter m ls) = StaticRouterStructure (fmap routerStructure m) (length ls) -routerStructure (DynamicRouter f) = - DynamicRouterStructure $ - routerStructure (f (error "routerStructure: dummy text")) +routerStructure (CaptureRouter router) = + CaptureRouterStructure $ + routerStructure router routerStructure (RawRouter _) = RawRouterStructure routerStructure (Choice r1 r2) = @@ -108,21 +99,20 @@ routerStructure (Choice r1 r2) = -- | Compare the structure of two routers. -- -sameStructure :: Router' a -> Router' b -> Bool +sameStructure :: Router' env a -> Router' env b -> Bool sameStructure r1 r2 = routerStructure r1 == routerStructure r2 -- | Provide a textual representation of the -- structure of a router. -- -routerLayout :: Router' a -> Text +routerLayout :: Router' env a -> Text routerLayout router = T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) where mkRouterLayout :: Bool -> RouterStructure -> [Text] - mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n - mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ "] else ["└─ "] mkRouterLayout c (ChoiceStructure r1 r2) = @@ -146,47 +136,54 @@ routerLayout router = mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children -- | Apply a transformation to the response of a `Router`. -tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application. -runRouter :: Router -> RoutingApplication -runRouter (WithRequest router) request respond = - runRouter (router request) request respond -runRouter (StaticRouter table ls) request respond = - case pathInfo request of - [] -> runChoice ls request respond - -- This case is to handle trailing slashes. - [""] -> runChoice ls request respond - first : rest | Just router <- M.lookup first table - -> let request' = request { pathInfo = rest } - in runRouter router request' respond - _ -> respond $ Fail err404 -runRouter (DynamicRouter fun) request respond = - case pathInfo request of - [] -> respond $ Fail err404 - -- This case is to handle trailing slashes. - [""] -> respond $ Fail err404 - first : rest - -> let request' = request { pathInfo = rest } - in runRouter (fun first) request' respond -runRouter (RawRouter app) request respond = app request respond -runRouter (Choice r1 r2) request respond = - runChoice [runRouter r1, runRouter r2] request respond +runRouter :: Router () -> RoutingApplication +runRouter r = runRouterEnv r () + +runRouterEnv :: Router env -> env -> RoutingApplication +runRouterEnv router env request respond = + case router of + StaticRouter table ls -> + case pathInfo request of + [] -> runChoice ls env request respond + -- This case is to handle trailing slashes. + [""] -> runChoice ls env request respond + first : rest | Just router' <- M.lookup first table + -> let request' = request { pathInfo = rest } + in runRouterEnv router' env request' respond + _ -> respond $ Fail err404 + CaptureRouter router' -> + case pathInfo request of + [] -> respond $ Fail err404 + -- This case is to handle trailing slashes. + [""] -> respond $ Fail err404 + first : rest + -> let request' = request { pathInfo = rest } + in runRouterEnv router' (first, env) request' respond + RawRouter app -> + app env request respond + Choice r1 r2 -> + runChoice [runRouterEnv r1, runRouterEnv r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. -- -runChoice :: [RoutingApplication] -> RoutingApplication -runChoice [] _request respond = respond (Fail err404) -runChoice [r] request respond = r request respond -runChoice (r : rs) request respond = - r request $ \ response1 -> - case response1 of - Fail _ -> runChoice rs request $ \ response2 -> - respond $ highestPri response1 response2 - _ -> respond response1 +runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication +runChoice ls = + case ls of + [] -> \ _ _ respond -> respond (Fail err404) + [r] -> r + (r : rs) -> + \ env request respond -> + r env request $ \ response1 -> + case response1 of + Fail _ -> runChoice rs env request $ \ response2 -> + respond $ highestPri response1 response2 + _ -> respond response1 where highestPri (Fail e1) (Fail e2) = if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 99def4b8..5825531e 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -8,7 +8,10 @@ {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where +import Control.Monad (ap, liftM) +import Control.Monad.Trans (MonadIO(..)) import Control.Monad.Trans.Except (runExceptT) +import Data.Text (Text) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () @@ -95,113 +98,133 @@ toApplication ra request respond = ra request routingRespond -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- -data Delayed c where - Delayed :: { capturesD :: IO (RouteResult captures) - , methodD :: IO (RouteResult ()) - , authD :: IO (RouteResult auth) - , bodyD :: IO (RouteResult body) - , serverD :: (captures -> auth -> body -> RouteResult c) - } -> Delayed c +data Delayed env c where + Delayed :: { capturesD :: env -> DelayedIO captures + , methodD :: DelayedIO () + , authD :: DelayedIO auth + , bodyD :: DelayedIO body + , serverD :: captures -> auth -> body -> Request -> RouteResult c + } -> Delayed env c -instance Functor Delayed where - fmap f Delayed{..} - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = bodyD - , serverD = (fmap.fmap.fmap.fmap) f serverD - } -- Note [Existential Record Update] +instance Functor (Delayed env) where + fmap f Delayed{..} = + Delayed + { serverD = \ c a b req -> f <$> serverD c a b req + , .. + } -- Note [Existential Record Update] + +-- | Computations used in a 'Delayed' can depend on the +-- incoming 'Request', may perform 'IO, and result in a +-- 'RouteResult, meaning they can either suceed, fail +-- (with the possibility to recover), or fail fatally. +-- +newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) } + +instance Functor DelayedIO where + fmap = liftM + +instance Applicative DelayedIO where + pure = return + (<*>) = ap + +instance Monad DelayedIO where + return x = DelayedIO (const $ return (Route x)) + DelayedIO m >>= f = + DelayedIO $ \ req -> do + r <- m req + case r of + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + Route a -> runDelayedIO (f a) req + +instance MonadIO DelayedIO where + liftIO m = DelayedIO (const $ Route <$> m) + +-- | A 'Delayed' without any stored checks. +emptyDelayed :: RouteResult a -> Delayed env a +emptyDelayed result = + Delayed (const r) r r r (\ _ _ _ _ -> result) + where + r = return () + +-- | Fail with the option to recover. +delayedFail :: ServantErr -> DelayedIO a +delayedFail err = DelayedIO (const $ return $ Fail err) + +-- | Fail fatally, i.e., without any option to recover. +delayedFailFatal :: ServantErr -> DelayedIO a +delayedFailFatal err = DelayedIO (const $ return $ FailFatal err) + +-- | Gain access to the incoming request. +withRequest :: (Request -> DelayedIO a) -> DelayedIO a +withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req) -- | Add a capture to the end of the capture block. -addCapture :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addCapture Delayed{..} new - = Delayed { capturesD = combineRouteResults (,) capturesD new - , methodD = methodD - , authD = authD - , bodyD = bodyD - , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addCapture :: Delayed env (a -> b) + -> (Text -> DelayedIO a) + -> Delayed (Text, env) b +addCapture Delayed{..} new = + Delayed + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt + , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req + , .. + } -- Note [Existential Record Update] -- | Add a method check to the end of the method block. -addMethodCheck :: Delayed a - -> IO (RouteResult ()) - -> Delayed a -addMethodCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = combineRouteResults const methodD new - , authD = authD - , bodyD = bodyD - , serverD = serverD - } -- Note [Existential Record Update] +addMethodCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addMethodCheck Delayed{..} new = + Delayed + { methodD = methodD <* new + , .. + } -- Note [Existential Record Update] -- | Add an auth check to the end of the auth block. -addAuthCheck :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addAuthCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = combineRouteResults (,) authD new - , bodyD = bodyD - , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addAuthCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addAuthCheck Delayed{..} new = + Delayed + { authD = (,) <$> authD <*> new + , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req + , .. + } -- Note [Existential Record Update] -- | Add a body check to the end of the body block. -addBodyCheck :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addBodyCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = combineRouteResults (,) bodyD new - , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addBodyCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addBodyCheck Delayed{..} new = + Delayed + { bodyD = (,) <$> bodyD <*> new + , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + , .. + } -- Note [Existential Record Update] -- | Add an accept header check to the end of the body block. -- The accept header check should occur after the body check, -- but this will be the case, because the accept header check -- is only scheduled by the method combinators. -addAcceptCheck :: Delayed a - -> IO (RouteResult ()) - -> Delayed a -addAcceptCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = combineRouteResults const bodyD new - , serverD = serverD - } -- Note [Existential Record Update] +addAcceptCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addAcceptCheck Delayed{..} new = + Delayed + { bodyD = bodyD <* new + , .. + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used. -passToServer :: Delayed (a -> b) -> a -> Delayed b -passToServer d x = ($ x) <$> d - --- | The combination 'IO . RouteResult' is a monad, but we --- don't explicitly wrap it in a newtype in order to make it --- an instance. This is the '>>=' of that monad. --- --- We stop on the first error. -bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b) -bindRouteResults m f = do - r <- m - case r of - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e - Route a -> f a - --- | Common special case of 'bindRouteResults', corresponding --- to 'liftM2'. -combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c) -combineRouteResults f m1 m2 = - m1 `bindRouteResults` \ a -> - m2 `bindRouteResults` \ b -> - return (Route (f a b)) +passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b +passToServer Delayed{..} x = + Delayed + { serverD = \ c a b req -> ($ x req) <$> serverD c a b req + , .. + } -- Note [Existential Record Update] -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body @@ -209,24 +232,29 @@ combineRouteResults f m1 m2 = -- -- This should only be called once per request; otherwise the guarantees about -- effect and HTTP error ordering break down. -runDelayed :: Delayed a +runDelayed :: Delayed env a + -> env + -> Request -> IO (RouteResult a) -runDelayed Delayed{..} = - capturesD `bindRouteResults` \ c -> - methodD `bindRouteResults` \ _ -> - authD `bindRouteResults` \ a -> - bodyD `bindRouteResults` \ b -> - return (serverD c a b) +runDelayed Delayed{..} env = runDelayedIO $ do + c <- capturesD env + methodD + a <- authD + b <- bodyD + DelayedIO (\ req -> return $ serverD c a b req) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. -runAction :: Delayed (Handler a) +runAction :: Delayed env (Handler a) + -> env + -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action respond k = runDelayed action >>= go >>= respond +runAction action env req respond k = + runDelayed action env req >>= go >>= respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 7ebd1a75..684361b2 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -25,9 +25,9 @@ routerSpec = do let app' :: Application app' = toApplication $ runRouter router' - router', router :: Router + router', router :: Router () router' = tweakResponse (fmap twk) router - router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") twk :: Response -> Response twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b @@ -69,11 +69,9 @@ shouldHaveSameStructureAs p1 p2 = unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) -makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router -makeTrivialRouter p = route p EmptyContext d - where - d = Delayed r r r r (\ _ _ _ -> FailFatal err501) - r = return (Route ()) +makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () +makeTrivialRouter p = + route p EmptyContext (emptyDelayed (FailFatal err501)) type End = Get '[JSON] () diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs index 48595c9c..21999451 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -20,7 +20,6 @@ module Servant.Server.UsingContextSpec.TestCombinators where import GHC.TypeLits import Servant -import Servant.Server.Internal.RoutingApplication data ExtractFromContext @@ -31,7 +30,7 @@ instance (HasContextEntry context String, HasServer subApi context) => String -> ServerT subApi m route Proxy context delayed = - route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) + route subProxy context (fmap (inject context) delayed) where subProxy :: Proxy subApi subProxy = Proxy diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 5b4154d7..fc4eb1df 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (ServantErr (..), Server, Handler, err401, err403, +import Servant.Server (Server, Handler, err401, err403, err404, serve, serveWithContext, Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, From 96abac7ef2ebbc316a12f096dcd135416f7d3a72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Wed, 13 Apr 2016 15:41:28 +0200 Subject: [PATCH 22/74] remove duplicated HeaderArg export it is also 2 lines below --- servant-js/src/Servant/JS/Internal.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 3c817e1e..d123ef9a 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -23,7 +23,6 @@ module Servant.JS.Internal , HasForeignType(..) , GenerateList(..) , NoTypes - , HeaderArg , ArgType(..) , HeaderArg(..) , QueryArg(..) From c3bb14fb26dd1ded6f06d89e09fe0f31f5aaa0ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Wed, 13 Apr 2016 15:41:51 +0200 Subject: [PATCH 23/74] remove redundant import to remove warnings --- servant-js/src/Servant/JS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-js/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 4afb38db..3494ca69 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -123,7 +123,7 @@ import Servant.JS.Axios import Servant.JS.Internal import Servant.JS.JQuery import Servant.JS.Vanilla -import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) +import Servant.Foreign (listFromAPI) -- | Generate the data necessary to generate javascript code -- for all the endpoints of an API, as ':<|>'-separated values From a551eb62e2543d46b89ce23aa2399ad1655fe9ee Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Tue, 12 Apr 2016 10:35:07 +0200 Subject: [PATCH 24/74] Do the accept check before the body check. This is a reasonably simple attempt at fixing #460. By moving the accept check to a place before the body check, we can make it recoverable (the body check is irreversible, so everything done after the body check has to fail fatally). The advantage is that we can now specify routes offering different content types modularly. Failure to match one is not fatal, and will result in subsequent routes being tried. The disadvantage is that we hereby bump the error priority of the 406 status code. If a request contains a bad accept header and a bad body, we now get 406 rather than 400. This deviates from the HTTP decision diagram we try to follow, but seems like an acceptable compromise for now. --- servant-server/CHANGELOG.md | 4 +++ servant-server/src/Servant/Server/Internal.hs | 9 +++++- .../Server/Internal/RoutingApplication.hs | 16 +++++++--- .../test/Servant/Server/ErrorSpec.hs | 31 ++++++++++++++----- servant-server/test/Servant/ServerSpec.hs | 10 ++++++ 5 files changed, 57 insertions(+), 13 deletions(-) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 736c36bd..b4213b6d 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -7,6 +7,10 @@ efficiently. Functions `layout` and `layoutWithContext` have been added to visualize the router layout for debugging purposes. Test cases for expected router layouts have been added. +* If an endpoint is discovered to have a non-matching "accept header", + this is now a recoverable rather than a fatal failure, allowing + different endpoints for the same route, but with different content + types to be specified modularly. * Export `throwError` from module `Servant` * Add `Handler` type synonym diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2d378c9d..5d02c96d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -154,10 +154,17 @@ methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 +-- This has switched between using 'Fail' and 'FailFatal' a number of +-- times. If the 'acceptCheck' is run after the body check (which would +-- be morally right), then we have to set this to 'FailFatal', because +-- the body check is not reversible, and therefore backtracking after the +-- body check is no longer an option. However, we now run the accept +-- check before the body check and can therefore afford to make it +-- recoverable. acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () - | otherwise = delayedFailFatal err406 + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 5825531e..10bdc461 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -203,16 +203,22 @@ addBodyCheck Delayed{..} new = } -- Note [Existential Record Update] --- | Add an accept header check to the end of the body block. --- The accept header check should occur after the body check, --- but this will be the case, because the accept header check --- is only scheduled by the method combinators. +-- | Add an accept header check to the beginning of the body +-- block. There is a tradeoff here. In principle, we'd like +-- to take a bad body (400) response take precedence over a +-- failed accept check (406). BUT to allow streaming the body, +-- we cannot run the body check and then still backtrack. +-- We therefore do the accept check before the body check, +-- when we can still backtrack. There are other solutions to +-- this, but they'd be more complicated (such as delaying the +-- body check further so that it can still be run in a situation +-- where we'd otherwise report 406). addAcceptCheck :: Delayed env a -> DelayedIO () -> Delayed env a addAcceptCheck Delayed{..} new = Delayed - { bodyD = bodyD <* new + { bodyD = new *> bodyD , .. } -- Note [Existential Record Update] diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 94d26d09..39a71721 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -53,6 +53,23 @@ errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi errorOrderServer = \_ _ _ -> throwE err402 +-- On error priorities: +-- +-- We originally had +-- +-- 404, 405, 401, 415, 400, 406, 402 +-- +-- but we changed this to +-- +-- 404, 405, 401, 406, 415, 400, 402 +-- +-- for servant-0.7. +-- +-- This change is due to the body check being irreversible (to support +-- streaming). Any check done after the body check has to be made fatal, +-- breaking modularity. We've therefore moved the accept check before +-- the body check, to allow it being recoverable and modular, and this +-- goes along with promoting the error priority of 406. errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ @@ -86,18 +103,18 @@ errorOrderSpec = request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 - it "has 415 as its fourth highest priority error" $ do + it "has 406 as its fourth highest priority error" $ do request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody + `shouldRespondWith` 406 + + it "has 415 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody + it "has 400 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody `shouldRespondWith` 400 - it "has 406 as its sixth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody - `shouldRespondWith` 406 - it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index fc4eb1df..50113cf3 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -99,6 +99,9 @@ type VerbApi method status :<|> "noContent" :> Verb method status '[JSON] NoContent :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "accept" :> ( Verb method status '[JSON] Person + :<|> Verb method status '[PlainText] String + ) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -107,6 +110,7 @@ verbSpec = describe "Servant.API.Verb" $ do :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> (return alice :<|> return "B") get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -161,6 +165,12 @@ verbSpec = describe "Servant.API.Verb" $ do [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status + unless (status `elem` [214, 215] || method == methodHead) $ + it "allows modular specification of supported content types" $ do + response <- THW.request method "/accept" [(hAccept, "text/plain")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "B" + it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain` From ef1561167d1822a6805f56878926f82118027c04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 15 Apr 2016 17:18:12 +0800 Subject: [PATCH 25/74] doc: add a section about example projects --- doc/examples.md | 13 +++++++++++++ doc/index.rst | 1 + 2 files changed, 14 insertions(+) create mode 100644 doc/examples.md diff --git a/doc/examples.md b/doc/examples.md new file mode 100644 index 00000000..c0de221c --- /dev/null +++ b/doc/examples.md @@ -0,0 +1,13 @@ +# Example Projects + +- **[example-servant-minimal](https://github.com/haskell-servant/example-servant-minimal)**: + + A minimal example for a web server written using **servant-server**, + including a test-suite using [**hspec**](http://hspec.github.io/) and + **servant-client**. + + +- **[stack-templates](https://github.com/commercialhaskell/stack-templates)** + + Repository for templates for haskell projects, including some templates using + **servant**. These templates can be used with `stack new`. diff --git a/doc/index.rst b/doc/index.rst index eebba2dd..e14fded0 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -19,4 +19,5 @@ All in a type-safe manner. introduction.rst tutorial/index.rst + examples.md links.rst From ab6131d733b21e2e286391e8c99c75639b8c76ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 15 Apr 2016 16:02:57 +0800 Subject: [PATCH 26/74] version bump --- doc/tutorial/tutorial.cabal | 12 ++++++------ servant-blaze/servant-blaze.cabal | 4 ++-- servant-cassava/servant-cassava.cabal | 4 ++-- servant-client/servant-client.cabal | 8 ++++---- servant-docs/servant-docs.cabal | 4 ++-- servant-foreign/servant-foreign.cabal | 4 ++-- servant-js/servant-js.cabal | 8 ++++---- servant-lucid/servant-lucid.cabal | 4 ++-- servant-mock/servant-mock.cabal | 2 +- servant-server/servant-server.cabal | 4 ++-- servant/servant.cabal | 2 +- 11 files changed, 28 insertions(+), 28 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 47c507d2..021f1a10 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,5 +1,5 @@ name: tutorial -version: 0.6.1 +version: 0.7 synopsis: The servant tutorial homepage: http://haskell-servant.github.io/ license: BSD3 @@ -25,11 +25,11 @@ library , directory , blaze-markup , containers - , servant == 0.6.* - , servant-server == 0.6.* - , servant-client == 0.6.* - , servant-docs == 0.6.* - , servant-js == 0.6.* + , servant == 0.7.* + , servant-server == 0.7.* + , servant-client == 0.7.* + , servant-docs == 0.7.* + , servant-js == 0.7.* , warp , http-media , lucid diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 5a811621..3ce7faa4 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.6.1 +version: 0.7 synopsis: Blaze-html support for servant -- description: homepage: http://haskell-servant.github.io/ @@ -25,7 +25,7 @@ library -- other-modules: -- other-extensions: build-depends: base >=4.7 && <5 - , servant == 0.6.* + , servant == 0.7.* , http-media , blaze-html hs-source-dirs: src diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 868013b6..117ec804 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.6.1 +version: 0.7 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.github.io/ @@ -22,7 +22,7 @@ library -- other-extensions: build-depends: base >=4.6 && <5 , cassava >0.4 && <0.5 - , servant == 0.6.* + , servant == 0.7.* , http-media , vector hs-source-dirs: src diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 3f982751..7247a075 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.6.1 +version: 0.7 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -45,7 +45,7 @@ library , http-types , network-uri >= 2.6 , safe - , servant == 0.6.* + , servant == 0.7.* , string-conversions , text , transformers @@ -79,9 +79,9 @@ test-suite spec , HUnit , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.6.* + , servant == 0.7.* , servant-client - , servant-server == 0.6.* + , servant-server == 0.7.* , text , wai , warp diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 084c5167..0c877c52 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.6.1 +version: 0.7 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -42,7 +42,7 @@ library , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.6.* + , servant == 0.7.* , string-conversions , text , unordered-containers diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 1ce0859e..3e246e53 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.6.1 +version: 0.7 synopsis: Helpers for generating clients for servant APIs in any programming language description: Helper types and functions for generating client functions for servant APIs in any programming language @@ -31,7 +31,7 @@ library , Servant.Foreign.Inflections build-depends: base == 4.* , lens == 4.* - , servant == 0.6.* + , servant == 0.7.* , text >= 1.2 && < 1.3 , http-types hs-source-dirs: src diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 64e937e3..52216a1b 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -1,5 +1,5 @@ name: servant-js -version: 0.6.1 +version: 0.7 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. @@ -45,7 +45,7 @@ library , base-compat >= 0.9 , charset >= 0.3 , lens >= 4 - , servant-foreign == 0.6.* + , servant-foreign == 0.7.* , text >= 1.2 && < 1.3 hs-source-dirs: src @@ -67,8 +67,8 @@ executable counter , aeson >= 0.7 && < 0.12 , filepath >= 1 , lens >= 4 - , servant == 0.6.* - , servant-server == 0.6.* + , servant == 0.7.* + , servant-server == 0.7.* , servant-js , stm , transformers diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 7619022b..b0e17a96 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.6.1 +version: 0.7 synopsis: Servant support for lucid -- description: homepage: http://haskell-servant.github.io/ @@ -27,7 +27,7 @@ library build-depends: base >=4.7 && <5 , http-media , lucid - , servant == 0.6.* + , servant == 0.7.* hs-source-dirs: src default-language: Haskell2010 include-dirs: include diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index aa877c04..871c3fe9 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -1,5 +1,5 @@ name: servant-mock -version: 0.6.1 +version: 0.7 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index ff407233..fc577514 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.6.1 +version: 0.7 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -60,7 +60,7 @@ library , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.6.* + , servant == 0.7.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 diff --git a/servant/servant.cabal b/servant/servant.cabal index 8c013bbe..9d034592 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.6.1 +version: 0.7 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them From 718ca10589dfeed52bd12de98dfa0542e4b9c775 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 15 Apr 2016 16:17:51 +0800 Subject: [PATCH 27/74] update changelogs for release --- servant-docs/CHANGELOG.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 3fed9973..d40dc68c 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,5 +1,5 @@ -HEAD ----- +0.7 +--- * Use `throwError` instead of `throwE` in documentation From 65bdaa6d10d7de89289a3ba296b799d20d03ce9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 15 Apr 2016 19:23:23 +0800 Subject: [PATCH 28/74] tweaked release script --- scripts/upload.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/upload.hs b/scripts/upload.hs index b44dee78..b03f251c 100755 --- a/scripts/upload.hs +++ b/scripts/upload.hs @@ -11,4 +11,4 @@ main :: IO () main = do sources <- words <$> readFile "sources.txt" forM_ sources $ \ source -> do - callCommand ("stack upload " ++ source) + callCommand ("stack upload --no-signature " ++ source) From b13ecd6098e9d324e3944488dfecb06f74a23182 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko Date: Sat, 16 Apr 2016 16:51:38 +0300 Subject: [PATCH 29/74] Add missing changelogs and readme to cabal in `servant`, `servant-client`. --- servant-client/servant-client.cabal | 5 ++++- servant/servant.cabal | 4 +++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7247a075..d074c1f8 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -15,11 +15,14 @@ maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues +extra-source-files: + include/*.h + CHANGELOG.md + README.md source-repository head type: git location: http://github.com/haskell-servant/servant.git diff --git a/servant/servant.cabal b/servant/servant.cabal index 9d034592..1faddaaa 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -16,9 +16,11 @@ maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 +extra-source-files: + include/*.h + CHANGELOG.md source-repository head type: git location: http://github.com/haskell-servant/servant.git From c064f94fd6e3c9c7ef7d241a5c81d300ee4b1595 Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Sat, 16 Apr 2016 16:13:58 +0100 Subject: [PATCH 30/74] Fix doctests failure when testpack or checkers are installed Test fails as: Test suite doctests: RUNNING... test/Servant/API/ContentTypesSpec.hs:31:18: Ambiguous module name `Test.QuickCheck.Instances': it was found in multiple packages: checkers-0.4.4@check_A5bAKHstANbBRqwFoOaIKx testpack-2.1.3.0@testp_BjTqfpWNTOG5Lwlc3iqqG9 quickcheck-instances-0.3.12@quick_3Tkh09kYN8p78zxMKFPcZI Test suite doctests: FAIL Fixed by importing 'Test.QuickCheck.Instances' from "quickcheck-instances". Signed-off-by: Sergei Trofimovich --- servant/test/Servant/API/ContentTypesSpec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 062b6b2b..e29900e2 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where @@ -28,7 +29,7 @@ import GHC.Generics import Network.URL (exportParams, importParams) import Test.Hspec import Test.QuickCheck -import Test.QuickCheck.Instances () +import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes From 69239393adecf21b631978271ea9d5e9584a0368 Mon Sep 17 00:00:00 2001 From: Ruben Moor Date: Wed, 20 Apr 2016 15:53:55 +0200 Subject: [PATCH 31/74] Update examples.md --- doc/examples.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/examples.md b/doc/examples.md index c0de221c..f99e6d17 100644 --- a/doc/examples.md +++ b/doc/examples.md @@ -11,3 +11,7 @@ Repository for templates for haskell projects, including some templates using **servant**. These templates can be used with `stack new`. + +- ** [custom-monad](https://github.com/themoritz/diener)**: + + A custom monad that can replace `IO` in servant applications. It adds among other things logging functionality and a reader (for database conncetions). A full usage example of servant/diener is also provided. From 292d49408af8ffdb7385cd02068e8b9ad19bda10 Mon Sep 17 00:00:00 2001 From: Ruben Moor Date: Wed, 20 Apr 2016 16:04:51 +0200 Subject: [PATCH 32/74] fixed formatting --- doc/examples.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/examples.md b/doc/examples.md index f99e6d17..974dffe4 100644 --- a/doc/examples.md +++ b/doc/examples.md @@ -12,6 +12,8 @@ Repository for templates for haskell projects, including some templates using **servant**. These templates can be used with `stack new`. -- ** [custom-monad](https://github.com/themoritz/diener)**: +- **[custom-monad](https://github.com/themoritz/diener)**: - A custom monad that can replace `IO` in servant applications. It adds among other things logging functionality and a reader (for database conncetions). A full usage example of servant/diener is also provided. + A custom monad that can replace `IO` in servant applications. It adds among + other things logging functionality and a reader (for database conncetions). + A full usage example of servant/diener is also provided. From 07f10aaf5e4e226f3466864e7f271f20870b20cb Mon Sep 17 00:00:00 2001 From: Ruben Moor Date: Wed, 20 Apr 2016 16:07:02 +0200 Subject: [PATCH 33/74] typos --- doc/examples.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/examples.md b/doc/examples.md index 974dffe4..b861ddc1 100644 --- a/doc/examples.md +++ b/doc/examples.md @@ -15,5 +15,5 @@ - **[custom-monad](https://github.com/themoritz/diener)**: A custom monad that can replace `IO` in servant applications. It adds among - other things logging functionality and a reader (for database conncetions). + other things logging functionality and a reader monad (for database connections). A full usage example of servant/diener is also provided. From e1463cd02d6ccf9457fb5f4e408b22cefeefea81 Mon Sep 17 00:00:00 2001 From: Justin Sermeno Date: Mon, 21 Mar 2016 16:46:04 -0500 Subject: [PATCH 34/74] remove response header contains check --- servant/src/Servant/API/ResponseHeaders.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index cde14938..cdb7341e 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -68,8 +68,7 @@ class BuildHeadersTo hs where instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h - , Contains h xs ~ 'False) +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) @@ -89,7 +88,7 @@ class GetHeaders ls where instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) ) => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest @@ -100,7 +99,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v ) => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs @@ -112,20 +111,15 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a)) + , new ~ (Headers '[Header h v] a) ) => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) -type family Contains x xs where - Contains x ((Header x a) ': xs) = 'True - Contains x ((Header y a) ': xs) = Contains x xs - Contains x '[] = 'False - -- $setup -- >>> import Servant.API -- >>> import Data.Aeson From b26bbfccdaef5734ae62b07df14706e4294b13b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Apr 2016 18:07:23 +0800 Subject: [PATCH 35/74] travis: enable -Wall -Werror --- doc/tutorial/tutorial.cabal | 8 ++------ servant-blaze/servant-blaze.cabal | 1 + servant-cassava/servant-cassava.cabal | 1 + servant-client/servant-client.cabal | 3 +-- servant-client/test/Servant/ClientSpec.hs | 2 +- servant-docs/servant-docs.cabal | 1 - servant-foreign/src/Servant/Foreign/Internal.hs | 3 ++- servant-js/servant-js.cabal | 2 +- servant-js/src/Servant/JS/Internal.hs | 2 +- servant-lucid/servant-lucid.cabal | 1 + servant-mock/example/main.hs | 3 +++ servant-mock/servant-mock.cabal | 5 +++-- servant-server/servant-server.cabal | 5 ++--- .../test/Servant/Server/Internal/ContextSpec.hs | 9 +++++---- servant-server/test/Servant/Server/Internal/EnterSpec.hs | 1 - servant-server/test/Servant/Server/RouterSpec.hs | 1 + servant-server/test/Servant/Server/StreamingSpec.hs | 1 - servant-server/test/Servant/Server/UsingContextSpec.hs | 1 - .../Servant/Server/UsingContextSpec/TestCombinators.hs | 4 ++-- servant/servant.cabal | 5 ++--- travis.sh | 2 +- 21 files changed, 30 insertions(+), 31 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 021f1a10..badde620 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -46,15 +46,11 @@ library , markdown-unlit >= 0.4 , http-client default-language: Haskell2010 - ghc-options: -Wall -Werror -pgmL markdown-unlit - -- to silence aeson-0.10 warnings: - ghc-options: -fno-warn-missing-methods - ghc-options: -fno-warn-name-shadowing + ghc-options: -Wall -pgmL markdown-unlit test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 3ce7faa4..c4203651 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -31,3 +31,4 @@ library hs-source-dirs: src default-language: Haskell2010 include-dirs: include + ghc-options: -Wall diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 117ec804..a336c4e8 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -28,3 +28,4 @@ library hs-source-dirs: src default-language: Haskell2010 include-dirs: include + ghc-options: -Wall diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index d074c1f8..a1e42925 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -60,8 +60,7 @@ library test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 17048593..c41b4093 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -28,7 +28,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) +import Control.Monad.Trans.Except (throwE, runExceptT) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 0c877c52..8ae8b810 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -82,4 +82,3 @@ test-suite spec , servant-docs , string-conversions default-language: Haskell2010 - diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 72f24116..4e457897 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -7,7 +7,8 @@ -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens hiding (cons, List) +import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~), + (.~)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 52216a1b..13beb73c 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -55,7 +55,7 @@ library executable counter main-is: counter.hs - ghc-options: -O2 -Wall + ghc-options: -Wall hs-source-dirs: examples if flag(example) diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index d123ef9a..1eb28199 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -46,7 +46,7 @@ module Servant.JS.Internal , Header ) where -import Control.Lens hiding (List) +import Control.Lens ((^.)) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.Monoid diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index b0e17a96..5b2199aa 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -31,3 +31,4 @@ library hs-source-dirs: src default-language: Haskell2010 include-dirs: include + ghc-options: -Wall diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 4a457467..a602dc88 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -2,6 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + import Data.Aeson import GHC.Generics import Network.Wai.Handler.Warp diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 871c3fe9..8940e7c2 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -35,6 +35,7 @@ library hs-source-dirs: src default-language: Haskell2010 include-dirs: include + ghc-options: -Wall executable mock-app main-is: main.hs @@ -45,11 +46,11 @@ executable mock-app buildable: True else buildable: False + ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index fc577514..321750db 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -94,8 +94,7 @@ executable greet test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -147,5 +146,5 @@ test-suite doctests main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded include-dirs: include diff --git a/servant-server/test/Servant/Server/Internal/ContextSpec.hs b/servant-server/test/Servant/Server/Internal/ContextSpec.hs index dfac1e2e..887f7269 100644 --- a/servant-server/test/Servant/Server/Internal/ContextSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fdefer-type-errors #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy (Proxy (..)) -import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.Hspec (Spec, describe, it, shouldBe, context) import Test.ShouldNotTypecheck (shouldNotTypecheck) import Servant.API @@ -26,16 +26,17 @@ spec = do shouldNotTypecheck x context "Show instance" $ do - let cxt = 'a' :. True :. EmptyContext it "has a Show instance" $ do + let cxt = 'a' :. True :. EmptyContext show cxt `shouldBe` "'a' :. True :. EmptyContext" context "bracketing" $ do it "works" $ do + let cxt = 'a' :. True :. EmptyContext show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" it "works with operators" $ do - let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) + let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" describe "descendIntoNamedContext" $ do diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 1591e987..821d5640 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -5,7 +5,6 @@ module Servant.Server.Internal.EnterSpec where import qualified Control.Category as C import Control.Monad.Reader -import Control.Monad.Trans.Except import Data.Proxy import Servant.API import Servant.Server diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 684361b2..e1ec5d7b 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -16,6 +16,7 @@ import Servant.API import Servant.Server import Servant.Server.Internal +spec :: Spec spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs index ed289257..215664ee 100644 --- a/servant-server/test/Servant/Server/StreamingSpec.hs +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -11,7 +11,6 @@ module Servant.Server.StreamingSpec where import Control.Concurrent import Control.Exception hiding (Handler) import Control.Monad.IO.Class -import Control.Monad.Trans.Except import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Network.HTTP.Types diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs index 1f9c3328..91ab8376 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -5,7 +5,6 @@ module Servant.Server.UsingContextSpec where -import Control.Monad.Trans.Except import Network.Wai import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs index 21999451..0a718788 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -30,12 +30,12 @@ instance (HasContextEntry context String, HasServer subApi context) => String -> ServerT subApi m route Proxy context delayed = - route subProxy context (fmap (inject context) delayed) + route subProxy context (fmap inject delayed) where subProxy :: Proxy subApi subProxy = Proxy - inject context f = f (getContextEntry context) + inject f = f (getContextEntry context) data InjectIntoContext diff --git a/servant/servant.cabal b/servant/servant.cabal index 1faddaaa..7e0a16f7 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -89,8 +89,7 @@ library test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -122,5 +121,5 @@ test-suite doctests main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded include-dirs: include diff --git a/travis.sh b/travis.sh index 60734911..cd815efb 100755 --- a/travis.sh +++ b/travis.sh @@ -6,7 +6,7 @@ for package in $(cat sources.txt) doc/tutorial ; do echo testing $package pushd $package tinc - cabal configure --enable-tests --disable-optimization + cabal configure --enable-tests --disable-optimization --ghc-options='-Werror' cabal build cabal test popd From 29be5761cecd0e88ce3b8b24a28a9a28dca0e135 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 21 Apr 2016 15:27:08 +0800 Subject: [PATCH 36/74] servant-client: add Eq instance for ServantError --- servant-client/src/Servant/Common/Req.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 52398637..18703141 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -55,6 +55,19 @@ data ServantError } deriving (Show, Typeable) +instance Eq ServantError where + FailureResponse a b c == FailureResponse x y z = + (a, b, c) == (x, y, z) + DecodeFailure a b c == DecodeFailure x y z = + (a, b, c) == (x, y, z) + UnsupportedContentType a b == UnsupportedContentType x y = + (a, b) == (x, y) + InvalidContentTypeHeader a b == InvalidContentTypeHeader x y = + (a, b) == (x, y) + ConnectionError a == ConnectionError x = + show a == show x + _ == _ = False + instance Exception ServantError data Req = Req From e0216781b04d9e4fbe712c4556b32656e41e286e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 21 Apr 2016 18:22:54 +0800 Subject: [PATCH 37/74] set the homepage to readthedocs --- README.md | 3 ++- doc/tutorial/tutorial.cabal | 2 +- servant-blaze/servant-blaze.cabal | 2 +- servant-cassava/servant-cassava.cabal | 2 +- servant-client/servant-client.cabal | 4 ++-- servant-docs/servant-docs.cabal | 2 +- servant-js/servant-js.cabal | 2 +- servant-lucid/servant-lucid.cabal | 2 +- servant-server/README.md | 3 +-- servant-server/servant-server.cabal | 4 ++-- servant/servant.cabal | 4 ++-- 11 files changed, 15 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 3cf786ea..9d3631a7 100644 --- a/README.md +++ b/README.md @@ -4,11 +4,12 @@ ## Getting Started -We have a [tutorial](http://haskell-servant.github.io/tutorial) that +We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that introduces the core features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. +The central documentation can be found [here](http://haskell-servant.readthedocs.org/). Other blog posts, videos and slides can be found on the [website](http://haskell-servant.github.io/). diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index badde620..4eb1d41c 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,7 +1,7 @@ name: tutorial version: 0.7 synopsis: The servant tutorial -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE author: Servant Contributors diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index c4203651..987e9a4c 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -5,7 +5,7 @@ name: servant-blaze version: 0.7 synopsis: Blaze-html support for servant -- description: -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE author: Servant Contributors diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index a336c4e8..800e4bcf 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -5,7 +5,7 @@ name: servant-cassava version: 0.7 synopsis: Servant CSV content-type for cassava -- description: -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE author: Servant Contributors diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index a1e42925..64164cf7 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -5,7 +5,7 @@ description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. . - See . + See . . license: BSD3 @@ -17,7 +17,7 @@ category: Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: include/*.h diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 8ae8b810..dc7f19b3 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -16,7 +16,7 @@ category: Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: include/*.h diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 13beb73c..6276bca6 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -19,7 +19,7 @@ copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: include/*.h diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 5b2199aa..cdaae66c 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -5,7 +5,7 @@ name: servant-lucid version: 0.7 synopsis: Servant support for lucid -- description: -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE author: Servant Contributors diff --git a/servant-server/README.md b/servant-server/README.md index 08842f19..b2a9ed00 100644 --- a/servant-server/README.md +++ b/servant-server/README.md @@ -6,5 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint ## Getting started -We've written a [tutorial](http://haskell-servant.github.io/tutorial/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. - +We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 321750db..e7012fdd 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -4,14 +4,14 @@ synopsis: A family of combinators for defining webservices APIs and s description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE diff --git a/servant/servant.cabal b/servant/servant.cabal index 7e0a16f7..55cf4c17 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -4,10 +4,10 @@ synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE From a948639673ffbb0a1c90f9331ec597e8230d0de3 Mon Sep 17 00:00:00 2001 From: Amar Date: Thu, 21 Apr 2016 19:31:51 +0800 Subject: [PATCH 38/74] Move enter to servant package --- servant-client/src/Servant/Client.hs | 1 + servant-server/servant-server.cabal | 2 -- servant-server/src/Servant/Server.hs | 2 +- .../Internal/EnterSpec.hs => ArbitraryMonadServerSpec.hs} | 2 +- servant/servant.cabal | 3 +++ .../Server/Internal => servant/src/Servant/Utils}/Enter.hs | 2 +- 6 files changed, 7 insertions(+), 5 deletions(-) rename servant-server/test/Servant/{Server/Internal/EnterSpec.hs => ArbitraryMonadServerSpec.hs} (97%) rename {servant-server/src/Servant/Server/Internal => servant/src/Servant/Utils}/Enter.hs (98%) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ee27846c..6ea8bef7 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -43,6 +43,7 @@ import Servant.Client.Experimental.Auth import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req +import Servant.Utils.Enter -- * Accessing APIs as a Client diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index e7012fdd..2c3fd1ea 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -40,7 +40,6 @@ library Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context - Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr @@ -101,7 +100,6 @@ test-suite spec other-modules: Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec - Servant.Server.Internal.EnterSpec Servant.ServerSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index bbba7c1b..257a721d 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -101,7 +101,7 @@ import Data.Proxy (Proxy) import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.Internal.Enter +import Servant.Utils.Enter -- * Implementing Servers diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs similarity index 97% rename from servant-server/test/Servant/Server/Internal/EnterSpec.hs rename to servant-server/test/Servant/ArbitraryMonadServerSpec.hs index 821d5640..2f01609a 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.EnterSpec where +module Servant.ArbitraryMonadServerSpec where import qualified Control.Category as C import Control.Monad.Reader diff --git a/servant/servant.cabal b/servant/servant.cabal index 55cf4c17..3c35a5da 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -47,6 +47,7 @@ library Servant.API.Verbs Servant.API.WithNamedContext Servant.Utils.Links + Servant.Utils.Enter build-depends: base >= 4.7 && < 4.9 , base-compat >= 0.9 @@ -58,6 +59,8 @@ library , http-api-data >= 0.1 && < 0.3 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 + , mtl >= 2 && < 3 + , mmorph >= 1 , text >= 1 && < 2 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant/src/Servant/Utils/Enter.hs similarity index 98% rename from servant-server/src/Servant/Server/Internal/Enter.hs rename to servant/src/Servant/Utils/Enter.hs index f1c88b2e..35168dc2 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant/src/Servant/Utils/Enter.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Servant.Server.Internal.Enter where +module Servant.Utils.Enter where import qualified Control.Category as C #if MIN_VERSION_mtl(2,2,1) From 4045d20c8d218ac5ab2f74780b3a1b9714aece64 Mon Sep 17 00:00:00 2001 From: Amar Date: Thu, 21 Apr 2016 20:30:11 +0800 Subject: [PATCH 39/74] Fix unused warning --- servant-client/src/Servant/Client.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 6ea8bef7..ee27846c 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -43,7 +43,6 @@ import Servant.Client.Experimental.Auth import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req -import Servant.Utils.Enter -- * Accessing APIs as a Client From 3f4bcf7752bd87a24bc03305e95726a2c5833ad5 Mon Sep 17 00:00:00 2001 From: Amar Date: Thu, 28 Apr 2016 22:11:40 +0800 Subject: [PATCH 40/74] Remove mmorph dependency from servant-server --- servant-server/servant-server.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 2c3fd1ea..f9c64b25 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -56,7 +56,6 @@ library , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 , mtl >= 2 && < 3 - , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 , servant == 0.7.* From 61a99c9567fba95319a3be9d390ab04978e10e1e Mon Sep 17 00:00:00 2001 From: Amar Date: Thu, 28 Apr 2016 22:26:27 +0800 Subject: [PATCH 41/74] Replace Servant.Server.Internal.Enter with Servant.Utils.Enter in a comment --- servant-server/src/Servant/Server/Internal/Context.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index 580a7542..cf84689b 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -18,7 +18,7 @@ import GHC.TypeLits -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using --- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that +-- with 'Servant.Utils.Enter'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- If you are using combinators that require a non-empty 'Context' you have to From 845a06ccbd4c7b594b242fc8a37d64bed11d2a11 Mon Sep 17 00:00:00 2001 From: Amar Date: Thu, 28 Apr 2016 22:27:50 +0800 Subject: [PATCH 42/74] Correct the description of arbitrary monad server spec --- servant-server/test/Servant/ArbitraryMonadServerSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs index 2f01609a..444d86ec 100644 --- a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs +++ b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs @@ -14,7 +14,7 @@ import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with) spec :: Spec -spec = describe "module Servant.Server.Enter" $ do +spec = describe "Arbitrary monad server" $ do enterSpec type ReaderAPI = "int" :> Get '[JSON] Int From 70d2ccaae361ffa8cb030f393626e79ea4f866ab Mon Sep 17 00:00:00 2001 From: Chris Forno Date: Wed, 4 May 2016 19:46:54 +0800 Subject: [PATCH 43/74] support safeLink for RemoteHost --- servant/src/Servant/Utils/Links.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 2fb7d0a5..85bc6585 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -116,6 +116,7 @@ import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) +import Servant.API.RemoteHost ( RemoteHost ) import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) @@ -292,6 +293,10 @@ instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) +instance HasLink sub => HasLink (RemoteHost :> sub) where + type MkLink (RemoteHost :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = URI From 753ad402e18d6a18ba2dd05632c1df07c4deffd5 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 9 May 2016 19:28:44 +0200 Subject: [PATCH 44/74] Make servant-mock bounds match the other packages. This is causing build failures for some. --- servant-mock/servant-mock.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 8940e7c2..fd816ebe 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -27,8 +27,8 @@ library base >=4.7 && <5, bytestring >= 0.10 && <0.11, http-types >= 0.8 && <0.10, - servant >= 0.4, - servant-server >= 0.4, + servant == 0.7.*, + servant-server == 0.7.*, transformers >= 0.3 && <0.5, QuickCheck >= 2.7 && <2.9, wai >= 3.0 && <3.3 From f2c925f39a27a9213c201bc34dca6c37409cb02b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 12:48:28 +0200 Subject: [PATCH 45/74] Link to vault package. --- servant/src/Servant/API/Vault.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant/src/Servant/API/Vault.hs b/servant/src/Servant/API/Vault.hs index 7a767b39..7b0a0971 100644 --- a/servant/src/Servant/API/Vault.hs +++ b/servant/src/Servant/API/Vault.hs @@ -9,8 +9,8 @@ import Data.Vault.Lazy (Vault) -- -- | Use 'Vault' in your API types to provide access to the 'Vault' -- of the request, which is a location shared by middlewares and applications --- to store arbitrary data. See 'Vault' for more details on how to actually --- use the vault in your handlers +-- to store arbitrary data. See +-- for more details on how to actually use the vault in your handlers -- -- Example: -- From efbe6fd4983d4fc43f7f54d660f30e166da1726f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 13:21:34 +0200 Subject: [PATCH 46/74] Use NoContent and fix content-type lists in docs. --- doc/tutorial/Server.lhs | 52 ++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index af3fe17d..11fdf3c0 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -809,7 +809,7 @@ type UserAPI3 = -- view the user with given userid, in JSON Capture "userid" Int :> Get '[JSON] User :<|> -- delete the user with given userid. empty response - Capture "userid" Int :> Delete '[] () + Capture "userid" Int :> DeleteNoContent '[JSON] NoContent ``` We can instead factor out the `userid`: @@ -817,7 +817,7 @@ We can instead factor out the `userid`: ``` haskell type UserAPI4 = Capture "userid" Int :> ( Get '[JSON] User - :<|> Delete '[] () + :<|> DeleteNoContent '[JSON] NoContent ) ``` @@ -826,10 +826,10 @@ corresponding `Server`: ``` haskell ignore Server UserAPI3 = (Int -> Handler User) - :<|> (Int -> Handler ()) + :<|> (Int -> Handler NoContent) Server UserAPI4 = Int -> ( Handler User - :<|> Handler () + :<|> Handler NoContent ) ``` @@ -844,7 +844,7 @@ server8 = getUser :<|> deleteUser where getUser :: Int -> Handler User getUser _userid = error "..." - deleteUser :: Int -> Handler () + deleteUser :: Int -> Handler NoContent deleteUser _userid = error "..." -- notice how getUser and deleteUser @@ -856,7 +856,7 @@ server9 userid = getUser userid :<|> deleteUser userid where getUser :: Int -> Handler User getUser = error "..." - deleteUser :: Int -> Handler () + deleteUser :: Int -> Handler NoContent deleteUser = error "..." ``` @@ -875,13 +875,13 @@ type API1 = "users" :> -- we factor out the Request Body type API2 = ReqBody '[JSON] User :> ( Get '[JSON] User -- just display the same user back, don't register it - :<|> Post '[JSON] () -- register the user. empty response + :<|> PostNoContent '[JSON] NoContent -- register the user. empty response ) -- we factor out a Header type API3 = Header "Authorization" Token :> ( Get '[JSON] SecretData -- get some secret data, if authorized - :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized + :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized ) newtype Token = Token ByteString @@ -894,11 +894,11 @@ API type only at the end. ``` haskell type UsersAPI = Get '[JSON] [User] -- list users - :<|> ReqBody '[JSON] User :> Post '[] () -- add a user + :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user :<|> Capture "userid" Int :> ( Get '[JSON] User -- view a user - :<|> ReqBody '[JSON] User :> Put '[] () -- update a user - :<|> Delete '[] () -- delete a user + :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user + :<|> DeleteNoContent '[JSON] NoContent -- delete a user ) usersServer :: Server UsersAPI @@ -907,7 +907,7 @@ usersServer = getUsers :<|> newUser :<|> userOperations where getUsers :: Handler [User] getUsers = error "..." - newUser :: User -> Handler () + newUser :: User -> Handler NoContent newUser = error "..." userOperations userid = @@ -917,21 +917,21 @@ usersServer = getUsers :<|> newUser :<|> userOperations viewUser :: Int -> Handler User viewUser = error "..." - updateUser :: Int -> User -> Handler () + updateUser :: Int -> User -> Handler NoContent updateUser = error "..." - deleteUser :: Int -> Handler () + deleteUser :: Int -> Handler NoContent deleteUser = error "..." ``` ``` haskell type ProductsAPI = Get '[JSON] [Product] -- list products - :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product + :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product :<|> Capture "productid" Int :> ( Get '[JSON] Product -- view a product - :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product - :<|> Delete '[] () -- delete a product + :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product + :<|> DeleteNoContent '[JSON] NoContent -- delete a product ) data Product = Product { productId :: Int } @@ -942,7 +942,7 @@ productsServer = getProducts :<|> newProduct :<|> productOperations where getProducts :: Handler [Product] getProducts = error "..." - newProduct :: Product -> Handler () + newProduct :: Product -> Handler NoContent newProduct = error "..." productOperations productid = @@ -952,10 +952,10 @@ productsServer = getProducts :<|> newProduct :<|> productOperations viewProduct :: Int -> Handler Product viewProduct = error "..." - updateProduct :: Int -> Product -> Handler () + updateProduct :: Int -> Product -> Handler NoContent updateProduct = error "..." - deleteProduct :: Int -> Handler () + deleteProduct :: Int -> Handler NoContent deleteProduct = error "..." ``` @@ -975,20 +975,20 @@ abstract that away: -- indexed by values of type 'i' type APIFor a i = Get '[JSON] [a] -- list 'a's - :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a' + :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a' :<|> Capture "id" i :> ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' - :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' - :<|> Delete '[] () -- delete an 'a' + :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a' + :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a' ) -- Build the appropriate 'Server' -- given the handlers of the right type. serverFor :: Handler [a] -- handler for listing of 'a's - -> (a -> Handler ()) -- handler for adding an 'a' + -> (a -> Handler NoContent) -- handler for adding an 'a' -> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i' - -> (i -> a -> Handler ()) -- updating an 'a' with given id - -> (i -> Handler ()) -- deleting an 'a' given its id + -> (i -> a -> Handler NoContent) -- updating an 'a' with given id + -> (i -> Handler NoContent) -- deleting an 'a' given its id -> Server (APIFor a i) serverFor = error "..." -- implementation left as an exercise. contact us on IRC From d4c5edea2522c0421fe06e6c6a099f502df5decb Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 13:30:57 +0200 Subject: [PATCH 47/74] Change throwErr to throwError. --- .../src/Servant/Server/Internal/ServantErr.hs | 60 +++++++++---------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index b60f042c..e1267ce6 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -31,7 +31,7 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } +-- > failingHandler = throwError $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 @@ -45,7 +45,7 @@ err300 = ServantErr { errHTTPCode = 300 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err301 +-- > failingHandler = throwError err301 -- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 @@ -59,7 +59,7 @@ err301 = ServantErr { errHTTPCode = 301 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err302 +-- > failingHandler = throwError err302 -- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 @@ -73,7 +73,7 @@ err302 = ServantErr { errHTTPCode = 302 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err303 +-- > failingHandler = throwError err303 -- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 @@ -87,7 +87,7 @@ err303 = ServantErr { errHTTPCode = 303 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err304 +-- > failingHandler = throwError err304 -- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 @@ -101,7 +101,7 @@ err304 = ServantErr { errHTTPCode = 304 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err305 +-- > failingHandler = throwError err305 -- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 @@ -115,7 +115,7 @@ err305 = ServantErr { errHTTPCode = 305 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err307 +-- > failingHandler = throwError err307 -- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 @@ -129,7 +129,7 @@ err307 = ServantErr { errHTTPCode = 307 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } +-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 @@ -143,7 +143,7 @@ err400 = ServantErr { errHTTPCode = 400 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } +-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 @@ -157,7 +157,7 @@ err401 = ServantErr { errHTTPCode = 401 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } +-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 @@ -171,7 +171,7 @@ err402 = ServantErr { errHTTPCode = 402 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err403 { errBody = "Please login first." } +-- > failingHandler = throwError $ err403 { errBody = "Please login first." } -- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 @@ -185,7 +185,7 @@ err403 = ServantErr { errHTTPCode = 403 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 @@ -199,7 +199,7 @@ err404 = ServantErr { errHTTPCode = 404 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } +-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 @@ -213,7 +213,7 @@ err405 = ServantErr { errHTTPCode = 405 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err406 +-- > failingHandler = throwError err406 -- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 @@ -227,7 +227,7 @@ err406 = ServantErr { errHTTPCode = 406 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err407 +-- > failingHandler = throwError err407 -- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 @@ -241,7 +241,7 @@ err407 = ServantErr { errHTTPCode = 407 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } +-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 @@ -255,7 +255,7 @@ err409 = ServantErr { errHTTPCode = 409 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } +-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 @@ -269,7 +269,7 @@ err410 = ServantErr { errHTTPCode = 410 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr err411 +-- > failingHandler = throwError err411 -- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 @@ -283,7 +283,7 @@ err411 = ServantErr { errHTTPCode = 411 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } +-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 @@ -297,7 +297,7 @@ err412 = ServantErr { errHTTPCode = 412 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } +-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 @@ -311,7 +311,7 @@ err413 = ServantErr { errHTTPCode = 413 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } +-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 @@ -325,7 +325,7 @@ err414 = ServantErr { errHTTPCode = 414 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } +-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 @@ -339,7 +339,7 @@ err415 = ServantErr { errHTTPCode = 415 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } +-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 @@ -353,7 +353,7 @@ err416 = ServantErr { errHTTPCode = 416 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } +-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 @@ -367,7 +367,7 @@ err417 = ServantErr { errHTTPCode = 417 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 @@ -381,7 +381,7 @@ err500 = ServantErr { errHTTPCode = 500 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } +-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 @@ -395,7 +395,7 @@ err501 = ServantErr { errHTTPCode = 501 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } +-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 @@ -409,7 +409,7 @@ err502 = ServantErr { errHTTPCode = 502 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } +-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 @@ -423,7 +423,7 @@ err503 = ServantErr { errHTTPCode = 503 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } +-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 @@ -437,7 +437,7 @@ err504 = ServantErr { errHTTPCode = 504 -- Example usage: -- -- > failingHandler :: Handler () --- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } +-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 From e0ba34372ef196e0f40ac5b3114f294dee10a1de Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 13:39:01 +0200 Subject: [PATCH 48/74] Remove link to 0.4 version of tutorial. Stackage has 0.5 already, and the 0.4 version has numerous mistakes. --- doc/tutorial/index.rst | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index 1f48cdeb..b9c9a003 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -3,12 +3,7 @@ Tutorial This is an introductory tutorial to **servant**. -.. note:: - This tutorial is for the latest version of servant. The tutorial for - servant-0.4 can be viewed - `here `_. - -(Any comments, issues or feedback about the tutorial can be handled +(Any comments, issues or feedback about the tutorial can be submitted through `servant's issue tracker `_.) From e9cbb85ce12fb8334d4a66fb4a539eda1c48ce7a Mon Sep 17 00:00:00 2001 From: Amar Date: Tue, 10 May 2016 22:16:37 +0800 Subject: [PATCH 49/74] Add changelog entries --- servant-server/CHANGELOG.md | 5 +++++ servant/CHANGELOG.md | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index b4213b6d..e1ed25be 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.1 +------ + +* Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478) + 0.7 --- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index efeecf66..c9762c79 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.1 +------ + +* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478) + 0.5 ---- From 7ef27152b9bd2bfb97e73712b103a04eb7316586 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 15 Apr 2016 16:32:35 +0300 Subject: [PATCH 50/74] Add ghc-8.0.1 to travis matrix --- .travis.yml | 11 +++++++---- servant-mock/servant-mock.cabal | 2 +- servant/servant.cabal | 2 +- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 929b0b13..d6854b8a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,8 +3,9 @@ sudo: false language: c env: - - GHCVER=7.8.4 - - GHCVER=7.10.2 + - GHCVER=7.8.4 CABALVER=1.22 + - GHCVER=7.10.3 CABALVER=1.22 + - GHCVER=8.0.1 CABALVER=1.24 addons: apt: @@ -12,13 +13,15 @@ addons: - hvr-ghc packages: - ghc-7.8.4 - - ghc-7.10.2 + - ghc-7.10.3 + - ghc-8.0.1 - cabal-install-1.22 + - cabal-install-1.24 - libgmp-dev install: - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - ghc --version - cabal --version - travis_retry cabal update diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index fd816ebe..8e750d69 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -29,7 +29,7 @@ library http-types >= 0.8 && <0.10, servant == 0.7.*, servant-server == 0.7.*, - transformers >= 0.3 && <0.5, + transformers >= 0.3 && <0.6, QuickCheck >= 2.7 && <2.9, wai >= 3.0 && <3.3 hs-source-dirs: src diff --git a/servant/servant.cabal b/servant/servant.cabal index 3c35a5da..4f0e5579 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -49,7 +49,7 @@ library Servant.Utils.Links Servant.Utils.Enter build-depends: - base >= 4.7 && < 4.9 + base >= 4.7 && < 4.10 , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 From fd19694ed5591848ee7e78a259d647749f5ff426 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 17 Apr 2016 21:50:45 +0300 Subject: [PATCH 51/74] Make doctests accept GHC-8.0 formatted type errors --- servant-server/servant-server.cabal | 2 +- servant-server/src/Servant/Server/Internal/Context.hs | 2 +- servant/src/Servant/Utils/Links.hs | 10 ++-------- servant/test/Servant/Utils/LinksSpec.hs | 10 +++++----- 4 files changed, 9 insertions(+), 15 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index f9c64b25..b0ae526a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -122,7 +122,7 @@ test-suite spec , servant , servant-server , string-conversions - , should-not-typecheck == 2.* + , should-not-typecheck == 2.1.* , temporary , text , transformers diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index cf84689b..3dd3a898 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -59,7 +59,7 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ... --- No instance for (HasContextEntry '[] [Char]) +-- ...No instance for (HasContextEntry '[] [Char]) -- ... class HasContextEntry (context :: [*]) (val :: *) where getContextEntry :: Context context -> val diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 85bc6585..b2157c04 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -72,14 +72,8 @@ -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) -- >>> safeLink api bad_link -- ... --- Could not deduce (Or --- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) --- (IsElem' --- ("hello" :> Delete '[JSON] ()) --- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) --- arising from a use of ‘safeLink’ --- In the expression: safeLink api bad_link --- In an equation for ‘it’: it = safeLink api bad_link +-- ...Could not deduce... +-- ... -- -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 07e0b068..8c0d3f3a 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -67,27 +67,27 @@ spec = describe "Servant.Utils.Links" $ do -- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy NotALink) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- sanity check From 008f2434ee652f904a9fbb260ec16b875538c141 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 22 Apr 2016 09:32:39 +0300 Subject: [PATCH 52/74] Add -Wno-redundant-constraints --- servant-client/servant-client.cabal | 2 ++ servant-client/test/Servant/ClientSpec.hs | 4 ++++ servant-docs/servant-docs.cabal | 2 ++ servant-foreign/servant-foreign.cabal | 2 ++ servant-server/servant-server.cabal | 2 ++ servant/servant.cabal | 2 ++ 6 files changed, 14 insertions(+) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 64164cf7..55886ef2 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -56,6 +56,8 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include test-suite spec diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c41b4093..4a6ed243 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -15,7 +15,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else {-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index dc7f19b3..4352d259 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -50,6 +50,8 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include executable greet-docs diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 3e246e53..a5f91a39 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -37,6 +37,8 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include default-extensions: CPP , ConstraintKinds diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index b0ae526a..3a91a8ad 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -74,6 +74,8 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include executable greet diff --git a/servant/servant.cabal b/servant/servant.cabal index 4f0e5579..cfaa7384 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -88,6 +88,8 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include test-suite spec From 411dff06be47ae2226aa68a650bc758693f8d6a0 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 10 May 2016 17:19:18 +0300 Subject: [PATCH 53/74] Add stack-ghc-8.0.1.yaml --- stack-ghc-7.8.4.yaml | 3 +- stack-ghc-8.0.1.yaml | 166 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 167 insertions(+), 2 deletions(-) create mode 100644 stack-ghc-8.0.1.yaml diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 679b2b52..23965e9f 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -5,7 +5,6 @@ packages: - servant-cassava/ - servant-client/ - servant-docs/ -- servant-examples/ - servant-foreign/ - servant-js/ - servant-lucid/ @@ -24,5 +23,5 @@ extra-deps: - stm-delay-0.1.1.1 - control-monad-omega-0.3.1 - http-api-data-0.1.1.1 -- should-not-typecheck-2.0.1 +- should-not-typecheck-2.1.0 resolver: lts-2.22 diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml new file mode 100644 index 00000000..dcfb8e5f --- /dev/null +++ b/stack-ghc-8.0.1.yaml @@ -0,0 +1,166 @@ +flags: + time-locale-compat: + old-locale: false +packages: +- servant/ +- servant-blaze/ +- servant-cassava/ +- servant-client/ +- servant-docs/ +- servant-foreign/ +- servant-js/ +- servant-lucid/ +- servant-mock/ +- servant-server/ +setup-info: + ghc: + linux64: + 8.0.0.20160421: + url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-unknown-linux.tar.xz + macosx: + 8.0.0.20160421: + url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-apple-darwin.tar.xz +extra-deps: +- Diff-0.3.4 +- HUnit-1.3.1.1 +- QuickCheck-2.8.2 +- StateVar-1.1.0.4 +- adjunctions-4.3 +- aeson-0.11.2.0 +- aeson-pretty-0.7.2 +- ansi-terminal-0.6.2.3 +- ansi-wl-pprint-0.6.7.3 +- appar-0.1.4 +- asn1-encoding-0.9.3 +- asn1-parse-0.9.4 +- asn1-types-0.3.2 +- async-2.1.0 +- attoparsec-0.13.0.2 +- auto-update-0.1.4 +- base-compat-0.9.1 +- base-orphans-0.5.4 +- base64-bytestring-1.0.0.1 +- bifunctors-5.3 +- blaze-builder-0.4.0.2 +- blaze-html-0.8.1.1 +- blaze-markup-0.7.0.3 +- byteable-0.1.1 +- byteorder-1.0.4 +- bytestring-builder-0.10.6.0.0 +- bytestring-conversion-0.3.1 +- case-insensitive-1.2.0.6 +- cassava-0.4.5.0 +- cereal-0.5.1.0 +- charset-0.3.7.1 +- cmdargs-0.10.14 +- comonad-5 +- connection-0.2.5 +- contravariant-1.4 +- control-monad-omega-0.3.1 +- cookie-0.4.2 +- cryptonite-0.15 +- data-default-class-0.0.1 +- distributive-0.5.0.2 +- dlist-0.7.1.2 +- doctest-0.11.0 +- double-conversion-2.0.1.0 +- easy-file-0.2.1 +- exceptions-0.8.2.1 +- fail-4.9.0.0 +- fast-logger-2.4.6 +- file-embed-0.0.10 +- filemanip-0.3.6.3 +- free-4.12.4 +- ghc-paths-0.1.0.9 +- hashable-1.2.4.0 +- hex-0.1.2 +- hourglass-0.2.10 +- hspec-2.2.3 +- hspec-core-2.2.3 +- hspec-discover-2.2.3 +- hspec-expectations-0.7.2 +- hspec-wai-0.6.6 +- http-api-data-0.2.2 +- http-client-0.4.28 +- http-client-tls-0.2.4 +- http-date-0.0.6.1 +- http-media-0.6.3 +- http-types-0.9 +- http2-1.6.0 +- iproute-1.7.0 +- kan-extensions-5.0.1 +- language-ecmascript-0.17.1.0 +- lens-4.14 +- lifted-base-0.2.3.6 +- lucid-2.9.5 +- memory-0.12 +- mime-types-0.1.0.7 +- mmorph-1.0.6 +- monad-control-1.0.1.0 +- mtl-2.2.1 +- network-2.6.2.1 +- network-uri-2.6.1.0 +- old-locale-1.0.0.7 +- old-time-1.1.0.3 +- optparse-applicative-0.12.1.0 +- parallel-3.2.1.0 +- parsec-3.1.9 +- pem-0.2.2 +- prelude-extras-0.4.0.3 +- primitive-0.6.1.0 +- profunctors-5.2 +- psqueues-0.2.2.1 +- quickcheck-instances-0.3.12 +- quickcheck-io-0.1.2 +- random-1.1 +- reflection-2.1.2 +- resourcet-1.1.7.4 +- safe-0.3.9 +- scientific-0.3.4.6 +- semigroupoids-5.0.1 +- semigroups-0.18.1 +- setenv-0.1.1.3 +- should-not-typecheck-2.1.0 +- simple-sendfile-0.2.21 +- socks-0.5.5 +- split-0.2.3.1 +- stm-2.4.4.1 +- streaming-commons-0.1.15.4 +- string-conversions-0.4 +- stringsearch-0.3.6.6 +- syb-0.6 +- system-filepath-0.4.13.4 +- tagged-0.8.4 +- tagshare-0.0 +- temporary-1.2.0.4 +- testing-feat-0.4.0.3 +- text-1.2.2.1 +- tf-random-0.5 +- time-locale-compat-0.1.1.1 +- tls-1.3.7 +- transformers-base-0.4.4 +- transformers-compat-0.5.1.4 +- uniplate-1.6.12 +- unix-compat-0.4.1.4 +- unix-time-0.3.6 +- unordered-containers-0.2.7.0 +- url-2.1.3 +- utf8-string-1.0.1.1 +- vault-0.3.0.6 +- vector-0.11.0.0 +- void-0.7.1 +- wai-3.2.1 +- wai-app-static-3.1.5 +- wai-extra-3.0.15.1 +- wai-logger-2.2.7 +- warp-3.2.6 +- with-location-0.1.0 +- wl-pprint-1.2 +- word8-0.1.2 +- x509-1.6.3 +- x509-store-1.6.1 +- x509-system-1.6.3 +- x509-validation-1.6.3 +- zlib-0.6.1.1 +compiler-check: match-exact +resolver: ghc-8.0.0.20160421 From a5cf899eb876c3f626ffc8efd1ada5953826aa3a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 10 May 2016 19:03:01 +0300 Subject: [PATCH 54/74] Add RouterSpec and StreamingSpec to servant-server.cabal --- servant-server/servant-server.cabal | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 3a91a8ad..56908b41 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -101,9 +101,11 @@ test-suite spec other-modules: Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec - Servant.ServerSpec + Servant.Server.RouterSpec + Servant.Server.StreamingSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators + Servant.ServerSpec Servant.Utils.StaticFilesSpec build-depends: base == 4.* From 7174f5185d284d6aef43434b6315e6017f946871 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 22:45:06 +0200 Subject: [PATCH 55/74] Changelog updates for GHC 8.0 support. --- servant-client/CHANGELOG.md | 5 +++++ servant-docs/CHANGELOG.md | 5 +++++ servant-foreign/CHANGELOG.md | 5 +++++ servant-server/CHANGELOG.md | 1 + 4 files changed, 16 insertions(+) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index ada41eb0..3b74ebab 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.1 +----- + +* Support GHC 8.0 + 0.6 --- diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index d40dc68c..dfdb99e5 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.1 +----- + +* Support GHC 8.0 + 0.7 --- diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 75628b79..92339e12 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,3 +1,8 @@ +0.7.1 +----- + +* Support GHC 8.0 + 0.5 ----- * Use the `text` package instead of `String`. diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index e1ed25be..0046372d 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -2,6 +2,7 @@ ------ * Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Support GHC 8.0 0.7 --- From ff4fb00f7661be1a15ef373fcb1bfefc3cb66de5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 3 May 2016 18:05:39 +0800 Subject: [PATCH 56/74] fix haddocks for Servant.API.Header (fixes #491) --- servant/src/Servant/API/Header.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index ac7471c1..2f46f160 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -3,7 +3,9 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Header where +module Servant.API.Header ( + Header(..), +) where import Data.ByteString (ByteString) import Data.Typeable (Typeable) @@ -25,5 +27,3 @@ data Header (sym :: Symbol) a = Header a -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } From 5579c21050663249dd8050a0ad78dfef6fedcf6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 5 May 2016 11:31:08 +0800 Subject: [PATCH 57/74] added changelog entries for 0.7.1 --- servant-client/CHANGELOG.md | 1 + servant/CHANGELOG.md | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 3b74ebab..3627608d 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -2,6 +2,7 @@ ----- * Support GHC 8.0 +* `ServantError` has an `Eq` instance now. 0.6 --- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index c9762c79..09e8207b 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,10 +1,11 @@ 0.7.1 ------- +----- * Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Allow to set the same header multiple times in responses. 0.5 ----- +--- * Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators From d8a4cce69182bac8e5829d99f2a3ce86f184e8f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 5 May 2016 11:34:01 +0800 Subject: [PATCH 58/74] version bump --- doc/tutorial/tutorial.cabal | 2 +- servant-blaze/servant-blaze.cabal | 2 +- servant-cassava/servant-cassava.cabal | 2 +- servant-client/servant-client.cabal | 2 +- servant-docs/servant-docs.cabal | 2 +- servant-foreign/servant-foreign.cabal | 2 +- servant-js/servant-js.cabal | 2 +- servant-lucid/servant-lucid.cabal | 2 +- servant-mock/servant-mock.cabal | 2 +- servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 2 +- 11 files changed, 11 insertions(+), 11 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 4eb1d41c..3c7d52c1 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,5 +1,5 @@ name: tutorial -version: 0.7 +version: 0.7.1 synopsis: The servant tutorial homepage: http://haskell-servant.readthedocs.org/ license: BSD3 diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 987e9a4c..fdb1bc6d 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.7 +version: 0.7.1 synopsis: Blaze-html support for servant -- description: homepage: http://haskell-servant.readthedocs.org/ diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 800e4bcf..d7a66705 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.7 +version: 0.7.1 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.readthedocs.org/ diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 55886ef2..fae87d88 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.7 +version: 0.7.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 4352d259..b8f5210d 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.7 +version: 0.7.1 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index a5f91a39..305b161d 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.7 +version: 0.7.1 synopsis: Helpers for generating clients for servant APIs in any programming language description: Helper types and functions for generating client functions for servant APIs in any programming language diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 6276bca6..ba446e06 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -1,5 +1,5 @@ name: servant-js -version: 0.7 +version: 0.7.1 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index cdaae66c..cf726c02 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.7 +version: 0.7.1 synopsis: Servant support for lucid -- description: homepage: http://haskell-servant.readthedocs.org/ diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 8e750d69..ec8e0008 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -1,5 +1,5 @@ name: servant-mock -version: 0.7 +version: 0.7.1 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 56908b41..7ce9b184 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.7 +version: 0.7.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 cfaa7384..c500894d 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.7 +version: 0.7.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them From aed6f7b910f81ae28904227f3656cbc78a162fd1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 11 May 2016 10:17:24 +0200 Subject: [PATCH 59/74] Review fix --- doc/tutorial/index.rst | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index b9c9a003..c3516671 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -4,8 +4,7 @@ Tutorial This is an introductory tutorial to **servant**. (Any comments, issues or feedback about the tutorial can be submitted -through -`servant's issue tracker `_.) +to `servant's issue tracker `_.) .. toctree:: From 211254512e6742b9d08f4c0f7e9d5bfd17df09bf Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 May 2016 15:40:05 +0200 Subject: [PATCH 60/74] Re-export Application. --- servant-client/test/Servant/ClientSpec.hs | 3 +-- servant-server/src/Servant/Server.hs | 3 +++ servant-server/test/Servant/Server/RouterSpec.hs | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c41b4093..35ff8028 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -41,8 +41,7 @@ import qualified Network.HTTP.Client as C import Network.HTTP.Media import qualified Network.HTTP.Types as HTTP import Network.Socket -import Network.Wai (Application, Request, - requestHeaders, responseLBS) +import Network.Wai (Request, requestHeaders, responseLBS) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.Hspec diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index bbba7c1b..c38dee02 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -95,6 +95,9 @@ module Servant.Server , err504 , err505 + -- * Re-exports + , Application + ) where import Data.Proxy (Proxy) diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index e1ec5d7b..135497e3 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -8,7 +8,7 @@ import Control.Monad (unless) import Data.Proxy (Proxy(..)) import Data.Text (unpack) import Network.HTTP.Types (Status (..)) -import Network.Wai (Application, responseBuilder) +import Network.Wai (responseBuilder) import Network.Wai.Internal (Response (ResponseBuilder)) import Test.Hspec import Test.Hspec.Wai (get, shouldRespondWith, with) From 5a3b944067e6c912512d2f01ffc2c53b29735c51 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 13 May 2016 10:38:58 +0300 Subject: [PATCH 61/74] Remove servant-cassava, moved to own repository --- servant-cassava/LICENSE | 30 ----- servant-cassava/Setup.hs | 2 - servant-cassava/include/overlapping-compat.h | 8 -- servant-cassava/servant-cassava.cabal | 31 ----- servant-cassava/src/Servant/CSV/Cassava.hs | 115 ------------------- servant-cassava/tinc.yaml | 3 - sources.txt | 1 - stack-ghc-7.8.4.yaml | 1 - stack-ghc-8.0.1.yaml | 1 - stack.yaml | 1 - 10 files changed, 193 deletions(-) delete mode 100644 servant-cassava/LICENSE delete mode 100644 servant-cassava/Setup.hs delete mode 100644 servant-cassava/include/overlapping-compat.h delete mode 100644 servant-cassava/servant-cassava.cabal delete mode 100644 servant-cassava/src/Servant/CSV/Cassava.hs delete mode 100644 servant-cassava/tinc.yaml diff --git a/servant-cassava/LICENSE b/servant-cassava/LICENSE deleted file mode 100644 index 1d0ce8da..00000000 --- a/servant-cassava/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015-2016, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Julian K. Arni nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-cassava/Setup.hs b/servant-cassava/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/servant-cassava/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-cassava/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal deleted file mode 100644 index d7a66705..00000000 --- a/servant-cassava/servant-cassava.cabal +++ /dev/null @@ -1,31 +0,0 @@ --- Initial servant-cassava.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-cassava -version: 0.7.1 -synopsis: Servant CSV content-type for cassava --- description: -homepage: http://haskell-servant.readthedocs.org/ -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2015-2016 Servant Contributors --- category: -build-type: Simple -extra-source-files: include/*.h -cabal-version: >=1.10 - -library - exposed-modules: Servant.CSV.Cassava - -- other-modules: - -- other-extensions: - build-depends: base >=4.6 && <5 - , cassava >0.4 && <0.5 - , servant == 0.7.* - , http-media - , vector - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include - ghc-options: -Wall diff --git a/servant-cassava/src/Servant/CSV/Cassava.hs b/servant-cassava/src/Servant/CSV/Cassava.hs deleted file mode 100644 index 625007e7..00000000 --- a/servant-cassava/src/Servant/CSV/Cassava.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for --- @cassava@'s encoding and decoding classes. --- --- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)] --- --- Default encoding and decoding options are also provided, along with the --- @CSV@ type synonym that uses them. --- --- >>> type EgDefault = Get '[CSV] [(Int, String)] -module Servant.CSV.Cassava where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Data.Csv -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import Data.Vector (Vector, toList) -import GHC.Generics (Generic) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..), - MimeUnrender (..)) - -data CSV' deriving (Typeable, Generic) - -type CSV = (CSV', DefaultDecodeOpts) - --- | @text/csv;charset=utf-8@ -instance Accept (CSV', a) where - contentType _ = "text" M.// "csv" M./: ("charset", "utf-8") - --- * Encoding - --- ** Instances - --- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining --- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, [a]) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals - where p = Proxy :: Proxy opt - --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) [a] where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) - where p = Proxy :: Proxy opt - --- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining --- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, Vector a) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) - where p = Proxy :: Proxy opt - --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Vector a) where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList - where p = Proxy :: Proxy opt - --- ** Encode Options - -class EncodeOpts a where - encodeOpts :: Proxy a -> EncodeOptions - -data DefaultEncodeOpts deriving (Typeable, Generic) - -instance EncodeOpts DefaultEncodeOpts where - encodeOpts _ = defaultEncodeOptions - --- * Decoding - --- ** Instances - --- | Decode with 'decodeByNameWith' -instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, [a]) where - mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs - where p = Proxy :: Proxy opt - --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) [a] where - mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs - where p = Proxy :: Proxy opt - -instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, Vector a) where - mimeUnrender _ = decodeByNameWith (decodeOpts p) - where p = Proxy :: Proxy opt - --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Vector a) where - mimeUnrender _ = decodeWith (decodeOpts p) HasHeader - where p = Proxy :: Proxy opt - --- ** Decode Options - -class DecodeOpts a where - decodeOpts :: Proxy a -> DecodeOptions - -data DefaultDecodeOpts deriving (Typeable, Generic) - -instance DecodeOpts DefaultDecodeOpts where - decodeOpts _ = defaultDecodeOptions diff --git a/servant-cassava/tinc.yaml b/servant-cassava/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-cassava/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant diff --git a/sources.txt b/sources.txt index 14089dbb..61a62b1f 100644 --- a/sources.txt +++ b/sources.txt @@ -1,7 +1,6 @@ servant servant-server servant-client -servant-cassava servant-docs servant-foreign servant-js diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 23965e9f..8be94dce 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -2,7 +2,6 @@ flags: {} packages: - servant/ - servant-blaze/ -- servant-cassava/ - servant-client/ - servant-docs/ - servant-foreign/ diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml index dcfb8e5f..64e29fd3 100644 --- a/stack-ghc-8.0.1.yaml +++ b/stack-ghc-8.0.1.yaml @@ -4,7 +4,6 @@ flags: packages: - servant/ - servant-blaze/ -- servant-cassava/ - servant-client/ - servant-docs/ - servant-foreign/ diff --git a/stack.yaml b/stack.yaml index 947970a5..2d665e6b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,6 @@ flags: packages: - servant/ - servant-blaze/ -- servant-cassava/ - servant-client/ - servant-docs/ - servant-foreign/ From ccde5b08980450d22a5c5536952320ed735e2730 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 13 May 2016 12:45:30 +0200 Subject: [PATCH 62/74] Add source-repo and bug report For servant-foreign and servant-mock. --- servant-foreign/servant-foreign.cabal | 1 + servant-mock/servant-mock.cabal | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 305b161d..c90c0dd3 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -21,6 +21,7 @@ extra-source-files: include/*.h CHANGELOG.md README.md +bug-reports: http://github.com/haskell-servant/servant/issues source-repository head type: git location: http://github.com/haskell-servant/servant.git diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index ec8e0008..c7e1c2ab 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -15,6 +15,10 @@ category: Web build-type: Simple extra-source-files: include/*.h cabal-version: >=1.10 +bug-reports: http://github.com/haskell-servant/servant/issues +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git flag example description: Build the example too From 73bc0e3c1d95e24b08ac1352b39b14f2d977b7a3 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 13 May 2016 14:38:00 +0300 Subject: [PATCH 63/74] Remove servant-blaze and servant-lucid --- servant-blaze/LICENSE | 30 ------------------ servant-blaze/Setup.hs | 2 -- servant-blaze/include/overlapping-compat.h | 8 ----- servant-blaze/servant-blaze.cabal | 34 -------------------- servant-blaze/src/Servant/HTML/Blaze.hs | 35 --------------------- servant-blaze/tinc.yaml | 3 -- servant-lucid/LICENSE | 30 ------------------ servant-lucid/Setup.hs | 2 -- servant-lucid/include/overlapping-compat.h | 8 ----- servant-lucid/servant-lucid.cabal | 34 -------------------- servant-lucid/src/Servant/HTML/Lucid.hs | 36 ---------------------- servant-lucid/tinc.yaml | 3 -- sources.txt | 2 -- stack-ghc-7.8.4.yaml | 2 -- stack-ghc-8.0.1.yaml | 4 --- stack.yaml | 2 -- 16 files changed, 235 deletions(-) delete mode 100644 servant-blaze/LICENSE delete mode 100644 servant-blaze/Setup.hs delete mode 100644 servant-blaze/include/overlapping-compat.h delete mode 100644 servant-blaze/servant-blaze.cabal delete mode 100644 servant-blaze/src/Servant/HTML/Blaze.hs delete mode 100644 servant-blaze/tinc.yaml delete mode 100644 servant-lucid/LICENSE delete mode 100644 servant-lucid/Setup.hs delete mode 100644 servant-lucid/include/overlapping-compat.h delete mode 100644 servant-lucid/servant-lucid.cabal delete mode 100644 servant-lucid/src/Servant/HTML/Lucid.hs delete mode 100644 servant-lucid/tinc.yaml diff --git a/servant-blaze/LICENSE b/servant-blaze/LICENSE deleted file mode 100644 index 1d0ce8da..00000000 --- a/servant-blaze/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015-2016, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Julian K. Arni nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-blaze/Setup.hs b/servant-blaze/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-blaze/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-blaze/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal deleted file mode 100644 index fdb1bc6d..00000000 --- a/servant-blaze/servant-blaze.cabal +++ /dev/null @@ -1,34 +0,0 @@ --- Initial servant-blaze.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-blaze -version: 0.7.1 -synopsis: Blaze-html support for servant --- description: -homepage: http://haskell-servant.readthedocs.org/ -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2015-2016 Servant Contributors -category: Web -build-type: Simple -extra-source-files: include/*.h -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -library - exposed-modules: Servant.HTML.Blaze - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , servant == 0.7.* - , http-media - , blaze-html - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include - ghc-options: -Wall diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs deleted file mode 100644 index 822a7ae9..00000000 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "overlapping-compat.h" --- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s --- `ToMarkup` class and `Html` datatype. --- You should only need to import this module for it's instances and the --- `HTML` datatype.: --- --- >>> type Eg = Get '[HTML] a --- --- Will then check that @a@ has a `ToMarkup` instance, or is `Html`. -module Servant.HTML.Blaze where - -import Data.Typeable (Typeable) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..)) -import Text.Blaze.Html (Html, ToMarkup, toHtml) -import Text.Blaze.Html.Renderer.Utf8 (renderHtml) - -data HTML deriving Typeable - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - -instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where - mimeRender _ = renderHtml . toHtml - -instance OVERLAPPING_ MimeRender HTML Html where - mimeRender _ = renderHtml - diff --git a/servant-blaze/tinc.yaml b/servant-blaze/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-blaze/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant diff --git a/servant-lucid/LICENSE b/servant-lucid/LICENSE deleted file mode 100644 index 1d0ce8da..00000000 --- a/servant-lucid/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015-2016, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Julian K. Arni nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-lucid/Setup.hs b/servant-lucid/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-lucid/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-lucid/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal deleted file mode 100644 index cf726c02..00000000 --- a/servant-lucid/servant-lucid.cabal +++ /dev/null @@ -1,34 +0,0 @@ --- Initial servant-lucid.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-lucid -version: 0.7.1 -synopsis: Servant support for lucid --- description: -homepage: http://haskell-servant.readthedocs.org/ -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2015-2016 Servant Contributors -category: Web -build-type: Simple -extra-source-files: include/*.h -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -library - exposed-modules: Servant.HTML.Lucid - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , http-media - , lucid - , servant == 0.7.* - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include - ghc-options: -Wall diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs deleted file mode 100644 index ec62a21c..00000000 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "overlapping-compat.h" - --- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s --- `ToHtml` class and `Html` datatype. --- You should only need to import this module for it's instances and the --- `HTML` datatype.: --- --- >>> type Eg = Get '[HTML] a --- --- Will then check that @a@ has a `ToHtml` instance, or is `Html`. -module Servant.HTML.Lucid where - -import Data.Typeable (Typeable) -import Lucid (Html, ToHtml (..), renderBS) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..)) - -data HTML deriving Typeable - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - -instance OVERLAPPABLE_ - ToHtml a => MimeRender HTML a where - mimeRender _ = renderBS . toHtml - -instance OVERLAPPING_ - MimeRender HTML (Html a) where - mimeRender _ = renderBS diff --git a/servant-lucid/tinc.yaml b/servant-lucid/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-lucid/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant diff --git a/sources.txt b/sources.txt index 61a62b1f..06ff7ed8 100644 --- a/sources.txt +++ b/sources.txt @@ -4,6 +4,4 @@ servant-client servant-docs servant-foreign servant-js -servant-blaze -servant-lucid servant-mock diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 8be94dce..c138c647 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -1,12 +1,10 @@ flags: {} packages: - servant/ -- servant-blaze/ - servant-client/ - servant-docs/ - servant-foreign/ - servant-js/ -- servant-lucid/ - servant-mock/ - servant-server/ extra-deps: diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml index 64e29fd3..84321fd2 100644 --- a/stack-ghc-8.0.1.yaml +++ b/stack-ghc-8.0.1.yaml @@ -3,12 +3,10 @@ flags: old-locale: false packages: - servant/ -- servant-blaze/ - servant-client/ - servant-docs/ - servant-foreign/ - servant-js/ -- servant-lucid/ - servant-mock/ - servant-server/ setup-info: @@ -48,7 +46,6 @@ extra-deps: - bytestring-builder-0.10.6.0.0 - bytestring-conversion-0.3.1 - case-insensitive-1.2.0.6 -- cassava-0.4.5.0 - cereal-0.5.1.0 - charset-0.3.7.1 - cmdargs-0.10.14 @@ -91,7 +88,6 @@ extra-deps: - language-ecmascript-0.17.1.0 - lens-4.14 - lifted-base-0.2.3.6 -- lucid-2.9.5 - memory-0.12 - mime-types-0.1.0.7 - mmorph-1.0.6 diff --git a/stack.yaml b/stack.yaml index 2d665e6b..bb76925e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,12 +3,10 @@ flags: example: false packages: - servant/ -- servant-blaze/ - servant-client/ - servant-docs/ - servant-foreign/ - servant-js/ -- servant-lucid/ - servant-mock/ - servant-server/ - doc/tutorial From 69d3e7355ae3f1a90e5c1102d112fd05a2b2448d Mon Sep 17 00:00:00 2001 From: Christopher League Date: Tue, 24 May 2016 23:11:54 -0400 Subject: [PATCH 64/74] Fix minor typo in tutorial --- doc/tutorial/ApiType.lhs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index 54022bb8..53aa187f 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -297,7 +297,7 @@ Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). When protecting endpoints with basic authentication, we need to specify two items: -1. The **realm** of authentication as per the Basic Authentictaion spec. +1. The **realm** of authentication as per the Basic Authentication spec. 2. The datatype returned by the server after authentication is verified. This is usually a `User` or `Customer` type datatype. From bd3670f54df1ac90d38af57ac76b6d36bccc6f22 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 25 May 2016 17:33:18 +0200 Subject: [PATCH 65/74] Remove host param from servant-client README. --- servant-client/README.md | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/servant-client/README.md b/servant-client/README.md index b1ef54b5..a2d40be2 100644 --- a/servant-client/README.md +++ b/servant-client/README.md @@ -13,9 +13,8 @@ type MyApi = "books" :> Get '[JSON] [Book] -- GET /books myApi :: Proxy MyApi myApi = Proxy -getAllBooks :: ExceptT String IO [Book] -postNewBook :: Book -> ExceptT String IO Book +getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book] +postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book -- 'client' allows you to produce operations to query an API from a client. -(getAllBooks :<|> postNewBook) = client myApi host - where host = BaseUrl Http "localhost" 8080 +(getAllBooks :<|> postNewBook) = client myApi ``` From 323883556c3979db76128fe4d4ac55fc680f8736 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Christian=20Kj=C3=A6r?= Date: Sat, 28 May 2016 01:03:48 +0200 Subject: [PATCH 66/74] Update stack.yaml to LTS 6.0 All the missing extra-deps are now on Stackage, and the ones that were forced to a later version have also been updated, so the LTS should suffice. --- stack.yaml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/stack.yaml b/stack.yaml index bb76925e..65fbd685 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,11 +11,4 @@ packages: - servant-server/ - doc/tutorial extra-deps: -- base-compat-0.9.0 -- engine-io-wai-1.0.2 -- control-monad-omega-0.3.1 -- should-not-typecheck-2.0.1 -- markdown-unlit-0.4.0 -- aeson-0.11.0.0 -- fail-4.9.0.0 -resolver: nightly-2016-03-17 +resolver: lts-6.0 From 778ec34156b639bfdaa2d2419d6835be04034330 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 28 May 2016 16:25:08 +0300 Subject: [PATCH 67/74] Use nightly-2016-05-27 for in stack-ghc-8.0.1.yaml --- stack-ghc-8.0.1.yaml | 156 +------------------------------------------ 1 file changed, 3 insertions(+), 153 deletions(-) diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml index 84321fd2..8861e1a9 100644 --- a/stack-ghc-8.0.1.yaml +++ b/stack-ghc-8.0.1.yaml @@ -1,6 +1,4 @@ -flags: - time-locale-compat: - old-locale: false +resolver: nightly-2016-05-27 packages: - servant/ - servant-client/ @@ -9,153 +7,5 @@ packages: - servant-js/ - servant-mock/ - servant-server/ -setup-info: - ghc: - linux64: - 8.0.0.20160421: - url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-unknown-linux.tar.xz - macosx: - 8.0.0.20160421: - url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-apple-darwin.tar.xz -extra-deps: -- Diff-0.3.4 -- HUnit-1.3.1.1 -- QuickCheck-2.8.2 -- StateVar-1.1.0.4 -- adjunctions-4.3 -- aeson-0.11.2.0 -- aeson-pretty-0.7.2 -- ansi-terminal-0.6.2.3 -- ansi-wl-pprint-0.6.7.3 -- appar-0.1.4 -- asn1-encoding-0.9.3 -- asn1-parse-0.9.4 -- asn1-types-0.3.2 -- async-2.1.0 -- attoparsec-0.13.0.2 -- auto-update-0.1.4 -- base-compat-0.9.1 -- base-orphans-0.5.4 -- base64-bytestring-1.0.0.1 -- bifunctors-5.3 -- blaze-builder-0.4.0.2 -- blaze-html-0.8.1.1 -- blaze-markup-0.7.0.3 -- byteable-0.1.1 -- byteorder-1.0.4 -- bytestring-builder-0.10.6.0.0 -- bytestring-conversion-0.3.1 -- case-insensitive-1.2.0.6 -- cereal-0.5.1.0 -- charset-0.3.7.1 -- cmdargs-0.10.14 -- comonad-5 -- connection-0.2.5 -- contravariant-1.4 -- control-monad-omega-0.3.1 -- cookie-0.4.2 -- cryptonite-0.15 -- data-default-class-0.0.1 -- distributive-0.5.0.2 -- dlist-0.7.1.2 -- doctest-0.11.0 -- double-conversion-2.0.1.0 -- easy-file-0.2.1 -- exceptions-0.8.2.1 -- fail-4.9.0.0 -- fast-logger-2.4.6 -- file-embed-0.0.10 -- filemanip-0.3.6.3 -- free-4.12.4 -- ghc-paths-0.1.0.9 -- hashable-1.2.4.0 -- hex-0.1.2 -- hourglass-0.2.10 -- hspec-2.2.3 -- hspec-core-2.2.3 -- hspec-discover-2.2.3 -- hspec-expectations-0.7.2 -- hspec-wai-0.6.6 -- http-api-data-0.2.2 -- http-client-0.4.28 -- http-client-tls-0.2.4 -- http-date-0.0.6.1 -- http-media-0.6.3 -- http-types-0.9 -- http2-1.6.0 -- iproute-1.7.0 -- kan-extensions-5.0.1 -- language-ecmascript-0.17.1.0 -- lens-4.14 -- lifted-base-0.2.3.6 -- memory-0.12 -- mime-types-0.1.0.7 -- mmorph-1.0.6 -- monad-control-1.0.1.0 -- mtl-2.2.1 -- network-2.6.2.1 -- network-uri-2.6.1.0 -- old-locale-1.0.0.7 -- old-time-1.1.0.3 -- optparse-applicative-0.12.1.0 -- parallel-3.2.1.0 -- parsec-3.1.9 -- pem-0.2.2 -- prelude-extras-0.4.0.3 -- primitive-0.6.1.0 -- profunctors-5.2 -- psqueues-0.2.2.1 -- quickcheck-instances-0.3.12 -- quickcheck-io-0.1.2 -- random-1.1 -- reflection-2.1.2 -- resourcet-1.1.7.4 -- safe-0.3.9 -- scientific-0.3.4.6 -- semigroupoids-5.0.1 -- semigroups-0.18.1 -- setenv-0.1.1.3 -- should-not-typecheck-2.1.0 -- simple-sendfile-0.2.21 -- socks-0.5.5 -- split-0.2.3.1 -- stm-2.4.4.1 -- streaming-commons-0.1.15.4 -- string-conversions-0.4 -- stringsearch-0.3.6.6 -- syb-0.6 -- system-filepath-0.4.13.4 -- tagged-0.8.4 -- tagshare-0.0 -- temporary-1.2.0.4 -- testing-feat-0.4.0.3 -- text-1.2.2.1 -- tf-random-0.5 -- time-locale-compat-0.1.1.1 -- tls-1.3.7 -- transformers-base-0.4.4 -- transformers-compat-0.5.1.4 -- uniplate-1.6.12 -- unix-compat-0.4.1.4 -- unix-time-0.3.6 -- unordered-containers-0.2.7.0 -- url-2.1.3 -- utf8-string-1.0.1.1 -- vault-0.3.0.6 -- vector-0.11.0.0 -- void-0.7.1 -- wai-3.2.1 -- wai-app-static-3.1.5 -- wai-extra-3.0.15.1 -- wai-logger-2.2.7 -- warp-3.2.6 -- with-location-0.1.0 -- wl-pprint-1.2 -- word8-0.1.2 -- x509-1.6.3 -- x509-store-1.6.1 -- x509-system-1.6.3 -- x509-validation-1.6.3 -- zlib-0.6.1.1 -compiler-check: match-exact -resolver: ghc-8.0.0.20160421 +extra-deps: [] +flags: {} From 3c27ff5a32462899c6968f5c6e170ea3d61dc51c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 11 May 2016 16:51:39 +0800 Subject: [PATCH 68/74] added test script for stack files (and fixed stack for ghc-7.8) --- scripts/test-stack.sh | 11 +++++++++ servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 1 + servant/src/Servant/API/Alternative.hs | 2 -- servant/src/Servant/Utils/Enter.hs | 3 --- servant/test/Servant/API/ContentTypesSpec.hs | 7 +++--- stack-ghc-7.8.4.yaml | 26 +++++++++++--------- stack.yaml | 4 +-- 8 files changed, 32 insertions(+), 24 deletions(-) create mode 100755 scripts/test-stack.sh diff --git a/scripts/test-stack.sh b/scripts/test-stack.sh new file mode 100755 index 00000000..b93d6107 --- /dev/null +++ b/scripts/test-stack.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -o nounset +set -o errexit + +for stack_file in stack*.yaml ; do + echo testing $stack_file... + export STACK_YAML=$stack_file + stack setup + stack test --fast --ghc-options="-Werror" +done diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 7ce9b184..6b7997fc 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -67,7 +67,7 @@ library , transformers >= 0.3 && < 0.6 , transformers-compat>= 0.4 , wai >= 3.0 && < 3.3 - , wai-app-static >= 3.0 && < 3.2 + , wai-app-static >= 3.1 && < 3.2 , warp >= 3.0 && < 3.3 , word8 == 0.1.* diff --git a/servant/servant.cabal b/servant/servant.cabal index c500894d..694958a9 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -104,6 +104,7 @@ test-suite spec Servant.Utils.LinksSpec build-depends: base == 4.* + , base-compat , aeson , attoparsec , bytestring diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index a7651d3c..8a8a693f 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} -#if !MIN_VERSION_base(4,8,0) {-# LANGUAGE DeriveFoldable #-} -#endif {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} diff --git a/servant/src/Servant/Utils/Enter.hs b/servant/src/Servant/Utils/Enter.hs index 35168dc2..12f7a530 100644 --- a/servant/src/Servant/Utils/Enter.hs +++ b/servant/src/Servant/Utils/Enter.hs @@ -11,9 +11,6 @@ module Servant.Utils.Enter where import qualified Control.Category as C -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except -#endif import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index e29900e2..1a155b5c 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -8,10 +8,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid -#endif +import Prelude () +import Prelude.Compat + import Control.Arrow import Data.Aeson import Data.ByteString.Char8 (ByteString, append, pack) diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index c138c647..0fe58482 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -8,17 +8,21 @@ packages: - servant-mock/ - servant-server/ extra-deps: -- base-compat-0.9.0 -- hspec-2.2.0 -- hspec-core-2.2.0 -- hspec-discover-2.2.0 -- hspec-expectations-0.7.2 -- doctest-0.10.1 -- engine-io-1.2.10 -- engine-io-wai-1.0.3 -- socket-io-1.3.3 -- stm-delay-0.1.1.1 +- base-compat-0.9.1 - control-monad-omega-0.3.1 -- http-api-data-0.1.1.1 +- cryptonite-0.6 +- doctest-0.11.0 +- hspec-2.2.3 +- hspec-core-2.2.3 +- hspec-discover-2.2.3 +- hspec-expectations-0.7.2 +- http-api-data-0.2.2 +- primitive-0.6.1.0 +- servant-0.7.1 +- servant-client-0.7.1 +- servant-docs-0.7.1 +- servant-server-0.7.1 - should-not-typecheck-2.1.0 +- time-locale-compat-0.1.1.1 +- wai-app-static-3.1.5 resolver: lts-2.22 diff --git a/stack.yaml b/stack.yaml index 65fbd685..95599455 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,4 @@ -flags: - servant-js: - example: false +flags: {} packages: - servant/ - servant-client/ From d81e15b5e5a718e250242e5e8ca841f4a5554dcc Mon Sep 17 00:00:00 2001 From: Erlend Hamberg Date: Tue, 14 Jun 2016 14:20:35 +0200 Subject: [PATCH 69/74] Fix example `MimeRender` instance The `MimeRender` instance in the documentation was incomplete and expected one more argument. --- 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 f9c46406..8dc1d7ac 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -154,7 +154,7 @@ newtype AcceptHeader = AcceptHeader BS.ByteString -- > instance Accept MyContentType where -- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > --- > instance Show a => MimeRender MyContentType where +-- > instance Show a => MimeRender MyContentType a where -- > mimeRender _ val = pack ("This is MINE! " ++ show val) -- > -- > type MyAPI = "path" :> Get '[MyContentType] Int From 0f1e5475b95157ff11505c452b6977f97ea7fb21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 7 Jun 2016 20:56:39 +0800 Subject: [PATCH 70/74] doc: add two more examples for servant projects --- doc/examples.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/doc/examples.md b/doc/examples.md index b861ddc1..47e73aa1 100644 --- a/doc/examples.md +++ b/doc/examples.md @@ -17,3 +17,21 @@ A custom monad that can replace `IO` in servant applications. It adds among other things logging functionality and a reader monad (for database connections). A full usage example of servant/diener is also provided. + + +- **[example-servant-elm](https://github.com/haskell-servant/example-servant-elm)**: + + An example for a project consisting of + + - a backend web server written using **servant-server**, + - a frontend written in [elm](http://elm-lang.org/) using + [servant-elm](https://github.com/mattjbray/servant-elm) to generate client + functions in elm for the API, + - test-suites for both the backend and the frontend. + + +- **[example-servant-persistent](https://github.com/haskell-servant/example-servant-persistent)**: + + An example for a web server written with **servant-server** and + [persistent](https://www.stackage.org/package/persistent) for writing data + into a database. From 023368c3967b862dc5c4e8a1abba28d69abeb6b0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 1 Jul 2016 09:58:23 -0300 Subject: [PATCH 71/74] CPP deprecated parseUrl function. --- servant-client/src/Servant/Common/Req.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 18703141..1dedde71 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -103,7 +103,7 @@ setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = - setheaders . setAccept . setrqb . setQS <$> parseUrl url + setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url where url = show $ nullURI { uriScheme = case reqScheme of Http -> "http:" @@ -129,6 +129,9 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = | not . null . reqAccept $ req] } toProperHeader (name, val) = (fromString name, encodeUtf8 val) +#if !MIN_VERSION_http_client(0,4,30) + parseUrlThrow = parseUrl +#endif -- * performing requests From 5effdfdbbbe738908d41272705949bc7244a9c0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 2 Jun 2016 15:49:55 +0800 Subject: [PATCH 72/74] Rename type variables 'layout' and 'sublayout' to 'api' --- servant-client/src/Servant/Client.hs | 84 +++++++------- servant-docs/src/Servant/Docs/Internal.hs | 106 +++++++++--------- .../src/Servant/Docs/Internal/Pretty.hs | 4 +- .../src/Servant/Foreign/Internal.hs | 100 ++++++++--------- servant-js/src/Servant/JS.hs | 2 +- .../test/Servant/JSSpec/CustomHeaders.hs | 24 ++-- servant-server/src/Servant/Server.hs | 12 +- servant-server/src/Servant/Server/Internal.hs | 78 ++++++------- 8 files changed, 205 insertions(+), 205 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ee27846c..fd3ab24b 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -57,15 +57,15 @@ import Servant.Common.Req -- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] -- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient layout => Proxy layout -> Client layout +client :: HasClient api => Proxy api -> Client api client p = clientWithRoute p defReq -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. -class HasClient layout where - type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> Client layout +class HasClient api where + type Client api :: * + clientWithRoute :: Proxy api -> Req -> Client api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -106,14 +106,14 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where -- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book -- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) - => HasClient (Capture capture a :> sublayout) where +instance (KnownSymbol capture, ToHttpApiData a, HasClient api) + => HasClient (Capture capture a :> api) where - type Client (Capture capture a :> sublayout) = - a -> Client sublayout + type Client (Capture capture a :> api) = + a -> Client api clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (appendToPath p req) where p = unpack (toUrlPiece val) @@ -186,14 +186,14 @@ instance OVERLAPPING_ -- > viewReferer = client myApi -- > -- then you can just use "viewRefer" to query that endpoint -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (Header sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (Header sym a :> api) where - type Client (Header sym a :> sublayout) = - Maybe a -> Client sublayout + type Client (Header sym a :> api) = + Maybe a -> Client api clientWithRoute Proxy req mval = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval @@ -203,14 +203,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. -instance HasClient sublayout - => HasClient (HttpVersion :> sublayout) where +instance HasClient api + => HasClient (HttpVersion :> api) where - type Client (HttpVersion :> sublayout) = - Client sublayout + type Client (HttpVersion :> api) = + Client api clientWithRoute Proxy = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -237,15 +237,15 @@ instance HasClient sublayout -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (QueryParam sym a :> api) where - type Client (QueryParam sym a :> sublayout) = - Maybe a -> Client sublayout + type Client (QueryParam sym a :> api) = + Maybe a -> Client api -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (maybe req (flip (appendToQueryString pname) req . Just) mparamText @@ -282,14 +282,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' -- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (QueryParams sym a :> api) where - type Client (QueryParams sym a :> sublayout) = - [a] -> Client sublayout + type Client (QueryParams sym a :> api) = + [a] -> Client api clientWithRoute Proxy req paramlist = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' @@ -320,14 +320,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient sublayout) - => HasClient (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, HasClient api) + => HasClient (QueryFlag sym :> api) where - type Client (QueryFlag sym :> sublayout) = - Bool -> Client sublayout + type Client (QueryFlag sym :> api) = + Bool -> Client api clientWithRoute Proxy req flag = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (if flag then appendToQueryString paramname Nothing req else req @@ -364,14 +364,14 @@ instance HasClient Raw where -- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book -- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient sublayout) - => HasClient (ReqBody (ct ': cts) a :> sublayout) where +instance (MimeRender ct a, HasClient api) + => HasClient (ReqBody (ct ': cts) a :> api) where - type Client (ReqBody (ct ': cts) a :> sublayout) = - a -> Client sublayout + type Client (ReqBody (ct ': cts) a :> api) = + a -> Client api clientWithRoute Proxy req body = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) @@ -379,11 +379,11 @@ instance (MimeRender ct a, HasClient sublayout) ) -- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where - type Client (path :> sublayout) = Client sublayout +instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where + type Client (path :> api) = Client api clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute (Proxy :: Proxy api) (appendToPath p req) where p = symbolVal (Proxy :: Proxy path) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 2d0cf673..0672dc15 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -163,7 +163,7 @@ data DocNote = DocNote -- -- These are intended to be built using extraInfo. -- Multiple ExtraInfo may be combined with the monoid instance. -newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action) +newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action) instance Monoid (ExtraInfo a) where mempty = ExtraInfo mempty ExtraInfo a `mappend` ExtraInfo b = @@ -300,11 +300,11 @@ makeLenses ''Action -- default way to create documentation. -- -- prop> docs == docsWithOptions defaultDocOptions -docs :: HasDocs layout => Proxy layout -> API +docs :: HasDocs api => Proxy api -> API docs p = docsWithOptions p defaultDocOptions -- | Generate the docs for a given API that implements 'HasDocs'. -docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API +docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API docsWithOptions p = docsFor p (defEndpoint, defAction) -- | Closed type family, check if endpoint is exactly within API. @@ -316,7 +316,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn e e = () --- | Create an 'ExtraInfo' that is garunteed to be within the given API layout. +-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout. -- -- The safety here is to ensure that you only add custom documentation to an -- endpoint that actually exists within your API. @@ -329,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where -- > , DocNote "Second secton" ["And some more"] -- > ] -extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) - => Proxy endpoint -> Action -> ExtraInfo layout +extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint) + => Proxy endpoint -> Action -> ExtraInfo api extraInfo p action = let api = docsFor p (defEndpoint, defAction) defaultDocOptions -- Assume one endpoint, HasLink constraint means that we should only ever @@ -349,7 +349,7 @@ extraInfo p action = -- 'extraInfo'. -- -- If you only want to add an introduction, use 'docsWithIntros'. -docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API +docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API docsWith opts intros (ExtraInfo endpoints) p = docsWithOptions p opts & apiIntros <>~ intros @@ -358,13 +358,13 @@ docsWith opts intros (ExtraInfo endpoints) p = -- | Generate the docs for a given API that implements 'HasDocs' with with any -- number of introduction(s) -docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API +docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API docsWithIntros intros = docsWith defaultDocOptions intros mempty -- | The class that abstracts away the impact of API combinators -- on documentation generation. -class HasDocs layout where - docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API +class HasDocs api where + docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API -- | The class that lets us display a sample input or output in the supported -- content-types when generating documentation for endpoints that either: @@ -675,26 +675,26 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. instance OVERLAPPABLE_ - (HasDocs layout1, HasDocs layout2) - => HasDocs (layout1 :<|> layout2) where + (HasDocs a, HasDocs b) + => HasDocs (a :<|> b) where docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) - where p1 :: Proxy layout1 + where p1 :: Proxy a p1 = Proxy - p2 :: Proxy layout2 + p2 :: Proxy b p2 = Proxy -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. -instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) - => HasDocs (Capture sym a :> sublayout) where +instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) + => HasDocs (Capture sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action') + docsFor subApiP (endpoint', action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api captureP = Proxy :: Proxy (Capture sym a) action' = over captures (|> toCapture captureP) action @@ -736,43 +736,43 @@ instance OVERLAPPING_ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance (KnownSymbol sym, HasDocs sublayout) - => HasDocs (Header sym a :> sublayout) where +instance (KnownSymbol sym, HasDocs api) + => HasDocs (Header sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api action' = over headers (|> headername) action headername = T.pack $ symbolVal (Proxy :: Proxy sym) -instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) - => HasDocs (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api) + => HasDocs (QueryParam sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryParam sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) - => HasDocs (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api) + => HasDocs (QueryParams sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryParams sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout) - => HasDocs (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api) + => HasDocs (QueryFlag sym :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryFlag sym) action' = over params (|> toParam paramP) action @@ -785,49 +785,49 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) - => HasDocs (ReqBody (ct ': cts) a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) + => HasDocs (ReqBody (ct ': cts) a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a -instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where +instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action) + docsFor subApiP (endpoint', action) - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api endpoint' = endpoint & path <>~ [symbolVal pa] pa = Proxy :: Proxy path -instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where +instance HasDocs api => HasDocs (RemoteHost :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where +instance HasDocs api => HasDocs (IsSecure :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where +instance HasDocs api => HasDocs (HttpVersion :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (Vault :> sublayout) where +instance HasDocs api => HasDocs (Vault :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where - docsFor Proxy = docsFor (Proxy :: Proxy sublayout) +instance HasDocs api => HasDocs (WithNamedContext name context api) where + docsFor Proxy = docsFor (Proxy :: Proxy api) -instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where +instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where docsFor Proxy (endpoint, action) = - docsFor (Proxy :: Proxy sublayout) (endpoint, action') + docsFor (Proxy :: Proxy api) (endpoint, action') where authProxy = Proxy :: Proxy (BasicAuth realm usr) action' = over authInfo (|> toAuthInfo authProxy) action diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs index 13275467..993526b7 100644 --- a/servant-docs/src/Servant/Docs/Internal/Pretty.hs +++ b/servant-docs/src/Servant/Docs/Internal/Pretty.hs @@ -29,12 +29,12 @@ instance ToJSON a => MimeRender PrettyJSON a where -- @ -- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) -- @ -pretty :: Proxy layout -> Proxy (Pretty layout) +pretty :: Proxy api -> Proxy (Pretty api) pretty Proxy = Proxy -- | Replace all JSON content types with PrettyJSON. -- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. -type family Pretty (layout :: k) :: k where +type family Pretty (api :: k) :: k where Pretty (x :<|> y) = Pretty x :<|> Pretty y Pretty (x :> y) = Pretty x :> Pretty y Pretty (Get cs r) = Get (Pretty cs) r diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 4e457897..f29bd198 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -184,9 +184,9 @@ data NoTypes instance HasForeignType NoTypes () ftype where typeFor _ _ _ = () -class HasForeign lang ftype (layout :: *) where - type Foreign ftype layout :: * - foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout +class HasForeign lang ftype (api :: *) where + type Foreign ftype api :: * + foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api instance (HasForeign lang ftype a, HasForeign lang ftype b) => HasForeign lang ftype (a :<|> b) where @@ -196,12 +196,12 @@ instance (HasForeign lang ftype a, HasForeign lang ftype b) foreignFor lang ftype (Proxy :: Proxy a) req :<|> foreignFor lang ftype (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout) - => HasForeign lang ftype (Capture sym t :> sublayout) where - type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout +instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api) + => HasForeign lang ftype (Capture sym t :> api) where + type Foreign ftype (Capture sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = - foreignFor lang Proxy (Proxy :: Proxy sublayout) $ + foreignFor lang Proxy (Proxy :: Proxy api) $ req & reqUrl . path <>~ [Segment (Cap arg)] & reqFuncName . _FunctionName %~ (++ ["by", str]) where @@ -224,9 +224,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method) method = reflectMethod (Proxy :: Proxy method) methodLC = toLower $ decodeUtf8 method -instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) - => HasForeign lang ftype (Header sym a :> sublayout) where - type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api) + => HasForeign lang ftype (Header sym a :> api) where + type Foreign ftype (Header sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg] @@ -235,14 +235,14 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su arg = Arg { _argName = PathSegment hname , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } - subP = Proxy :: Proxy sublayout + subP = Proxy :: Proxy api -instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) - => HasForeign lang ftype (QueryParam sym a :> sublayout) where - type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api) + => HasForeign lang ftype (QueryParam sym a :> api) where + type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = - foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] where str = pack . symbolVal $ (Proxy :: Proxy sym) @@ -251,11 +251,11 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } instance - (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout) - => HasForeign lang ftype (QueryParams sym a :> sublayout) where - type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout + (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api) + => HasForeign lang ftype (QueryParams sym a :> api) where + type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = - foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg List] where str = pack . symbolVal $ (Proxy :: Proxy sym) @@ -264,12 +264,12 @@ instance , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } instance - (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout) - => HasForeign lang ftype (QueryFlag sym :> sublayout) where - type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout + (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api) + => HasForeign lang ftype (QueryFlag sym :> api) where + type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] where str = pack . symbolVal $ (Proxy :: Proxy sym) @@ -284,20 +284,20 @@ instance HasForeign lang ftype Raw where req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method -instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout) - => HasForeign lang ftype (ReqBody list a :> sublayout) where - type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout +instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api) + => HasForeign lang ftype (ReqBody list a :> api) where + type Foreign ftype (ReqBody list a :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype (Proxy :: Proxy api) $ req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a)) -instance (KnownSymbol path, HasForeign lang ftype sublayout) - => HasForeign lang ftype (path :> sublayout) where - type Foreign ftype (path :> sublayout) = Foreign ftype sublayout +instance (KnownSymbol path, HasForeign lang ftype api) + => HasForeign lang ftype (path :> api) where + type Foreign ftype (path :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype (Proxy :: Proxy api) $ req & reqUrl . path <>~ [Segment (Static (PathSegment str))] & reqFuncName . _FunctionName %~ (++ [str]) where @@ -305,39 +305,39 @@ instance (KnownSymbol path, HasForeign lang ftype sublayout) Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang ftype sublayout - => HasForeign lang ftype (RemoteHost :> sublayout) where - type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout +instance HasForeign lang ftype api + => HasForeign lang ftype (RemoteHost :> api) where + type Foreign ftype (RemoteHost :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) req + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout - => HasForeign lang ftype (IsSecure :> sublayout) where - type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout +instance HasForeign lang ftype api + => HasForeign lang ftype (IsSecure :> api) where + type Foreign ftype (IsSecure :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) req + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where - type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout +instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where + type Foreign ftype (Vault :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) req + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout => - HasForeign lang ftype (WithNamedContext name context sublayout) where +instance HasForeign lang ftype api => + HasForeign lang ftype (WithNamedContext name context api) where - type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout + type Foreign ftype (WithNamedContext name context api) = Foreign ftype api - foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout) + foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) -instance HasForeign lang ftype sublayout - => HasForeign lang ftype (HttpVersion :> sublayout) where - type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout +instance HasForeign lang ftype api + => HasForeign lang ftype (HttpVersion :> api) where + type Foreign ftype (HttpVersion :> api) = Foreign ftype api foreignFor lang ftype Proxy req = - foreignFor lang ftype (Proxy :: Proxy sublayout) req + foreignFor lang ftype (Proxy :: Proxy api) req -- | Utility class used by 'listFromAPI' which computes -- the data needed to generate a function for each endpoint diff --git a/servant-js/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 3494ca69..9a66688c 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -128,7 +128,7 @@ import Servant.Foreign (listFromAPI) -- | Generate the data necessary to generate javascript code -- for all the endpoints of an API, as ':<|>'-separated values -- of type 'AjaxReq'. -javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout +javascript :: HasForeign NoTypes () api => Proxy api -> Foreign () api javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq -- | Directly generate all the javascript functions for your API diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 6d881aa4..862443f2 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -23,11 +23,11 @@ import Servant.JS.Internal -- using -- Basic, Digest, whatever. data Authorization (sym :: Symbol) a -instance (KnownSymbol sym, HasForeign lang () sublayout) - => HasForeign lang () (Authorization sym a :> sublayout) where - type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout +instance (KnownSymbol sym, HasForeign lang () api) + => HasForeign lang () (Authorization sym a :> api) where + type Foreign () (Authorization sym a :> api) = Foreign () api - foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "Authorization" ()) $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] @@ -37,11 +37,11 @@ instance (KnownSymbol sym, HasForeign lang () sublayout) -- | This is a combinator that fetches an X-MyLovelyHorse header. data MyLovelyHorse a -instance (HasForeign lang () sublayout) - => HasForeign lang () (MyLovelyHorse a :> sublayout) where - type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout +instance (HasForeign lang () api) + => HasForeign lang () (MyLovelyHorse a :> api) where + type Foreign () (MyLovelyHorse a :> api) = Foreign () api - foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" @@ -49,11 +49,11 @@ instance (HasForeign lang () sublayout) -- | This is a combinator that fetches an X-WhatsForDinner header. data WhatsForDinner a -instance (HasForeign lang () sublayout) - => HasForeign lang () (WhatsForDinner a :> sublayout) where - type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout +instance (HasForeign lang () api) + => HasForeign lang () (WhatsForDinner a :> api) where + type Foreign () (WhatsForDinner a :> api) = Foreign () api - foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6f4f0c22..259d2f05 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -130,11 +130,11 @@ import Servant.Utils.Enter -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application +serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -serveWithContext :: (HasServer layout context) - => Proxy layout -> Context context -> Server layout -> Application +serveWithContext :: (HasServer api context) + => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = toApplication (runRouter (route p context (emptyDelayed (Route server)))) @@ -189,12 +189,12 @@ serveWithContext p context server = -- that one takes precedence. If both parts fail, the \"better\" error -- code will be returned. -- -layout :: (HasServer layout '[]) => Proxy layout -> Text +layout :: (HasServer api '[]) => Proxy api -> Text layout p = layoutWithContext p EmptyContext -- | Variant of 'layout' that takes an additional 'Context'. -layoutWithContext :: (HasServer layout context) - => Proxy layout -> Context context -> Text +layoutWithContext :: (HasServer api context) + => Proxy api -> Context context -> Text layoutWithContext p context = routerLayout (route p context (emptyDelayed (FailFatal err501))) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5d02c96d..21374dbe 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -68,16 +68,16 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -class HasServer layout context where - type ServerT layout (m :: * -> *) :: * +class HasServer api context where + type ServerT api (m :: * -> *) :: * route :: - Proxy layout + Proxy api -> Context context - -> Delayed env (Server layout) + -> Delayed env (Server api) -> Router env -type Server layout = ServerT layout Handler +type Server api = ServerT api Handler -- * Instances @@ -118,15 +118,15 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) - => HasServer (Capture capture a :> sublayout) context where +instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) + => HasServer (Capture capture a :> api) context where - type ServerT (Capture capture a :> sublayout) m = - a -> ServerT sublayout m + type ServerT (Capture capture a :> api) m = + a -> ServerT api m route Proxy context d = CaptureRouter $ - route (Proxy :: Proxy sublayout) + route (Proxy :: Proxy api) context (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of Nothing -> delayedFail err400 @@ -236,15 +236,15 @@ instance OVERLAPPING_ -- > server = viewReferer -- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) - => HasServer (Header sym a :> sublayout) context where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) + => HasServer (Header sym a :> api) context where - type ServerT (Header sym a :> sublayout) m = - Maybe a -> ServerT sublayout m + type ServerT (Header sym a :> api) m = + Maybe a -> ServerT api m route Proxy context subserver = let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) - in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) + in route (Proxy :: Proxy api) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -268,11 +268,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) - => HasServer (QueryParam sym a :> sublayout) context where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) + => HasServer (QueryParam sym a :> api) context where - type ServerT (QueryParam sym a :> sublayout) m = - Maybe a -> ServerT sublayout m + type ServerT (QueryParam sym a :> api) m = + Maybe a -> ServerT api m route Proxy context subserver = let querytext r = parseQueryText $ rawQueryString r @@ -282,7 +282,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) context (passToServer subserver param) + in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -304,11 +304,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) - => HasServer (QueryParams sym a :> sublayout) context where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) + => HasServer (QueryParams sym a :> api) context where - type ServerT (QueryParams sym a :> sublayout) m = - [a] -> ServerT sublayout m + type ServerT (QueryParams sym a :> api) m = + [a] -> ServerT api m route Proxy context subserver = let querytext r = parseQueryText $ rawQueryString r @@ -317,7 +317,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- corresponding values parameters r = filter looksLikeParam (querytext r) values r = mapMaybe (convert . snd) (parameters r) - in route (Proxy :: Proxy sublayout) context (passToServer subserver values) + in route (Proxy :: Proxy api) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -335,11 +335,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) -- > server = getBooks -- > where getBooks :: Bool -> Handler [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout context) - => HasServer (QueryFlag sym :> sublayout) context where +instance (KnownSymbol sym, HasServer api context) + => HasServer (QueryFlag sym :> api) context where - type ServerT (QueryFlag sym :> sublayout) m = - Bool -> ServerT sublayout m + type ServerT (QueryFlag sym :> api) m = + Bool -> ServerT api m route Proxy context subserver = let querytext r = parseQueryText $ rawQueryString r @@ -347,7 +347,7 @@ instance (KnownSymbol sym, HasServer sublayout context) Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) context (passToServer subserver param) + in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -392,14 +392,14 @@ instance HasServer Raw context where -- > server = postBook -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout context - ) => HasServer (ReqBody list a :> sublayout) context where +instance ( AllCTUnrender list a, HasServer api context + ) => HasServer (ReqBody list a :> api) context where - type ServerT (ReqBody list a :> sublayout) m = - a -> ServerT sublayout m + type ServerT (ReqBody list a :> api) m = + a -> ServerT api m route Proxy context subserver = - route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck) + route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck) where bodyCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 @@ -416,15 +416,15 @@ instance ( AllCTUnrender list a, HasServer sublayout context Just (Right v) -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and --- pass the rest of the request path to @sublayout@. -instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where +-- pass the rest of the request path to @api@. +instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where - type ServerT (path :> sublayout) m = ServerT sublayout m + type ServerT (path :> api) m = ServerT api m route Proxy context subserver = pathRouter (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) context subserver) + (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where From dc9afe6405cac796320241e237d31970505fd5bc Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 5 Jul 2016 12:27:30 +0300 Subject: [PATCH 73/74] Add upper bounds http-client <0.5 --- servant-client/servant-client.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index fae87d88..949b0d29 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -42,7 +42,7 @@ library , bytestring , exceptions , http-api-data >= 0.1 && < 0.3 - , http-client + , http-client <0.5 , http-client-tls , http-media , http-types From 9cabc8d320c8c6b766cf78a9865e448ff7e7c0c2 Mon Sep 17 00:00:00 2001 From: mrkkrp Date: Thu, 7 Jul 2016 22:53:50 +0300 Subject: [PATCH 74/74] =?UTF-8?q?Add=20=E2=80=98HasLink=E2=80=99=20instanc?= =?UTF-8?q?e=20for=20=E2=80=98BasicAuth=E2=80=99?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Close #539. --- servant/src/Servant/Utils/Links.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index b2157c04..7c2929c9 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -106,6 +106,7 @@ import Prelude () import Prelude.Compat import Web.HttpApiData +import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) @@ -291,6 +292,10 @@ instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) +instance HasLink sub => HasLink (BasicAuth realm a :> sub) where + type MkLink (BasicAuth realm a :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = URI