67315c4 · servant · git.iko.soy

.travis.yml+1−1

compare with master

unifiedsplit

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

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

26

27script:

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

29

30cache:

31 directories:

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

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

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

114api = Proxy

115api = Proxy

115

116

116server :: Application

117server :: Application

117−server = serve api (

118+server = serve api EmptyConfig (

118 return alice

119 return alice

119 :<|> return NoContent

120 :<|> return NoContent

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

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

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

141failApi = Proxy

142failApi = Proxy

142

143

143failServer :: Application

144failServer :: Application

144−failServer = serve failApi (

145+failServer = serve failApi EmptyConfig (

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

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

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

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

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

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

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

231

232

232wrappedApiSpec :: Spec

233wrappedApiSpec :: Spec

233wrappedApiSpec = describe "error status codes" $ do

234wrappedApiSpec = 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" "" []

235 context "are correctly handled by the client" $

236 context "are correctly handled by the client" $

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

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

237 test (WrappedApi api, desc) =

238 test (WrappedApi api, desc) =

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

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

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

288

289

289data WrappedApi where

290data WrappedApi where

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

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

292+ , HasConfig api '[], HasClient api

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

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

292 Proxy api -> WrappedApi

294 Proxy api -> WrappedApi

293

295

294

296

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

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

8

9import Data.Aeson

10import Data.ByteString (ByteString)

11+import Data.IORef

11import Data.Text (Text)

12import Data.Text (Text)

12import GHC.Generics

13import GHC.Generics

13import Network.Wai

14import Network.Wai

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

18-- Pretty much stolen/adapted from

19-- Pretty much stolen/adapted from

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

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

20

21

22+type DBConnection = IORef [ByteString]

21−type DBLookup = ByteString -> IO Bool

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

24+

25+initDB :: IO DBConnection

26+initDB = newIORef ["good password"]

22

27

23isGoodCookie :: DBLookup

28isGoodCookie :: DBLookup

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

29+isGoodCookie ref password = do

30+ allowed <- readIORef ref

31+ return (password `elem` allowed)

25

32

26data AuthProtected

33data AuthProtected

27

34

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

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

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

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

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

38+ (HasConfigEntry config DBConnection, HasConfig rest config)

30

39

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

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

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

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

33 where

42 where

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

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

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

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

36 Just v -> do

45 Just v -> do

46+ let dbConnection = getConfigEntry config

37− authGranted <- isGoodCookie v

47+ authGranted <- isGoodCookie dbConnection v

38 if authGranted

48 if authGranted

39 then return $ Route ()

49 then return $ Route ()

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

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

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

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

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

67

77

68main :: IO ()

78main :: IO ()

79+main = do

80+ dbConnection <- initDB

81+ let config = dbConnection :. EmptyConfig

69−main = run 8080 (serve api server)

82+ run 8080 (serve api config server)

70

83

71{- Sample session:

84{- Sample session:

72$ curl http://localhost:8080/

85$ curl http://localhost:8080/

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

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

38

39

40app :: WaiMonad () -> Application

41−app sHandler = serve api $ server sHandler

41+app sHandler = serve api EmptyConfig $ server sHandler

42

43port :: Int

44port = 3001

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

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

42server = return users

43

44app :: 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

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

69

70app :: 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

49 :<|> return isaac

50

51app :: 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

81 marketing clientinfo = return (emailForClient clientinfo)

82

83app :: 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

60server = return persons

61

62app :: 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

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

35

36app :: 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

15server = serveDirectory "tutorial"

16

17app :: 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

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

31

32app :: 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

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

103

104app :: 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

41

42-- logStdout :: Middleware

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

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

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

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

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

47app :: Application

48−app = logStdout (serve simpleAPI server)

48+app = logStdout (serve simpleAPI EmptyConfig server)

49

50main :: IO ()

51main = run 8080 app

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

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

20api = Proxy

21

22main :: 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

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

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

61test :: Application

62−test = serve testApi server

62+test = serve testApi EmptyConfig server

63

64-- Run the server.

65--

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

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

37 Servant

38 Servant.Server

39 Servant.Server.Internal

40+ Servant.Server.Internal.Config

40 Servant.Server.Internal.Enter

41 Servant.Server.Internal.Enter

41 Servant.Server.Internal.Router

42 Servant.Server.Internal.Router

42 Servant.Server.Internal.RoutingApplication

43 Servant.Server.Internal.RoutingApplication

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

94 hs-source-dirs: test

95 hs-source-dirs: test

95 main-is: Spec.hs

96 main-is: Spec.hs

96 other-modules:

97 other-modules:

98+ Servant.Server.ErrorSpec

99+ Servant.Server.Internal.ConfigSpec

97 Servant.Server.Internal.EnterSpec

100 Servant.Server.Internal.EnterSpec

98 Servant.ServerSpec

101 Servant.ServerSpec

102+ Servant.Server.UsingConfigSpec

103+ Servant.Server.UsingConfigSpec.TestCombinators

99 Servant.Utils.StaticFilesSpec

104 Servant.Utils.StaticFilesSpec

100− Servant.Server.ErrorSpec

101 build-depends:

105 build-depends:

102 base == 4.*

106 base == 4.*

103 , aeson

107 , aeson

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

115 , servant

119 , servant

116 , servant-server

120 , servant-server

117 , string-conversions

121 , string-conversions

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

118 , temporary

123 , temporary

119 , text

124 , text

120 , transformers

125 , transformers

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

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

1+{-# LANGUAGE ConstraintKinds #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

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

35 , generalizeNat

36 , generalizeNat

36 , tweakResponse

37 , tweakResponse

37

38

39+ -- * Config

40+ , Config(..)

41+ , NamedConfig(..)

42+

38 -- * Default error type

43 -- * Default error type

39 , ServantErr(..)

44 , ServantErr(..)

40 -- ** 3XX

45 -- ** 3XX

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

96-- > myApi :: Proxy MyApi

101-- > myApi :: Proxy MyApi

97-- > myApi = Proxy

102-- > myApi = Proxy

98-- >

103-- >

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

105+-- > config = EmptyConfig

106+-- >

99-- > app :: Application

107-- > app :: Application

100−-- > app = serve myApi server

108+-- > app = serve myApi config server

101-- >

109-- >

102-- > main :: IO ()

110-- > main :: IO ()

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

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

104--

112--

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

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

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

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

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

107 where

116 where

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

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

109 r = return (Route ())

118 r = return (Route ())

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

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

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

13

14

14module Servant.Server.Internal

15module Servant.Server.Internal

15 ( module Servant.Server.Internal

16 ( module Servant.Server.Internal

17+ , module Servant.Server.Internal.Config

16 , module Servant.Server.Internal.Router

18 , module Servant.Server.Internal.Router

17 , module Servant.Server.Internal.RoutingApplication

19 , module Servant.Server.Internal.RoutingApplication

18 , module Servant.Server.Internal.ServantErr

20 , module Servant.Server.Internal.ServantErr

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

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

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

31import Data.Text (Text)

33import Data.Text (Text)

32import Data.Typeable

34import Data.Typeable

35+import GHC.Exts (Constraint)

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

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

34 symbolVal)

37 symbolVal)

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

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

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

49 Verb, ReflectMethod(reflectMethod),

52 Verb, ReflectMethod(reflectMethod),

50 IsSecure(..), Header,

53 IsSecure(..), Header,

51 QueryFlag, QueryParam, QueryParams,

54 QueryFlag, QueryParam, QueryParams,

52− Raw, RemoteHost, ReqBody, Vault)

55+ Raw, RemoteHost, ReqBody, Vault,

56+ WithNamedConfig)

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

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

54 AllCTRender (..),

58 AllCTRender (..),

55 AllCTUnrender (..),

59 AllCTUnrender (..),

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

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

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

59 getResponse)

63 getResponse)

60

64

65+import Servant.Server.Internal.Config

61import Servant.Server.Internal.Router

66import Servant.Server.Internal.Router

62import Servant.Server.Internal.RoutingApplication

67import Servant.Server.Internal.RoutingApplication

63import Servant.Server.Internal.ServantErr

68import Servant.Server.Internal.ServantErr

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

65

70

66class HasServer layout where

71class HasServer layout where

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

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

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

68

74

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

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

70

76

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

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

72

78

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

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

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

87

93

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

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

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

89

96

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

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

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

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

92 where pa = Proxy :: Proxy a

99 where pa = Proxy :: Proxy a

93 pb = Proxy :: Proxy b

100 pb = Proxy :: Proxy b

94

101

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

117

124

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

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

119 a -> ServerT sublayout m

126 a -> ServerT sublayout m

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

120

128

121− route Proxy d =

129+ route Proxy config d =

122 DynamicRouter $ \ first ->

130 DynamicRouter $ \ first ->

123 route (Proxy :: Proxy sublayout)

131 route (Proxy :: Proxy sublayout)

132+ config

124 (addCapture d $ case captured captureProxy first of

133 (addCapture d $ case captured captureProxy first of

125 Nothing -> return $ Fail err404

134 Nothing -> return $ Fail err404

126 Just v -> return $ Route v

135 Just v -> return $ Route v

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

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

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

193

202

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

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

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

195

205

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

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

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

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

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

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

199

209

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

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

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

204

214

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

215 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 = ()

206

217

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

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

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

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

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

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

210

221

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

233

244

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

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

235 Maybe a -> ServerT sublayout m

246 Maybe a -> ServerT sublayout m

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

236

248

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

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

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

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

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

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

241

253

242-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

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

265

277

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

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

267 Maybe a -> ServerT sublayout m

279 Maybe a -> ServerT sublayout m

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

268

281

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

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

270 let querytext = parseQueryText $ rawQueryString request

283 let querytext = parseQueryText $ rawQueryString request

271 param =

284 param =

272 case lookup paramname querytext of

285 case lookup paramname querytext of

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

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

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

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

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

276 -- the right type

289 -- the right type

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

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

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

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

279

292

280-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,

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

301

314

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

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

303 [a] -> ServerT sublayout m

316 [a] -> ServerT sublayout m

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

304

318

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

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

306 let querytext = parseQueryText $ rawQueryString request

320 let querytext = parseQueryText $ rawQueryString request

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

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

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

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

309 -- corresponding values

323 -- corresponding values

310 parameters = filter looksLikeParam querytext

324 parameters = filter looksLikeParam querytext

311 values = mapMaybe (convert . snd) parameters

325 values = mapMaybe (convert . snd) parameters

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

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

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

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

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

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

315 convert Nothing = Nothing

329 convert Nothing = Nothing

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

332

346

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

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

334 Bool -> ServerT sublayout m

348 Bool -> ServerT sublayout m

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

335

350

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

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

337 let querytext = parseQueryText $ rawQueryString request

352 let querytext = parseQueryText $ rawQueryString request

338 param = case lookup paramname querytext of

353 param = case lookup paramname querytext of

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

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

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

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

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

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

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

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

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

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

345 | otherwise = False

360 | otherwise = False

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

355instance HasServer Raw where

370instance HasServer Raw where

356

371

357 type ServerT Raw m = Application

372 type ServerT Raw m = Application

373+ type HasConfig Raw c = ()

358

374

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

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

360 r <- runDelayed rawApplication

376 r <- runDelayed rawApplication

361 case r of

377 case r of

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

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

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

389

405

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

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

391 a -> ServerT sublayout m

407 a -> ServerT sublayout m

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

392

409

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

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

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

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

395 where

412 where

396 bodyCheck request = do

413 bodyCheck request = do

397 -- See HTTP RFC 2616, section 7.2.1

414 -- See HTTP RFC 2616, section 7.2.1

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

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

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

413

430

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

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

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

415

433

416− route Proxy subserver = StaticRouter $

434+ route Proxy config subserver = StaticRouter $

417 M.singleton (cs (symbolVal proxyPath))

435 M.singleton (cs (symbolVal proxyPath))

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

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

419 where proxyPath = Proxy :: Proxy path

437 where proxyPath = Proxy :: Proxy path

420

438

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

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

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

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

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

423

442

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

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

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

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

426

445

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

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

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

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

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

429

449

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

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

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

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

432

452

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

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

434

454

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

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

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

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

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

437

458

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

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

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

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

440

461

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

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

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

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

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

443

465

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

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

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

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

446

468

447pathIsEmpty :: Request -> Bool

469pathIsEmpty :: Request -> Bool

448pathIsEmpty = go . pathInfo

470pathIsEmpty = go . pathInfo

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

452

474

453ct_wildcard :: B.ByteString

475ct_wildcard :: B.ByteString

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

476ct_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

42

43errorOrderSpec :: Spec

44errorOrderSpec = describe "HTTP error order"

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

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

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

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

48 badMethod = methodGet

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

89prioErrorsSpec :: Spec

90prioErrorsSpec = describe "PrioErrors" $ do

91 let server = return

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

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

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

94 it fulldescr $

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

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

154

155errorRetrySpec :: Spec

156errorRetrySpec = describe "Handler search"

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

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

158

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

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

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

194

195errorChoiceSpec :: Spec

196errorChoiceSpec = describe "Multiple handlers return errors"

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

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

198

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

200 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

4+

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

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

7+import Test.ShouldNotTypecheck (shouldNotTypecheck)

8+

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'

48

49enterSpec :: Spec

50enterSpec = describe "Enter" $ do

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

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

52

53 it "allows running arbitrary monads" $ do

54 get "int" `shouldRespondWith` "1797"

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

56

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

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

58 it "allows combnation of enters" $ do

59 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 #-}

5+

6+module Servant.Server.UsingConfigSpec where

7+

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,

48 StdMethod (..), Verb, addHeader)

49import Servant.API.Internal.Test.ComprehensiveAPI

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

51− serve)

51+ serve, Config(EmptyConfig))

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

53 shouldBe, shouldContain)

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

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

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

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

108

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

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

110

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

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

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

181captureSpec :: Spec

182captureSpec = do

183 describe "Servant.API.Capture" $ do

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

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

185

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

187 response <- get "/2"

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

192

193 with (return (serve

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

195+ EmptyConfig

195 (\ "captured" request_ respond ->

196 (\ "captured" request_ respond ->

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

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

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

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

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

224queryParamSpec :: Spec

225queryParamSpec :: Spec

225queryParamSpec = do

226queryParamSpec = do

226 describe "Servant.API.QueryParam" $ do

227 describe "Servant.API.QueryParam" $ do

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

228+ it "allows retrieving simple GET parameters" $

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

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

229 let params1 = "?name=bob"

230 let params1 = "?name=bob"

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

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

231 rawQueryString = params1,

232 rawQueryString = params1,

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

236 name = "bob"

237 name = "bob"

237 }

238 }

238

239

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

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

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

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

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

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

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

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

243 rawQueryString = params2,

244 rawQueryString = params2,

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

250 }

251 }

251

252

253

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

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

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

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

255 let params3 = "?capitalize"

256 let params3 = "?capitalize"

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

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

257 rawQueryString = params3,

258 rawQueryString = params3,

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

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

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

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

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

305

306

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

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

307

308

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

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

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

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

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

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

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

337 expectsString Nothing = error "Expected a string"

338 expectsString Nothing = error "Expected a string"

338

339

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

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

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

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

341

342

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

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

343 delete' "/" "" `shouldRespondWith` 200

344 delete' "/" "" `shouldRespondWith` 200

344

345

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

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

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

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

347

348

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

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

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

366rawSpec = do

367rawSpec = do

367 describe "Servant.API.Raw" $ do

368 describe "Servant.API.Raw" $ do

368 it "runs applications" $ do

369 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

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

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

371 pathInfo = ["foo"]

372 pathInfo = ["foo"]

372 }

