67315c4 · typeable/servant

git.iko.soy/typeable/servant

server: added Config machinery

commit67315c44870735d19f89668565aa0f10693c03c0 authorSönke Hahn <soenkehahn@gmail.com> dateThu 14 Jan 2016, 23:43 (11 years ago) parent06ad05e

31 files changed+486−83

compare with master

unifiedsplit

.travis.yml+1−1

@@ -25,7 +25,7 @@ install:

2525 - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

2626

2727script:

28− - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done

28+ - 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

2929

3030cache:

3131 directories:

servant-client/test/Servant/ClientSpec.hs+7−5

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE DeriveGeneric #-}

45{-# LANGUAGE FlexibleContexts #-}

@@ -114,7 +115,7 @@ api :: Proxy Api

114115api = Proxy

115116

116117server :: Application

117−server = serve api (

118+server = serve api EmptyConfig (

118119 return alice

119120 :<|> return NoContent

120121 :<|> (\ name -> return $ Person name 0)

@@ -141,7 +142,7 @@ failApi :: Proxy FailApi

141142failApi = Proxy

142143

143144failServer :: Application

144−failServer = serve failApi (

145+failServer = serve failApi EmptyConfig (

145146 (\ _request respond -> respond $ responseLBS ok200 [] "")

146147 :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")

147148 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

@@ -231,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

231232

232233wrappedApiSpec :: Spec

233234wrappedApiSpec = describe "error status codes" $ do

234− let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []

235+ let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []

235236 context "are correctly handled by the client" $

236237 let test :: (WrappedApi, String) -> Spec

237238 test (WrappedApi api, desc) =

@@ -287,8 +288,9 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

287288 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

288289

289290data WrappedApi where

290− WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,

291− HasClient api, Client api ~ ExceptT ServantError IO ()) =>

291+ WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a

292+ , HasConfig api '[], HasClient api

293+ , Client api ~ ExceptT ServantError IO ()) =>

292294 Proxy api -> WrappedApi

293295

294296

servant-examples/auth-combinator/auth-combinator.hs+19−6

@@ -8,6 +8,7 @@

99import Data.Aeson

1010import Data.ByteString (ByteString)

11+import Data.IORef

1112import Data.Text (Text)

1213import GHC.Generics

1314import Network.Wai

@@ -18,23 +19,32 @@ import Servant.Server.Internal

1819-- Pretty much stolen/adapted from

1920-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs

2021

21−type DBLookup = ByteString -> IO Bool

22+type DBConnection = IORef [ByteString]

23+type DBLookup = DBConnection -> ByteString -> IO Bool

24+

25+initDB :: IO DBConnection

26+initDB = newIORef ["good password"]

2227

2328isGoodCookie :: DBLookup

24−isGoodCookie = return . (== "good password")

29+isGoodCookie ref password = do

30+ allowed <- readIORef ref

31+ return (password `elem` allowed)

2532

2633data AuthProtected

2734

2835instance HasServer rest => HasServer (AuthProtected :> rest) where

2936 type ServerT (AuthProtected :> rest) m = ServerT rest m

37+ type HasConfig (AuthProtected :> rest) config =

38+ (HasConfigEntry config DBConnection, HasConfig rest config)

3039

31− route Proxy subserver = WithRequest $ \ request ->

32− route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request

40+ route Proxy config subserver = WithRequest $ \ request ->

41+ route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request

3342 where

3443 cookieCheck req = case lookup "Cookie" (requestHeaders req) of

3544 Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }

3645 Just v -> do

37− authGranted <- isGoodCookie v

46+ let dbConnection = getConfigEntry config

47+ authGranted <- isGoodCookie dbConnection v

3848 if authGranted

3949 then return $ Route ()

4050 else return $ FailFatal err403 { errBody = "Invalid cookie" }

@@ -66,7 +76,10 @@ server = return prvdata :<|> return pubdata

6676 pubdata = [PublicData "this is a public piece of data"]

6777

6878main :: IO ()

69−main = run 8080 (serve api server)

79+main = do

80+ dbConnection <- initDB

81+ let config = dbConnection :. EmptyConfig

82+ run 8080 (serve api config server)

7083

7184{- Sample session:

7285$ curl http://localhost:8080/

servant-examples/socket-io-chat/socket-io-chat.hs+1−1

@@ -38,7 +38,7 @@ server sHandler = socketIOHandler

3838

3939

4040app :: WaiMonad () -> Application

41−app sHandler = serve api $ server sHandler

41+app sHandler = serve api EmptyConfig $ server sHandler

4242

4343port :: Int

4444port = 3001

servant-examples/tutorial/T1.hs+1−1

@@ -42,4 +42,4 @@ server :: Server UserAPI

4242server = return users

4343

4444app :: Application

45−app = serve userAPI server

45+app = serve userAPI EmptyConfig server

servant-examples/tutorial/T10.hs+1−1

@@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs

6868 plain = ("Content-Type", "text/plain")

6969

7070app :: Application

71−app = serve api server

71+app = serve api EmptyConfig server

servant-examples/tutorial/T2.hs+1−1

@@ -49,4 +49,4 @@ server = return users

4949 :<|> return isaac

5050

5151app :: Application

52−app = serve userAPI server

52+app = serve userAPI EmptyConfig server

servant-examples/tutorial/T3.hs+1−1

@@ -81,4 +81,4 @@ server = position

8181 marketing clientinfo = return (emailForClient clientinfo)

8282

8383app :: Application

84−app = serve api server

84+app = serve api EmptyConfig server

servant-examples/tutorial/T4.hs+1−1

@@ -60,4 +60,4 @@ server :: Server PersonAPI

6060server = return persons

6161

6262app :: Application

63−app = serve personAPI server

63+app = serve personAPI EmptyConfig server

servant-examples/tutorial/T5.hs+1−1

@@ -34,4 +34,4 @@ server = do

3434 where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }

3535

3636app :: Application

37−app = serve ioAPI server

37+app = serve ioAPI EmptyConfig server

servant-examples/tutorial/T6.hs+1−1

@@ -15,4 +15,4 @@ server :: Server API

1515server = serveDirectory "tutorial"

1616

1717app :: Application

18−app = serve api server

18+app = serve api EmptyConfig server

servant-examples/tutorial/T7.hs+1−1

@@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT

3030 readerToEither = Nat $ \r -> return (runReader r "hi")

3131

3232app :: Application

33−app = serve readerAPI readerServer

33+app = serve readerAPI EmptyConfig readerServer

servant-examples/tutorial/T9.hs+1−1

@@ -102,4 +102,4 @@ writeJSFiles = do

102102 TIO.writeFile "tutorial/t9/jq.js" jq

103103

104104app :: Application

105−app = serve api' server'

105+app = serve api' EmptyConfig server'

servant-examples/wai-middleware/wai-middleware.hs+2−2

@@ -41,11 +41,11 @@ server = return products

4141

4242-- logStdout :: Middleware

4343-- i.e, logStdout :: Application -> Application

44−-- serve :: Proxy api -> Server api -> Application

44+-- serve :: Proxy api -> Config a -> Server api -> Application

4545-- so applying a middleware is really as simple as

4646-- applying a function to the result of 'serve'

4747app :: Application

48−app = logStdout (serve simpleAPI server)

48+app = logStdout (serve simpleAPI EmptyConfig server)

4949

5050main :: IO ()

5151main = run 8080 app

servant-mock/example/main.hs+1−1

@@ -20,4 +20,4 @@ api :: Proxy API

2020api = Proxy

2121

2222main :: IO ()

23−main = run 8080 (serve api $ mock api)

23+main = run 8080 (serve api EmptyConfig $ mock api)

servant-server/example/greet.hs+1−1

@@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH

5959-- Turn the server into a WAI app. 'serve' is provided by servant,

6060-- more precisely by the Servant.Server module.

6161test :: Application

62−test = serve testApi server

62+test = serve testApi EmptyConfig server

6363

6464-- Run the server.

6565--

servant-server/servant-server.cabal+6−1

@@ -37,6 +37,7 @@ library

3737 Servant

3838 Servant.Server

3939 Servant.Server.Internal

40+ Servant.Server.Internal.Config

4041 Servant.Server.Internal.Enter

4142 Servant.Server.Internal.Router

4243 Servant.Server.Internal.RoutingApplication

@@ -94,10 +95,13 @@ test-suite spec

9495 hs-source-dirs: test

9596 main-is: Spec.hs

9697 other-modules:

98+ Servant.Server.ErrorSpec

99+ Servant.Server.Internal.ConfigSpec

97100 Servant.Server.Internal.EnterSpec

98101 Servant.ServerSpec

102+ Servant.Server.UsingConfigSpec

103+ Servant.Server.UsingConfigSpec.TestCombinators

99104 Servant.Utils.StaticFilesSpec

100− Servant.Server.ErrorSpec

101105 build-depends:

102106 base == 4.*

103107 , aeson

@@ -115,6 +119,7 @@ test-suite spec

115119 , servant

116120 , servant-server

117121 , string-conversions

122+ , should-not-typecheck == 2.*

118123 , temporary

119124 , text

120125 , transformers

servant-server/src/Servant/Server.hs+12−3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE ConstraintKinds #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE OverloadedStrings #-}

34{-# LANGUAGE TypeFamilies #-}

@@ -35,6 +36,10 @@ module Servant.Server

3536 , generalizeNat

3637 , tweakResponse

3738

39+ -- * Config

40+ , Config(..)

41+ , NamedConfig(..)

42+

3843 -- * Default error type

3944 , ServantErr(..)

4045 -- ** 3XX

@@ -96,14 +101,18 @@ import Servant.Server.Internal.Enter

96101-- > myApi :: Proxy MyApi

97102-- > myApi = Proxy

98103-- >

104+-- > config :: Config '[]

105+-- > config = EmptyConfig

106+-- >

99107-- > app :: Application

100−-- > app = serve myApi server

108+-- > app = serve myApi config server

101109-- >

102110-- > main :: IO ()

103111-- > main = Network.Wai.Handler.Warp.run 8080 app

104112--

105−serve :: HasServer layout => Proxy layout -> Server layout -> Application

106−serve p server = toApplication (runRouter (route p d))

113+serve :: (HasConfig layout a, HasServer layout)

114+ => Proxy layout -> Config a -> Server layout -> Application

115+serve p config server = toApplication (runRouter (route p config d))

107116 where

108117 d = Delayed r r r (\ _ _ -> Route server)

109118 r = return (Route ())

servant-server/src/Servant/Server/Internal.hs+67−28

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

45{-# LANGUAGE FlexibleInstances #-}

@@ -13,6 +14,7 @@

1314

1415module Servant.Server.Internal

1516 ( module Servant.Server.Internal

17+ , module Servant.Server.Internal.Config

1618 , module Servant.Server.Internal.Router

1719 , module Servant.Server.Internal.RoutingApplication

1820 , module Servant.Server.Internal.ServantErr

@@ -30,6 +32,7 @@ import Data.String (fromString)

3032import Data.String.Conversions (cs, (<>))

3133import Data.Text (Text)

3234import Data.Typeable

35+import GHC.Exts (Constraint)

3336import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

3437 symbolVal)

3538import Network.HTTP.Types hiding (Header, ResponseHeaders)

@@ -49,7 +52,8 @@ import Servant.API ((:<|>) (..), (:>), Capture,

4952 Verb, ReflectMethod(reflectMethod),

5053 IsSecure(..), Header,

5154 QueryFlag, QueryParam, QueryParams,

52− Raw, RemoteHost, ReqBody, Vault)

55+ Raw, RemoteHost, ReqBody, Vault,

56+ WithNamedConfig)

5357import Servant.API.ContentTypes (AcceptHeader (..),

5458 AllCTRender (..),

5559 AllCTUnrender (..),

@@ -58,6 +62,7 @@ import Servant.API.ContentTypes (AcceptHeader (..),

5862import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

5963 getResponse)

6064

65+import Servant.Server.Internal.Config

6166import Servant.Server.Internal.Router

6267import Servant.Server.Internal.RoutingApplication

6368import Servant.Server.Internal.ServantErr

@@ -65,8 +70,9 @@ import Servant.Server.Internal.ServantErr

6570

6671class HasServer layout where

6772 type ServerT layout (m :: * -> *) :: *

73+ type HasConfig layout (c :: [*]) :: Constraint

6874

69− route :: Proxy layout -> Delayed (Server layout) -> Router

75+ route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router

7076

7177type Server layout = ServerT layout (ExceptT ServantErr IO)

7278

@@ -86,9 +92,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)

8692instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

8793

8894 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

95+ type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)

8996

90− route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))

