From 67315c44870735d19f89668565aa0f10693c03c0 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] 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 c8726cf3..fb9e835a 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 #-} @@ -114,7 +115,7 @@ api :: Proxy Api api = Proxy server :: Application -server = serve api ( +server = serve api EmptyConfig ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) @@ -141,7 +142,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")] "") @@ -231,7 +232,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) = @@ -287,8 +288,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 03c5cb31..f6ed6319 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 e583523d..0955e332 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI 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, @@ -106,7 +106,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) $ @@ -181,7 +181,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" @@ -192,6 +192,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 @@ -224,8 +225,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, @@ -236,8 +237,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, @@ -250,8 +251,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, @@ -303,7 +304,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) @@ -336,13 +337,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)" $ @@ -366,7 +367,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"] } @@ -374,7 +375,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"] } @@ -408,7 +409,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" @@ -443,7 +444,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] @@ -509,7 +510,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 e0efb428..437c9843 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -41,6 +41,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