373 }

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

374 simpleBody response `shouldBe` "42"

375 simpleBody response `shouldBe` "42"

375

376

376 it "gets the pathInfo modified" $ do

377 it "gets the pathInfo modified" $ do

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

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

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

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

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

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

380 }

381 }

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

408alternativeSpec :: Spec

409alternativeSpec :: Spec

409alternativeSpec = do

410alternativeSpec = do

410 describe "Servant.API.Alternative" $ do

411 describe "Servant.API.Alternative" $ do

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

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

412

413

413 it "unions endpoints" $ do

414 it "unions endpoints" $ do

414 response <- get "/foo"

415 response <- get "/foo"

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

443

444

444responseHeadersSpec :: Spec

445responseHeadersSpec :: Spec

445responseHeadersSpec = describe "ResponseHeaders" $ do

446responseHeadersSpec = describe "ResponseHeaders" $ do

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

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

447

448

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

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

449

450

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

509 hostHandler = return . show

510 hostHandler = return . show

510

511

511miscCombinatorSpec :: Spec

512miscCombinatorSpec :: Spec

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

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

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

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

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

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

515 go "/version" "\"HTTP/1.0\""

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

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

17

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

19−import Servant.Server (Server, serve)

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

20import Servant.ServerSpec (Person (Person))