91− (route pb ((\ (_ :<|> b) -> b) <$> server))

97+ route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))

98+ (route pb config ((\ (_ :<|> b) -> b) <$> server))

9299 where pa = Proxy :: Proxy a

93100 pb = Proxy :: Proxy b

94101

@@ -117,10 +124,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)

117124

118125 type ServerT (Capture capture a :> sublayout) m =

119126 a -> ServerT sublayout m

127+ type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)

120128

121− route Proxy d =

129+ route Proxy config d =

122130 DynamicRouter $ \ first ->

123131 route (Proxy :: Proxy sublayout)

132+ config

124133 (addCapture d $ case captured captureProxy first of

125134 Nothing -> return $ Fail err404

126135 Just v -> return $ Route v

@@ -192,8 +201,9 @@ instance OVERLAPPABLE_

192201 ) => HasServer (Verb method status ctypes a) where

193202

194203 type ServerT (Verb method status ctypes a) m = m a

204+ type HasConfig (Verb method status ctypes a) c = ()

195205

196− route Proxy = methodRouter method (Proxy :: Proxy ctypes) status

206+ route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status

197207 where method = reflectMethod (Proxy :: Proxy method)

198208 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

199209

@@ -203,8 +213,9 @@ instance OVERLAPPING_

203213 ) => HasServer (Verb method status ctypes (Headers h a)) where

