From feef8caea2dea1f725e993ac4f69dcfb8a23ee80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 7 Jan 2016 23:59:54 +0100 Subject: [PATCH 1/7] add servant/.ghci --- servant/.ghci | 1 + 1 file changed, 1 insertion(+) create mode 100644 servant/.ghci diff --git a/servant/.ghci b/servant/.ghci new file mode 100644 index 00000000..e5c6777e --- /dev/null +++ b/servant/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h From 37afddf3a2a231e424dda74b063babf4d1bdccbf Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 11 Jan 2016 13:37:20 +0100 Subject: [PATCH 2/7] Re-add missing Header instance for docs. --- servant-docs/src/Servant/Docs/Internal.hs | 9 +++++++++ servant-docs/test/Servant/DocsSpec.hs | 6 ++++++ 2 files changed, 15 insertions(+) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 0c3e30ac..8167d667 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -707,6 +707,15 @@ instance OVERLAPPING_ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a +instance (KnownSymbol sym, HasDocs sublayout) + => HasDocs (Header sym a :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + 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 diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index d37f78c9..703ea795 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -63,6 +63,7 @@ spec = describe "Servant.Docs" $ do , ("zwei, kaks, kaks",(TT2,UT2,UT2)) ] + where tests md = do it "mentions supported content-types" $ do @@ -76,11 +77,15 @@ spec = describe "Servant.Docs" $ do md `shouldContain` "POST" md `shouldContain` "GET" + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." + it "contains response samples" $ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" it "contains request body samples" $ md `shouldContain` "17" + -- * APIs data Datatype1 = Datatype1 { dt1field1 :: String @@ -103,6 +108,7 @@ instance MimeRender PlainText Int where type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> Header "X-Test" Int :> Put '[JSON] Int data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) From 7f9758314e0c4316c43e450b84435668d65d2485 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Jan 2016 17:06:20 +0100 Subject: [PATCH 3/7] Build mock example by default. So that CI reports errors. --- servant-mock/servant-mock.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 7d8589d0..af444527 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -18,8 +18,7 @@ cabal-version: >=1.10 flag example description: Build the example too - manual: True - default: False + default: True library exposed-modules: From 5a7fe7662911ebe0bfa2bfcd0c2fc27d0e8c7f3f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Jan 2016 17:32:57 +0100 Subject: [PATCH 4/7] Add polykinds to servant-mock --- servant-mock/src/Servant/Mock.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index e4437fba..7d17dca5 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} From c6e0ccbc2fe133cca35d5098351fd00a653cb313 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 14 Jan 2016 23:58:48 +0100 Subject: [PATCH 5/7] server/docs: fix formatting inconsistency --- servant-server/src/Servant/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index a26941ea..b847ede3 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -63,7 +63,7 @@ module Servant.Server , err415 , err416 , err417 - -- * 5XX + -- ** 5XX , err500 , err501 , err502 From 3bc4e17309ab2eab47e20db3869a1264755c4fc0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Jan 2016 11:50:00 +0100 Subject: [PATCH 6/7] How to report security issues. --- CONTRIBUTING.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 335f6094..f0cdd2eb 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it! We are currently moving to a more aggresive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major releases it may take some time in between releases. + +## Reporting security issues + +Please email haskell-servant-maintainers AT googlegroups DOT com. This group is +private, and accessible only to known maintainers. We will then discuss how to +proceed. Please do not make the issue public before we inform you that we have +a patch ready. From 8ecc3f07064a3a627b8e49fb182789c82cd9c5d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 14 Jan 2016 23:43:48 +0100 Subject: [PATCH 7/7] server: added Config machinery --- .travis.yml | 2 +- servant-client/test/Servant/ClientSpec.hs | 12 +- .../auth-combinator/auth-combinator.hs | 25 +++- .../socket-io-chat/socket-io-chat.hs | 2 +- servant-examples/tutorial/T1.hs | 2 +- servant-examples/tutorial/T10.hs | 2 +- servant-examples/tutorial/T2.hs | 2 +- servant-examples/tutorial/T3.hs | 2 +- servant-examples/tutorial/T4.hs | 2 +- servant-examples/tutorial/T5.hs | 2 +- servant-examples/tutorial/T6.hs | 2 +- servant-examples/tutorial/T7.hs | 2 +- servant-examples/tutorial/T9.hs | 2 +- .../wai-middleware/wai-middleware.hs | 4 +- servant-mock/example/main.hs | 2 +- servant-server/example/greet.hs | 2 +- servant-server/servant-server.cabal | 7 +- servant-server/src/Servant/Server.hs | 15 ++- servant-server/src/Servant/Server/Internal.hs | 95 +++++++++---- .../src/Servant/Server/Internal/Config.hs | 57 ++++++++ .../test/Servant/Server/ErrorSpec.hs | 8 +- .../Servant/Server/Internal/ConfigSpec.hs | 61 +++++++++ .../test/Servant/Server/Internal/EnterSpec.hs | 4 +- .../test/Servant/Server/UsingConfigSpec.hs | 125 ++++++++++++++++++ .../Server/UsingConfigSpec/TestCombinators.hs | 78 +++++++++++ servant-server/test/Servant/ServerSpec.hs | 35 ++--- .../test/Servant/Utils/StaticFilesSpec.hs | 4 +- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 3 + servant/src/Servant/API/WithNamedConfig.hs | 8 ++ stack.yaml | 1 + 31 files changed, 486 insertions(+), 83 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Config.hs create mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs create mode 100644 servant/src/Servant/API/WithNamedConfig.hs diff --git a/.travis.yml b/.travis.yml index 62501f7a..9cddf7ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ install: - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config script: - - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done cache: directories: diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 245a7216..46bf3712 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -110,7 +111,7 @@ api :: Proxy Api api = Proxy server :: Application -server = serve api ( +server = serve api EmptyConfig ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) @@ -137,7 +138,7 @@ failApi :: Proxy FailApi failApi = Proxy failServer :: Application -failServer = serve failApi ( +failServer = serve failApi EmptyConfig ( (\ _request respond -> respond $ responseLBS ok200 [] "") :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") @@ -227,7 +228,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = @@ -283,8 +284,9 @@ 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, - HasClient api, Client api ~ ExceptT ServantError IO ()) => + WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a + , HasConfig api '[], HasClient api + , Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index ec152782..87f1fcc7 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -8,6 +8,7 @@ import Data.Aeson import Data.ByteString (ByteString) +import Data.IORef import Data.Text (Text) import GHC.Generics import Network.Wai @@ -18,23 +19,32 @@ import Servant.Server.Internal -- Pretty much stolen/adapted from -- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs -type DBLookup = ByteString -> IO Bool +type DBConnection = IORef [ByteString] +type DBLookup = DBConnection -> ByteString -> IO Bool + +initDB :: IO DBConnection +initDB = newIORef ["good password"] isGoodCookie :: DBLookup -isGoodCookie = return . (== "good password") +isGoodCookie ref password = do + allowed <- readIORef ref + return (password `elem` allowed) data AuthProtected instance HasServer rest => HasServer (AuthProtected :> rest) where type ServerT (AuthProtected :> rest) m = ServerT rest m + type HasConfig (AuthProtected :> rest) config = + (HasConfigEntry config DBConnection, HasConfig rest config) - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request where cookieCheck req = case lookup "Cookie" (requestHeaders req) of Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } Just v -> do - authGranted <- isGoodCookie v + let dbConnection = getConfigEntry config + authGranted <- isGoodCookie dbConnection v if authGranted then return $ Route () else return $ FailFatal err403 { errBody = "Invalid cookie" } @@ -66,7 +76,10 @@ server = return prvdata :<|> return pubdata pubdata = [PublicData "this is a public piece of data"] main :: IO () -main = run 8080 (serve api server) +main = do + dbConnection <- initDB + let config = dbConnection :. EmptyConfig + run 8080 (serve api config server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs index 1250d8fe..4f5e649a 100644 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -38,7 +38,7 @@ server sHandler = socketIOHandler app :: WaiMonad () -> Application -app sHandler = serve api $ server sHandler +app sHandler = serve api EmptyConfig $ server sHandler port :: Int port = 3001 diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs index 97bbecb8..2473e7c8 100644 --- a/servant-examples/tutorial/T1.hs +++ b/servant-examples/tutorial/T1.hs @@ -42,4 +42,4 @@ server :: Server UserAPI server = return users app :: Application -app = serve userAPI server +app = serve userAPI EmptyConfig server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index be5da4cf..859ff2cb 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs index fc49d256..bd311330 100644 --- a/servant-examples/tutorial/T2.hs +++ b/servant-examples/tutorial/T2.hs @@ -49,4 +49,4 @@ server = return users :<|> return isaac app :: Application -app = serve userAPI server +app = serve userAPI EmptyConfig server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs index 7b5bdeb3..4a56b946 100644 --- a/servant-examples/tutorial/T3.hs +++ b/servant-examples/tutorial/T3.hs @@ -81,4 +81,4 @@ server = position marketing clientinfo = return (emailForClient clientinfo) app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs index 69cbf951..b86c8cb2 100644 --- a/servant-examples/tutorial/T4.hs +++ b/servant-examples/tutorial/T4.hs @@ -60,4 +60,4 @@ server :: Server PersonAPI server = return persons app :: Application -app = serve personAPI server +app = serve personAPI EmptyConfig server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs index 3b18aedb..81812d90 100644 --- a/servant-examples/tutorial/T5.hs +++ b/servant-examples/tutorial/T5.hs @@ -34,4 +34,4 @@ server = do where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } app :: Application -app = serve ioAPI server +app = serve ioAPI EmptyConfig server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs index 781bf703..3e24647d 100644 --- a/servant-examples/tutorial/T6.hs +++ b/servant-examples/tutorial/T6.hs @@ -15,4 +15,4 @@ server :: Server API server = serveDirectory "tutorial" app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs index e0145caf..010b66dd 100644 --- a/servant-examples/tutorial/T7.hs +++ b/servant-examples/tutorial/T7.hs @@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT readerToEither = Nat $ \r -> return (runReader r "hi") app :: Application -app = serve readerAPI readerServer +app = serve readerAPI EmptyConfig readerServer diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs index 75dd0630..a9fd575b 100644 --- a/servant-examples/tutorial/T9.hs +++ b/servant-examples/tutorial/T9.hs @@ -102,4 +102,4 @@ writeJSFiles = do TIO.writeFile "tutorial/t9/jq.js" jq app :: Application -app = serve api' server' +app = serve api' EmptyConfig server' diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index d625d092..52368c00 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -41,11 +41,11 @@ server = return products -- logStdout :: Middleware -- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Server api -> Application +-- serve :: Proxy api -> Config a -> Server api -> Application -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application -app = logStdout (serve simpleAPI server) +app = logStdout (serve simpleAPI EmptyConfig server) main :: IO () main = run 8080 app diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 51ba7329..6c63c0e4 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api $ mock api) +main = run 8080 (serve api EmptyConfig $ mock api) diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 3fda367d..37c3f674 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application -test = serve testApi server +test = serve testApi EmptyConfig server -- Run the server. -- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c4ec6edc..ee45da8a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -37,6 +37,7 @@ library Servant Servant.Server Servant.Server.Internal + Servant.Server.Internal.Config Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -94,10 +95,13 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: + Servant.Server.ErrorSpec + Servant.Server.Internal.ConfigSpec Servant.Server.Internal.EnterSpec Servant.ServerSpec + Servant.Server.UsingConfigSpec + Servant.Server.UsingConfigSpec.TestCombinators Servant.Utils.StaticFilesSpec - Servant.Server.ErrorSpec build-depends: base == 4.* , aeson @@ -115,6 +119,7 @@ test-suite spec , servant , servant-server , string-conversions + , should-not-typecheck == 2.* , temporary , text , transformers diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b847ede3..5ef8498d 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -35,6 +36,10 @@ module Servant.Server , generalizeNat , tweakResponse + -- * Config + , Config(..) + , NamedConfig(..) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -96,14 +101,18 @@ import Servant.Server.Internal.Enter -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > +-- > config :: Config '[] +-- > config = EmptyConfig +-- > -- > app :: Application --- > app = serve myApi server +-- > app = serve myApi config server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p d)) +serve :: (HasConfig layout a, HasServer layout) + => Proxy layout -> Config a -> Server layout -> Application +serve p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r (\ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 730e96d5..f502ea9a 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +14,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal + , module Servant.Server.Internal.Config , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -30,6 +32,7 @@ import Data.String (fromString) import Data.String.Conversions (cs, (<>)) import Data.Text (Text) import Data.Typeable +import GHC.Exts (Constraint) import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -49,7 +52,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault) + Raw, RemoteHost, ReqBody, Vault, + WithNamedConfig) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -58,6 +62,7 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.Server.Internal.Config import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -65,8 +70,9 @@ import Servant.Server.Internal.ServantErr class HasServer layout where type ServerT layout (m :: * -> *) :: * + type HasConfig layout (c :: [*]) :: Constraint - route :: Proxy layout -> Delayed (Server layout) -> Router + route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -86,9 +92,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m + type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c) - route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> b) -> b) <$> server)) + route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) + (route pb config ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -117,10 +124,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m + type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c) - route Proxy d = + route Proxy config d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) + config (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -192,8 +201,9 @@ instance OVERLAPPABLE_ ) => HasServer (Verb method status ctypes a) where type ServerT (Verb method status ctypes a) m = m a + type HasConfig (Verb method status ctypes a) c = () - route Proxy = methodRouter method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -203,8 +213,9 @@ instance OVERLAPPING_ ) => HasServer (Verb method status ctypes (Headers h a)) where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) + type HasConfig (Verb method status ctypes (Headers h a)) c = () - route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -233,10 +244,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m + type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -265,8 +277,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m + type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -274,7 +287,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) 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) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -301,15 +314,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m + type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- 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 - in route (Proxy :: Proxy sublayout) (passToServer subserver values) + in route (Proxy :: Proxy sublayout) config (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -332,14 +346,15 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m + type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -355,8 +370,9 @@ instance (KnownSymbol sym, HasServer sublayout) instance HasServer Raw where type ServerT Raw m = Application + type HasConfig Raw c = () - route Proxy rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -389,9 +405,10 @@ instance ( AllCTUnrender list a, HasServer sublayout type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m + type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -412,37 +429,42 @@ instance ( AllCTUnrender list a, HasServer sublayout instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type ServerT (path :> sublayout) m = ServerT sublayout m + type HasConfig (path :> sublayout) c = HasConfig sublayout c - route Proxy subserver = StaticRouter $ + route Proxy config subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) subserver) + (route (Proxy :: Proxy sublayout) config subserver) where proxyPath = Proxy :: Proxy path instance HasServer api => HasServer (RemoteHost :> api) where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m + type HasConfig (RemoteHost :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) instance HasServer api => HasServer (IsSecure :> api) where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m + type HasConfig (IsSecure :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ secure req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure instance HasServer api => HasServer (Vault :> api) where type ServerT (Vault :> api) m = Vault -> ServerT api m + type HasConfig (Vault :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ vault req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ vault req) instance HasServer api => HasServer (HttpVersion :> api) where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m + type HasConfig (HttpVersion :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo @@ -452,3 +474,20 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +-- * configs + +instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where + type ServerT (WithNamedConfig name subConfig subApi) m = + ServerT subApi m + type HasConfig (WithNamedConfig name subConfig subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs new file mode 100644 index 00000000..e710de4b --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +#include "overlapping-compat.h" + +module Servant.Server.Internal.Config where + +import Data.Proxy +import GHC.TypeLits + +-- | The entire configuration. +data Config a where + EmptyConfig :: Config '[] + (:.) :: x -> Config xs -> Config (x ': xs) +infixr 5 :. + +instance Show (Config '[]) where + show EmptyConfig = "EmptyConfig" +instance (Show a, Show (Config as)) => Show (Config (a ': as)) where + showsPrec outerPrecedence (a :. as) = + showParen (outerPrecedence > 5) $ + shows a . showString " :. " . shows as + +instance Eq (Config '[]) where + _ == _ = True +instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 + +class HasConfigEntry (config :: [*]) (val :: *) where + getConfigEntry :: Config config -> val + +instance OVERLAPPABLE_ + HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where + getConfigEntry (_ :. xs) = getConfigEntry xs + +instance OVERLAPPING_ + HasConfigEntry (val ': xs) val where + getConfigEntry (x :. _) = x + +-- * support for named subconfigs + +data NamedConfig (name :: Symbol) (subConfig :: [*]) + = NamedConfig (Config subConfig) + +descendIntoNamedConfig :: forall config name subConfig . + HasConfigEntry config (NamedConfig name subConfig) => + Proxy (name :: Symbol) -> Config config -> Config subConfig +descendIntoNamedConfig Proxy config = + let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig + in subConfig diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 500a0069..745b47d9 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do + $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet @@ -89,7 +89,7 @@ prioErrorsApi = Proxy prioErrorsSpec :: Spec prioErrorsSpec = describe "PrioErrors" $ do let server = return - with (return $ serve prioErrorsApi server) $ do + with (return $ serve prioErrorsApi EmptyConfig server) $ do let check (mdescr, method) path (cdescr, ctype, body) resp = it fulldescr $ Test.Hspec.Wai.request method path [(hContentType, ctype)] body @@ -154,7 +154,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi errorRetryServer) $ do + $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -194,7 +194,7 @@ errorChoiceServer = return 0 errorChoiceSpec :: Spec errorChoiceSpec = describe "Multiple handlers return errors" - $ with (return $ serve errorChoiceApi errorChoiceServer) $ do + $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do it "should respond with 404 if no path matches" $ do request methodGet "" [] "" `shouldRespondWith` 404 diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs new file mode 100644 index 00000000..182d91a8 --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module Servant.Server.Internal.ConfigSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.ShouldNotTypecheck (shouldNotTypecheck) + +import Servant.API +import Servant.Server.Internal.Config + +spec :: Spec +spec = do + describe "getConfigEntry" $ do + it "gets the config if a matching one exists" $ do + let config = 'a' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' + + it "gets the first matching config" $ do + let config = 'a' :. 'b' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' + + it "does not typecheck if type does not exist" $ do + let config = 'a' :. EmptyConfig + x = getConfigEntry config :: Bool + shouldNotTypecheck x + + context "Show instance" $ do + let config = 'a' :. True :. EmptyConfig + it "has a Show instance" $ do + show config `shouldBe` "'a' :. True :. EmptyConfig" + + context "bracketing" $ do + it "works" $ do + show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)" + + it "works with operators" $ do + let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig) + show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)" + + describe "descendIntoNamedConfig" $ do + let config :: Config [Char, NamedConfig "sub" '[Char]] + config = + 'a' :. + (NamedConfig subConfig :: NamedConfig "sub" '[Char]) + :. EmptyConfig + subConfig = 'b' :. EmptyConfig + it "allows extracting subconfigs" $ do + descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig + + it "allows extracting entries from subconfigs" $ do + getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char]) + `shouldBe` 'b' + + it "does not typecheck if subConfig has the wrong type" $ do + let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int] + shouldNotTypecheck (show x) + + it "does not typecheck if subConfig with that name doesn't exist" $ do + let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char] + shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 8b450377..06e8af9b 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do - with (return (serve readerAPI readerServer)) $ do + with (return (serve readerAPI EmptyConfig readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } - with (return (serve combinedAPI combinedReaderServer)) $ do + with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs new file mode 100644 index 00000000..a6c7ae43 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingConfigSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingConfigSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromConfig :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serve (Proxy :: Proxy OneEntryAPI) config testServer + where + config :: Config '[String] + config = "configEntry" :. EmptyConfig + +type OneEntryTwiceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String] + config = "configEntryTwice" :. EmptyConfig + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing config entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ConfigEntry" $ do + get "/" `shouldRespondWith` "\"configEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ConfigEntry twice" $ do + get "/foo" `shouldRespondWith` "\"configEntryTwice\"" + get "/bar" `shouldRespondWith` "\"configEntryTwice\"" + +type InjectAPI = + InjectIntoConfig :> "untagged" :> ExtractFromConfig :> + Get '[JSON] String :<|> + InjectIntoConfig :> "tagged" :> ExtractFromConfig :> + Get '[JSON] String + +injectApp :: Application +injectApp = serve (Proxy :: Proxy InjectAPI) config $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + config = EmptyConfig + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting config entries with custom combinators" $ do + it "allows to inject config entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged config entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + NamedConfigWithBirdface "sub" '[String] :> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String, (NamedConfig "sub" '[String])] + config = + "firstEntry" :. + (NamedConfig ("secondEntry" :. EmptyConfig)) :. + EmptyConfig + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ConfigEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedConfigAPI = + WithNamedConfig "sub" '[String] ( + ExtractFromConfig :> Get '[JSON] String) + +namedConfigApp :: Application +namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return + where + config :: Config '[NamedConfig "sub" '[String]] + config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig + +spec4 :: Spec +spec4 = do + with (return namedConfigApp) $ do + describe "WithNamedConfig" $ do + it "allows descending into a subconfig for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs new file mode 100644 index 00000000..53f00f21 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingConfigSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Config, you don't. This module is +-- separate from Servant.Server.UsingConfigSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingConfigSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.Config +import Servant.Server.Internal.RoutingApplication + +data ExtractFromConfig + +instance (HasServer subApi) => + HasServer (ExtractFromConfig :> subApi) where + + type ServerT (ExtractFromConfig :> subApi) m = + String -> ServerT subApi m + type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) = + (HasConfigEntry c String, HasConfig subApi c) + + route Proxy config delayed = + route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject config f = f (getConfigEntry config) + +data InjectIntoConfig + +instance (HasServer subApi) => + HasServer (InjectIntoConfig :> subApi) where + + type ServerT (InjectIntoConfig :> subApi) m = + ServerT subApi m + type HasConfig (InjectIntoConfig :> subApi) c = + (HasConfig subApi (String ': c)) + + route Proxy config delayed = + route subProxy newConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newConfig = ("injected" :: String) :. config + +data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) + +instance (HasServer subApi) => + HasServer (NamedConfigWithBirdface name subConfig :> subApi) where + + type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = + ServerT subApi m + type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e4069b0f..b19ee2e2 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -47,7 +47,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.Server (ServantErr (..), Server, err404, - serve) + serve, Config(EmptyConfig)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -101,7 +101,7 @@ verbSpec = describe "Servant.API.Verb" $ do wrongMethod m = if m == methodPatch then methodPost else methodPatch test desc api method (status :: Int) = context desc $ - with (return $ serve api server) $ do + with (return $ serve api EmptyConfig server) $ do -- HEAD and 214/215 need not return bodies unless (status `elem` [214, 215] || method == methodHead) $ @@ -176,7 +176,7 @@ captureServer legs = case legs of captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do - with (return (serve captureApi captureServer)) $ do + with (return (serve captureApi EmptyConfig captureServer)) $ do it "can capture parts of the 'pathInfo'" $ do response <- get "/2" @@ -187,6 +187,7 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) + EmptyConfig (\ "captured" request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do @@ -219,8 +220,8 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do - it "allows to retrieve simple GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving simple GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params1, @@ -231,8 +232,8 @@ queryParamSpec = do name = "bob" } - it "allows to retrieve lists in GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving lists in GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params2, @@ -245,8 +246,8 @@ queryParamSpec = do } - it "allows to retrieve value-less GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving value-less GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3, @@ -298,7 +299,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do mkReq method x = Test.Hspec.Wai.request method x [(hContentType, "application/json;charset=utf-8")] - with (return $ serve reqBodyApi server) $ do + with (return $ serve reqBodyApi EmptyConfig server) $ do it "passes the argument to the handler" $ do response <- mkReq methodPost "" (encode alice) @@ -331,13 +332,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" - with (return (serve headerApi expectsInt)) $ do + with (return (serve headerApi EmptyConfig expectsInt)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi expectsString)) $ do + with (return (serve headerApi EmptyConfig expectsString)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ @@ -361,7 +362,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -369,7 +370,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } @@ -403,7 +404,7 @@ alternativeServer = alternativeSpec :: Spec alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve alternativeApi alternativeServer) $ do + with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -438,7 +439,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do - with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do + with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do let methods = [methodGet, methodPost, methodPut, methodPatch] @@ -504,7 +505,7 @@ miscServ = versionHandler hostHandler = return . show miscCombinatorSpec :: Spec -miscCombinatorSpec = with (return $ serve miscApi miscServ) $ +miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 94c63f18..e6430b5c 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) -import Servant.Server (Server, serve) +import Servant.Server (Server, serve, Config(EmptyConfig)) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) @@ -29,7 +29,7 @@ api :: Proxy Api api = Proxy app :: Application -app = serve api server +app = serve api EmptyConfig server server :: Server Api server = diff --git a/servant/servant.cabal b/servant/servant.cabal index 451eb166..df2761a8 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -40,6 +40,7 @@ library Servant.API.Sub Servant.API.Vault Servant.API.Verbs + Servant.API.WithNamedConfig Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 03051533..2da0d4cf 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,6 +23,8 @@ module Servant.API ( -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware + module Servant.API.WithNamedConfig, + -- | Access config entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -88,6 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) +import Servant.API.WithNamedConfig (WithNamedConfig) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs new file mode 100644 index 00000000..3f234292 --- /dev/null +++ b/servant/src/Servant/API/WithNamedConfig.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedConfig where + +import GHC.TypeLits + +data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi diff --git a/stack.yaml b/stack.yaml index f370da09..c1aea0a2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,4 +16,5 @@ packages: extra-deps: - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 +- should-not-typecheck-2.0.1 resolver: nightly-2015-10-08