21import Servant.Utils.StaticFiles (serveDirectory)

22

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

29api = Proxy

30

31app :: Application

32−app = serve api server

32+app = serve api EmptyConfig server

33

34server :: Server Api

35server =

servant/servant.cabal+1

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

41 Servant.API.Sub

42 Servant.API.Vault

43 Servant.API.Verbs

44+ Servant.API.WithNamedConfig

44 Servant.Utils.Links

45 Servant.Utils.Links

45 build-depends:

46 build-depends:

46 base >=4.7 && <5

47 base >=4.7 && <5

servant/src/Servant/API.hs+3

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

23 -- | Is the request made through HTTPS?

24 module Servant.API.Vault,

25 -- | 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

26

28

27 -- * Actual endpoints, distinguished by HTTP method

29 -- * Actual endpoints, distinguished by HTTP method

28 module Servant.API.Verbs,

30 module Servant.API.Verbs,

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

88 PutNoContent, PutNonAuthoritative,

90 PutNoContent, PutNonAuthoritative,

89 ReflectMethod (reflectMethod),

91 ReflectMethod (reflectMethod),

90 Verb, StdMethod(..))

92 Verb, StdMethod(..))

93+import Servant.API.WithNamedConfig (WithNamedConfig)

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

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

92 URI (..), safeLink)

95 URI (..), safeLink)

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

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

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+

4+module Servant.API.WithNamedConfig where

5+

6+import GHC.TypeLits

7+

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

stack.yaml+1

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

16extra-deps:

17- engine-io-wai-1.0.2

18- control-monad-omega-0.3.1

19+- should-not-typecheck-2.0.1

19resolver: nightly-2015-10-08

20resolver: nightly-2015-10-08