204214

205215 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)

216+ type HasConfig (Verb method status ctypes (Headers h a)) c = ()

206217

207− route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status

218+ route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status

208219 where method = reflectMethod (Proxy :: Proxy method)

209220 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

210221

@@ -233,10 +244,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

233244

234245 type ServerT (Header sym a :> sublayout) m =

235246 Maybe a -> ServerT sublayout m

247+ type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c

236248

237− route Proxy subserver = WithRequest $ \ request ->

249+ route Proxy config subserver = WithRequest $ \ request ->

238250 let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)

239− in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)

251+ in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)

240252 where str = fromString $ symbolVal (Proxy :: Proxy sym)

241253

242254-- | 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)

265277

266278 type ServerT (QueryParam sym a :> sublayout) m =

267279 Maybe a -> ServerT sublayout m

280+ type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c

268281

269− route Proxy subserver = WithRequest $ \ request ->

282+ route Proxy config subserver = WithRequest $ \ request ->

270283 let querytext = parseQueryText $ rawQueryString request

271284 param =

272285 case lookup paramname querytext of

@@ -274,7 +287,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

274287 Just Nothing -> Nothing -- param present with no value -> Nothing

275288 Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to

276289 -- the right type

277− in route (Proxy :: Proxy sublayout) (passToServer subserver param)

290+ in route (Proxy :: Proxy sublayout) config (passToServer subserver param)

278291 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

279292

280293-- | 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)

301314

302315 type ServerT (QueryParams sym a :> sublayout) m =

303316 [a] -> ServerT sublayout m

317+ type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c

304318

305− route Proxy subserver = WithRequest $ \ request ->

319+ route Proxy config subserver = WithRequest $ \ request ->

306320 let querytext = parseQueryText $ rawQueryString request

307321 -- if sym is "foo", we look for query string parameters

308322 -- named "foo" or "foo[]" and call parseQueryParam on the

309323 -- corresponding values

310324 parameters = filter looksLikeParam querytext

311325 values = mapMaybe (convert . snd) parameters

312− in route (Proxy :: Proxy sublayout) (passToServer subserver values)

326+ in route (Proxy :: Proxy sublayout) config (passToServer subserver values)

313327 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

314328 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

315329 convert Nothing = Nothing

@@ -332,14 +346,15 @@ instance (KnownSymbol sym, HasServer sublayout)

332346

333347 type ServerT (QueryFlag sym :> sublayout) m =

334348 Bool -> ServerT sublayout m

349+ type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c

335350

336− route Proxy subserver = WithRequest $ \ request ->

351+ route Proxy config subserver = WithRequest $ \ request ->

337352 let querytext = parseQueryText $ rawQueryString request

338353 param = case lookup paramname querytext of

339354 Just Nothing -> True -- param is there, with no value

340355 Just (Just v) -> examine v -- param with a value

341356 Nothing -> False -- param not in the query string

342− in route (Proxy :: Proxy sublayout) (passToServer subserver param)

357+ in route (Proxy :: Proxy sublayout) config (passToServer subserver param)

343358 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

344359 examine v | v == "true" || v == "1" || v == "" = True

345360 | otherwise = False

@@ -355,8 +370,9 @@ instance (KnownSymbol sym, HasServer sublayout)

355370instance HasServer Raw where

356371

357372 type ServerT Raw m = Application

373+ type HasConfig Raw c = ()

358374

359− route Proxy rawApplication = LeafRouter $ \ request respond -> do

375+ route Proxy _ rawApplication = LeafRouter $ \ request respond -> do

360376 r <- runDelayed rawApplication

361377 case r of

362378 Route app -> app request (respond . Route)

@@ -389,9 +405,10 @@ instance ( AllCTUnrender list a, HasServer sublayout

389405

390406 type ServerT (ReqBody list a :> sublayout) m =

391407 a -> ServerT sublayout m

408+ type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c

392409

393− route Proxy subserver = WithRequest $ \ request ->

394− route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))

410+ route Proxy config subserver = WithRequest $ \ request ->

411+ route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))

395412 where

396413 bodyCheck request = do

397414 -- See HTTP RFC 2616, section 7.2.1

@@ -412,37 +429,42 @@ instance ( AllCTUnrender list a, HasServer sublayout

412429instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where

413430

414431 type ServerT (path :> sublayout) m = ServerT sublayout m

432+ type HasConfig (path :> sublayout) c = HasConfig sublayout c

415433

416− route Proxy subserver = StaticRouter $

434+ route Proxy config subserver = StaticRouter $

417435 M.singleton (cs (symbolVal proxyPath))

418− (route (Proxy :: Proxy sublayout) subserver)

436+ (route (Proxy :: Proxy sublayout) config subserver)

419437 where proxyPath = Proxy :: Proxy path

420438

421439instance HasServer api => HasServer (RemoteHost :> api) where

422440 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m

441+ type HasConfig (RemoteHost :> api) c = HasConfig api c

423442

424− route Proxy subserver = WithRequest $ \req ->

425− route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)

443+ route Proxy config subserver = WithRequest $ \req ->

444+ route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)

426445

427446instance HasServer api => HasServer (IsSecure :> api) where

428447 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m

448+ type HasConfig (IsSecure :> api) c = HasConfig api c

429449

430− route Proxy subserver = WithRequest $ \req ->

431− route (Proxy :: Proxy api) (passToServer subserver $ secure req)

450+ route Proxy config subserver = WithRequest $ \req ->

451+ route (Proxy :: Proxy api) config (passToServer subserver $ secure req)

432452

433453 where secure req = if isSecure req then Secure else NotSecure

434454

435455instance HasServer api => HasServer (Vault :> api) where

436456 type ServerT (Vault :> api) m = Vault -> ServerT api m

457+ type HasConfig (Vault :> api) c = HasConfig api c

437458

438− route Proxy subserver = WithRequest $ \req ->

439− route (Proxy :: Proxy api) (passToServer subserver $ vault req)

459+ route Proxy config subserver = WithRequest $ \req ->

460+ route (Proxy :: Proxy api) config (passToServer subserver $ vault req)

440461

441462instance HasServer api => HasServer (HttpVersion :> api) where

442463 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m

464+ type HasConfig (HttpVersion :> api) c = HasConfig api c

443465

444− route Proxy subserver = WithRequest $ \req ->

445− route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)

466+ route Proxy config subserver = WithRequest $ \req ->

467+ route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)

446468

447469pathIsEmpty :: Request -> Bool

448470pathIsEmpty = go . pathInfo

@@ -452,3 +474,20 @@ pathIsEmpty = go . pathInfo

452474

453475ct_wildcard :: B.ByteString

454476ct_wildcard = "*" <> "/" <> "*" -- Because CPP

477+

478+-- * configs

479+

480+instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where

481+ type ServerT (WithNamedConfig name subConfig subApi) m =

482+ ServerT subApi m

483+ type HasConfig (WithNamedConfig name subConfig subApi) config =

484+ (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)

485+

486+ route Proxy config delayed =

487+ route subProxy subConfig delayed

488+ where

489+ subProxy :: Proxy subApi

490+ subProxy = Proxy

491+

492+ subConfig :: Config subConfig

493+ subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

servant-server/src/Servant/Server/Internal/Config.hsnew file+57

@@ -0,0 +1,57 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeOperators #-}

10+

11+#include "overlapping-compat.h"

12+

13+module Servant.Server.Internal.Config where

14+

15+import Data.Proxy

16+import GHC.TypeLits

17+

18+-- | The entire configuration.

19+data Config a where

20+ EmptyConfig :: Config '[]

21+ (:.) :: x -> Config xs -> Config (x ': xs)

22+infixr 5 :.

23+

24+instance Show (Config '[]) where

25+ show EmptyConfig = "EmptyConfig"

26+instance (Show a, Show (Config as)) => Show (Config (a ': as)) where

27+ showsPrec outerPrecedence (a :. as) =

28+ showParen (outerPrecedence > 5) $

29+ shows a . showString " :. " . shows as

30+

31+instance Eq (Config '[]) where

32+ _ == _ = True

33+instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where

34+ x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

35+

36+class HasConfigEntry (config :: [*]) (val :: *) where

37+ getConfigEntry :: Config config -> val

38+

39+instance OVERLAPPABLE_

40+ HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where

41+ getConfigEntry (_ :. xs) = getConfigEntry xs

42+

43+instance OVERLAPPING_

44+ HasConfigEntry (val ': xs) val where

45+ getConfigEntry (x :. _) = x

46+

47+-- * support for named subconfigs

48+

49+data NamedConfig (name :: Symbol) (subConfig :: [*])

50+ = NamedConfig (Config subConfig)

51+

52+descendIntoNamedConfig :: forall config name subConfig .

53+ HasConfigEntry config (NamedConfig name subConfig) =>

54+ Proxy (name :: Symbol) -> Config config -> Config subConfig

55+descendIntoNamedConfig Proxy config =

56+ let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig

57+ in subConfig

servant-server/test/Servant/Server/ErrorSpec.hs+4−4

@@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402

4242

4343errorOrderSpec :: Spec

4444errorOrderSpec = describe "HTTP error order"

45− $ with (return $ serve errorOrderApi errorOrderServer) $ do

45+ $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do

4646 let badContentType = (hContentType, "text/plain")

4747 badAccept = (hAccept, "text/plain")

4848 badMethod = methodGet

@@ -89,7 +89,7 @@ prioErrorsApi = Proxy

8989prioErrorsSpec :: Spec

9090prioErrorsSpec = describe "PrioErrors" $ do

9191 let server = return

92− with (return $ serve prioErrorsApi server) $ do

92+ with (return $ serve prioErrorsApi EmptyConfig server) $ do

9393 let check (mdescr, method) path (cdescr, ctype, body) resp =

9494 it fulldescr $

9595 Test.Hspec.Wai.request method path [(hContentType, ctype)] body

@@ -154,7 +154,7 @@ errorRetryServer

154154

155155errorRetrySpec :: Spec

156156errorRetrySpec = describe "Handler search"

157− $ with (return $ serve errorRetryApi errorRetryServer) $ do

157+ $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do

158158

159159 let jsonCT = (hContentType, "application/json")

160160 jsonAccept = (hAccept, "application/json")

@@ -194,7 +194,7 @@ errorChoiceServer = return 0

194194

195195errorChoiceSpec :: Spec

196196errorChoiceSpec = describe "Multiple handlers return errors"

197− $ with (return $ serve errorChoiceApi errorChoiceServer) $ do

197+ $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do

198198

199199 it "should respond with 404 if no path matches" $ do

200200 request methodGet "" [] "" `shouldRespondWith` 404

servant-server/test/Servant/Server/Internal/ConfigSpec.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# OPTIONS_GHC -fdefer-type-errors #-}

3+module Servant.Server.Internal.ConfigSpec (spec) where

5+import Data.Proxy (Proxy (..))

6+import Test.Hspec (Spec, describe, it, shouldBe, pending, context)

7+import Test.ShouldNotTypecheck (shouldNotTypecheck)

9+import Servant.API

10+import Servant.Server.Internal.Config

11+

12+spec :: Spec

13+spec = do

14+ describe "getConfigEntry" $ do

15+ it "gets the config if a matching one exists" $ do

16+ let config = 'a' :. EmptyConfig

17+ getConfigEntry config `shouldBe` 'a'

18+

19+ it "gets the first matching config" $ do

20+ let config = 'a' :. 'b' :. EmptyConfig

21+ getConfigEntry config `shouldBe` 'a'

22+

23+ it "does not typecheck if type does not exist" $ do

24+ let config = 'a' :. EmptyConfig

25+ x = getConfigEntry config :: Bool

26+ shouldNotTypecheck x

27+

28+ context "Show instance" $ do

29+ let config = 'a' :. True :. EmptyConfig

30+ it "has a Show instance" $ do

31+ show config `shouldBe` "'a' :. True :. EmptyConfig"

32+

33+ context "bracketing" $ do

34+ it "works" $ do

35+ show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)"

36+

37+ it "works with operators" $ do

38+ let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)

39+ show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"

40+

41+ describe "descendIntoNamedConfig" $ do

42+ let config :: Config [Char, NamedConfig "sub" '[Char]]

43+ config =

44+ 'a' :.

45+ (NamedConfig subConfig :: NamedConfig "sub" '[Char])

46+ :. EmptyConfig

47+ subConfig = 'b' :. EmptyConfig

48+ it "allows extracting subconfigs" $ do

49+ descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig

50+

51+ it "allows extracting entries from subconfigs" $ do

52+ getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char])

53+ `shouldBe` 'b'

54+

55+ it "does not typecheck if subConfig has the wrong type" $ do

56+ let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int]

57+ shouldNotTypecheck (show x)

58+

59+ it "does not typecheck if subConfig with that name doesn't exist" $ do

60+ let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char]

61+ shouldNotTypecheck (show x)

servant-server/test/Servant/Server/Internal/EnterSpec.hs+2−2

@@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'

4848

4949enterSpec :: Spec

5050enterSpec = describe "Enter" $ do

51− with (return (serve readerAPI readerServer)) $ do

51+ with (return (serve readerAPI EmptyConfig readerServer)) $ do

5252

5353 it "allows running arbitrary monads" $ do

5454 get "int" `shouldRespondWith` "1797"

5555 post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }

5656

57− with (return (serve combinedAPI combinedReaderServer)) $ do

57+ with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do

5858 it "allows combnation of enters" $ do

5959 get "bool" `shouldRespondWith` "true"

servant-server/test/Servant/Server/UsingConfigSpec.hsnew file+125

@@ -0,0 +1,125 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

6+module Servant.Server.UsingConfigSpec where

8+import Control.Monad.Trans.Except

9+import Network.Wai

10+import Test.Hspec (Spec, describe, it)

11+import Test.Hspec.Wai

12+

13+import Servant

14+import Servant.Server.UsingConfigSpec.TestCombinators

15+

16+spec :: Spec

17+spec = do

18+ spec1

19+ spec2

20+ spec3

21+ spec4

22+

23+-- * API

24+

25+type OneEntryAPI =

26+ ExtractFromConfig :> Get '[JSON] String

27+

28+testServer :: String -> ExceptT ServantErr IO String

29+testServer s = return s

30+

31+oneEntryApp :: Application

32+oneEntryApp =

33+ serve (Proxy :: Proxy OneEntryAPI) config testServer

34+ where

35+ config :: Config '[String]

36+ config = "configEntry" :. EmptyConfig

37+

38+type OneEntryTwiceAPI =

39+ "foo" :> ExtractFromConfig :> Get '[JSON] String :<|>

40+ "bar" :> ExtractFromConfig :> Get '[JSON] String

41+

42+oneEntryTwiceApp :: Application

43+oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $

44+ testServer :<|>

45+ testServer

46+ where

47+ config :: Config '[String]

48+ config = "configEntryTwice" :. EmptyConfig

49+

50+-- * tests

51+

52+spec1 :: Spec

53+spec1 = do

54+ describe "accessing config entries from custom combinators" $ do

55+ with (return oneEntryApp) $ do

56+ it "allows retrieving a ConfigEntry" $ do

57+ get "/" `shouldRespondWith` "\"configEntry\""

58+

59+ with (return oneEntryTwiceApp) $ do

60+ it "allows retrieving the same ConfigEntry twice" $ do

61+ get "/foo" `shouldRespondWith` "\"configEntryTwice\""

62+ get "/bar" `shouldRespondWith` "\"configEntryTwice\""

63+

64+type InjectAPI =

65+ InjectIntoConfig :> "untagged" :> ExtractFromConfig :>

66+ Get '[JSON] String :<|>

67+ InjectIntoConfig :> "tagged" :> ExtractFromConfig :>

68+ Get '[JSON] String

69+

70+injectApp :: Application

71+injectApp = serve (Proxy :: Proxy InjectAPI) config $

72+ (\ s -> return s) :<|>

73+ (\ s -> return ("tagged: " ++ s))

74+ where

75+ config = EmptyConfig

76+

77+spec2 :: Spec

78+spec2 = do

79+ with (return injectApp) $ do

80+ describe "inserting config entries with custom combinators" $ do

81+ it "allows to inject config entries" $ do

82+ get "/untagged" `shouldRespondWith` "\"injected\""

83+

84+ it "allows to inject tagged config entries" $ do

85+ get "/tagged" `shouldRespondWith` "\"tagged: injected\""

86+

87+type WithBirdfaceAPI =

88+ "foo" :> ExtractFromConfig :> Get '[JSON] String :<|>

89+ NamedConfigWithBirdface "sub" '[String] :>

90+ "bar" :> ExtractFromConfig :> Get '[JSON] String

91+

92+withBirdfaceApp :: Application

93+withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $

94+ testServer :<|>

95+ testServer

96+ where

97+ config :: Config '[String, (NamedConfig "sub" '[String])]

98+ config =

99+ "firstEntry" :.

100+ (NamedConfig ("secondEntry" :. EmptyConfig)) :.

101+ EmptyConfig

102+

103+spec3 :: Spec

104+spec3 = do

105+ with (return withBirdfaceApp) $ do

106+ it "allows retrieving different ConfigEntries for the same combinator" $ do

107+ get "/foo" `shouldRespondWith` "\"firstEntry\""

108+ get "/bar" `shouldRespondWith` "\"secondEntry\""

109+

110+type NamedConfigAPI =

111+ WithNamedConfig "sub" '[String] (

112+ ExtractFromConfig :> Get '[JSON] String)

113+

114+namedConfigApp :: Application

115+namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return

116+ where

117+ config :: Config '[NamedConfig "sub" '[String]]

118+ config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig

119+

120+spec4 :: Spec

121+spec4 = do

122+ with (return namedConfigApp) $ do

123+ describe "WithNamedConfig" $ do

124+ it "allows descending into a subconfig for a given api" $ do

125+ get "/" `shouldRespondWith` "\"descend\""

servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hsnew file+78

@@ -0,0 +1,78 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+

11+-- | These are custom combinators for Servant.Server.UsingConfigSpec.

12+--

13+-- (For writing your own combinators you need to import Internal modules, for

14+-- just *using* combinators that require a Config, you don't. This module is

15+-- separate from Servant.Server.UsingConfigSpec to test that the module imports

16+-- work out this way.)

17+module Servant.Server.UsingConfigSpec.TestCombinators where

18+

19+import GHC.TypeLits

20+

21+import Servant

22+import Servant.Server.Internal.Config

23+import Servant.Server.Internal.RoutingApplication

24+

25+data ExtractFromConfig

26+

27+instance (HasServer subApi) =>

28+ HasServer (ExtractFromConfig :> subApi) where

29+

30+ type ServerT (ExtractFromConfig :> subApi) m =

31+ String -> ServerT subApi m

32+ type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) =

33+ (HasConfigEntry c String, HasConfig subApi c)

34+

35+ route Proxy config delayed =

36+ route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))

37+ where

38+ subProxy :: Proxy subApi

39+ subProxy = Proxy

40+

41+ inject config f = f (getConfigEntry config)

42+

43+data InjectIntoConfig

44+

45+instance (HasServer subApi) =>

46+ HasServer (InjectIntoConfig :> subApi) where

47+

48+ type ServerT (InjectIntoConfig :> subApi) m =

49+ ServerT subApi m

50+ type HasConfig (InjectIntoConfig :> subApi) c =

51+ (HasConfig subApi (String ': c))

52+

53+ route Proxy config delayed =

54+ route subProxy newConfig delayed

55+ where

56+ subProxy :: Proxy subApi

57+ subProxy = Proxy

58+

59+ newConfig = ("injected" :: String) :. config

60+

61+data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])

62+

63+instance (HasServer subApi) =>

64+ HasServer (NamedConfigWithBirdface name subConfig :> subApi) where

65+

66+ type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =

67+ ServerT subApi m

68+ type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config =

69+ (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)

70+

71+ route Proxy config delayed =

72+ route subProxy subConfig delayed

73+ where

74+ subProxy :: Proxy subApi

75+ subProxy = Proxy

76+

77+ subConfig :: Config subConfig

78+ subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

servant-server/test/Servant/ServerSpec.hs+18−17

@@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,

4848 StdMethod (..), Verb, addHeader)

4949import Servant.API.Internal.Test.ComprehensiveAPI

5050import Servant.Server (ServantErr (..), Server, err404,

51− serve)

51+ serve, Config(EmptyConfig))

5252import Test.Hspec (Spec, context, describe, it,

5353 shouldBe, shouldContain)

5454import Test.Hspec.Wai (get, liftIO, matchHeaders,

@@ -106,7 +106,7 @@ verbSpec = describe "Servant.API.Verb" $ do

106106 wrongMethod m = if m == methodPatch then methodPost else methodPatch

107107 test desc api method (status :: Int) = context desc $

108108

109− with (return $ serve api server) $ do

109+ with (return $ serve api EmptyConfig server) $ do

110110

111111 -- HEAD and 214/215 need not return bodies

112112 unless (status `elem` [214, 215] || method == methodHead) $

@@ -181,7 +181,7 @@ captureServer legs = case legs of

181181captureSpec :: Spec

182182captureSpec = do

183183 describe "Servant.API.Capture" $ do

184− with (return (serve captureApi captureServer)) $ do

184+ with (return (serve captureApi EmptyConfig captureServer)) $ do

185185

186186 it "can capture parts of the 'pathInfo'" $ do

187187 response <- get "/2"

@@ -192,6 +192,7 @@ captureSpec = do

192192

193193 with (return (serve

194194 (Proxy :: Proxy (Capture "captured" String :> Raw))

195+ EmptyConfig

195196 (\ "captured" request_ respond ->

196197 respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

197198 it "strips the captured path snippet from pathInfo" $ do

@@ -224,8 +225,8 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize

224225queryParamSpec :: Spec

225226queryParamSpec = do

226227 describe "Servant.API.QueryParam" $ do

227− it "allows to retrieve simple GET parameters" $

228− (flip runSession) (serve queryParamApi qpServer) $ do

228+ it "allows retrieving simple GET parameters" $

229+ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do

229230 let params1 = "?name=bob"

230231 response1 <- Network.Wai.Test.request defaultRequest{

231232 rawQueryString = params1,

@@ -236,8 +237,8 @@ queryParamSpec = do

236237 name = "bob"

237238 }

238239

239− it "allows to retrieve lists in GET parameters" $

240− (flip runSession) (serve queryParamApi qpServer) $ do

240+ it "allows retrieving lists in GET parameters" $

241+ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do

241242 let params2 = "?names[]=bob&names[]=john"

242243 response2 <- Network.Wai.Test.request defaultRequest{

243244 rawQueryString = params2,

@@ -250,8 +251,8 @@ queryParamSpec = do

250251 }

251252

252253

253− it "allows to retrieve value-less GET parameters" $

254− (flip runSession) (serve queryParamApi qpServer) $ do

254+ it "allows retrieving value-less GET parameters" $

255+ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do

255256 let params3 = "?capitalize"

256257 response3 <- Network.Wai.Test.request defaultRequest{

257258 rawQueryString = params3,

@@ -303,7 +304,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do

303304 mkReq method x = Test.Hspec.Wai.request method x

304305 [(hContentType, "application/json;charset=utf-8")]

305306

306− with (return $ serve reqBodyApi server) $ do

307+ with (return $ serve reqBodyApi EmptyConfig server) $ do

307308

308309 it "passes the argument to the handler" $ do

309310 response <- mkReq methodPost "" (encode alice)

@@ -336,13 +337,13 @@ headerSpec = describe "Servant.API.Header" $ do

336337 expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"

337338 expectsString Nothing = error "Expected a string"

338339

339− with (return (serve headerApi expectsInt)) $ do

340+ with (return (serve headerApi EmptyConfig expectsInt)) $ do

340341 let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]

341342

342343 it "passes the header to the handler (Int)" $

343344 delete' "/" "" `shouldRespondWith` 200

344345

345− with (return (serve headerApi expectsString)) $ do

346+ with (return (serve headerApi EmptyConfig expectsString)) $ do

346347 let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]

347348

348349 it "passes the header to the handler (String)" $

@@ -366,7 +367,7 @@ rawSpec :: Spec

366367rawSpec = do

367368 describe "Servant.API.Raw" $ do

368369 it "runs applications" $ do

369− (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do

370+ (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do

370371 response <- Network.Wai.Test.request defaultRequest{

371372 pathInfo = ["foo"]

372373 }

@@ -374,7 +375,7 @@ rawSpec = do

374375 simpleBody response `shouldBe` "42"

375376

376377 it "gets the pathInfo modified" $ do

377− (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do

378+ (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do

378379 response <- Network.Wai.Test.request defaultRequest{

379380 pathInfo = ["foo", "bar"]

380381 }

@@ -408,7 +409,7 @@ alternativeServer =

408409alternativeSpec :: Spec

409410alternativeSpec = do

410411 describe "Servant.API.Alternative" $ do

411− with (return $ serve alternativeApi alternativeServer) $ do

412+ with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do

412413

413414 it "unions endpoints" $ do

414415 response <- get "/foo"

@@ -443,7 +444,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"

443444

444445responseHeadersSpec :: Spec

445446responseHeadersSpec = describe "ResponseHeaders" $ do

446− with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do

447+ with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do

447448

448449 let methods = [methodGet, methodPost, methodPut, methodPatch]

449450

@@ -509,7 +510,7 @@ miscServ = versionHandler

509510 hostHandler = return . show

510511

511512miscCombinatorSpec :: Spec

512−miscCombinatorSpec = with (return $ serve miscApi miscServ) $

513+miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $

513514 describe "Misc. combinators for request inspection" $ do

514515 it "Successfully gets the HTTP version specified in the request" $

515516 go "/version" "\"HTTP/1.0\""

servant-server/test/Servant/Utils/StaticFilesSpec.hs+2−2

@@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it)

1616import Test.Hspec.Wai (get, shouldRespondWith, with)

1717

1818import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)

19−import Servant.Server (Server, serve)

19+import Servant.Server (Server, serve, Config(EmptyConfig))

2020import Servant.ServerSpec (Person (Person))

2121import Servant.Utils.StaticFiles (serveDirectory)

2222

@@ -29,7 +29,7 @@ api :: Proxy Api

2929api = Proxy

3030

3131app :: Application

32−app = serve api server

32+app = serve api EmptyConfig server

3333

3434server :: Server Api

3535server =

servant/servant.cabal+1

@@ -41,6 +41,7 @@ library

4141 Servant.API.Sub

4242 Servant.API.Vault

4343 Servant.API.Verbs

44+ Servant.API.WithNamedConfig

4445 Servant.Utils.Links

4546 build-depends:

4647 base >=4.7 && <5

servant/src/Servant/API.hs+3

@@ -23,6 +23,8 @@ module Servant.API (

2323 -- | Is the request made through HTTPS?

2424 module Servant.API.Vault,

2525 -- | Access the location for arbitrary data to be shared by applications and middleware

26+ module Servant.API.WithNamedConfig,

27+ -- | Access config entries in combinators in servant-server

2628

2729 -- * Actual endpoints, distinguished by HTTP method

2830 module Servant.API.Verbs,

@@ -88,6 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte

8890 PutNoContent, PutNonAuthoritative,

8991 ReflectMethod (reflectMethod),

9092 Verb, StdMethod(..))

93+import Servant.API.WithNamedConfig (WithNamedConfig)

9194import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

9295 URI (..), safeLink)

9396import Web.HttpApiData (FromHttpApiData (..),

servant/src/Servant/API/WithNamedConfig.hsnew file+8

@@ -0,0 +1,8 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

4+module Servant.API.WithNamedConfig where

6+import GHC.TypeLits

8+data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi

stack.yaml+1

@@ -16,4 +16,5 @@ packages:

1616extra-deps:

1717- engine-io-wai-1.0.2

1818- control-monad-omega-0.3.1

19+- should-not-typecheck-2.0.1

1920resolver: nightly-2015-10-08