8ef4d45 · typeable/servant

git.iko.soy/typeable/servant

renaming: Config -> Context

commit8ef4d4543b572d32abdd79c0cd7bc6ff9d2af43e authorSönke Hahn <soenkehahn@gmail.com> dateSun 28 Feb 2016, 23:23 (11 years ago) parent65d0a51

24 files changed+509−510

compare with master

unifiedsplit

servant-client/src/Servant/Client.hs+2−2 servant-docs/src/Servant/Docs/Internal.hs+1−1 servant-examples/auth-combinator/auth-combinator.hs+7−7 servant-examples/wai-middleware/wai-middleware.hs+1−1 servant-foreign/src/Servant/Foreign/Internal.hs+2−2 servant-mock/src/Servant/Mock.hs+33−33 servant-mock/test/Servant/MockSpec.hs+1−1 servant-server/servant-server.cabal+4−4 servant-server/src/Servant/Server.hs+11−11 servant-server/src/Servant/Server/Internal.hs+58−58 servant-server/src/Servant/Server/Internal/Config.hs−99 servant-server/src/Servant/Server/Internal/Context.hs+99 servant-server/test/Servant/Server/Internal/ConfigSpec.hs−61 servant-server/test/Servant/Server/Internal/ContextSpec.hs+61 servant-server/test/Servant/Server/UsingConfigSpec.hs−125 servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs−73 servant-server/test/Servant/Server/UsingContextSpec.hs+125 servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs+72 servant-server/test/Servant/ServerSpec.hs+6−6 servant/servant.cabal+1−1 servant/src/Servant/API.hs+3−3 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+1−1 servant/src/Servant/API/WithNamedConfig.hs−21 servant/src/Servant/API/WithNamedContext.hs+21

servant-client/src/Servant/Client.hs+2−2

@@ -418,9 +418,9 @@ instance HasClient api => HasClient (IsSecure :> api) where

418418 clientWithRoute (Proxy :: Proxy api) req baseurl manager

419419

420420instance HasClient subapi =>

421− HasClient (WithNamedConfig name config subapi) where

421+ HasClient (WithNamedContext name context subapi) where

422422

423− type Client (WithNamedConfig name config subapi) = Client subapi

423+ type Client (WithNamedContext name context subapi) = Client subapi

424424 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

425425

426426

servant-docs/src/Servant/Docs/Internal.hs+1−1

@@ -794,7 +794,7 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where

794794 docsFor Proxy ep =

795795 docsFor (Proxy :: Proxy sublayout) ep

796796

797−instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where

797+instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where

798798 docsFor Proxy = docsFor (Proxy :: Proxy sublayout)

799799

800800-- ToSample instances for simple types

servant-examples/auth-combinator/auth-combinator.hs+7−7

@@ -35,18 +35,18 @@ isGoodCookie ref password = do

3535

3636data AuthProtected

3737

38−instance (HasConfigEntry config DBConnection, HasServer rest config)

39− => HasServer (AuthProtected :> rest) config where

38+instance (HasContextEntry context DBConnection, HasServer rest context)

39+ => HasServer (AuthProtected :> rest) context where

4040

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

4242

43− route Proxy config subserver = WithRequest $ \ request ->

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

43+ route Proxy context subserver = WithRequest $ \ request ->

44+ route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request

4545 where

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

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

4848 Just v -> do

49− let dbConnection = getConfigEntry config

49+ let dbConnection = getContextEntry context

5050 authGranted <- isGoodCookie dbConnection v

5151 if authGranted

5252 then return $ Route ()

@@ -81,8 +81,8 @@ server = return prvdata :<|> return pubdata

8181main :: IO ()

8282main = do

8383 dbConnection <- initDB

84− let config = dbConnection :. EmptyConfig

85− run 8080 (serveWithConfig api config server)

84+ let context = dbConnection :. EmptyContext

85+ run 8080 (serveWithContext api context server)

8686

8787{- Sample session:

8888$ curl http://localhost:8080/

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

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

4141

4242-- logStdout :: Middleware

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

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

44+-- serve :: Proxy api -> Context context -> Server api -> Application

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

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

4747app :: Application

servant-foreign/src/Servant/Foreign/Internal.hs+2−2

@@ -310,9 +310,9 @@ instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where

310310 foreignFor lang (Proxy :: Proxy sublayout) req

311311

312312instance HasForeign lang sublayout =>

313− HasForeign lang (WithNamedConfig name config sublayout) where

313+ HasForeign lang (WithNamedContext name context sublayout) where

314314

315− type Foreign (WithNamedConfig name config sublayout) = Foreign sublayout

315+ type Foreign (WithNamedContext name context sublayout) = Foreign sublayout

316316

317317 foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout)

318318

servant-mock/src/Servant/Mock.hs+33−33

@@ -74,7 +74,7 @@ import Test.QuickCheck.Gen (Gen, generate)

7474-- than turns them into random-response-generating

7575-- request handlers, hence providing an instance for

7676-- all the combinators of the core /servant/ library.

77−class HasServer api config => HasMock api config where

77+class HasServer api context => HasMock api context where

7878 -- | Calling this method creates request handlers of

7979 -- the right type to implement the API described by

8080 -- @api@ that just generate random response values of

@@ -104,67 +104,67 @@ class HasServer api config => HasMock api config where

104104 -- So under the hood, 'mock' uses the 'IO' bit to generate

105105 -- random values of type 'User' and 'Book' every time these

106106 -- endpoints are requested.

107− mock :: Proxy api -> Proxy config -> Server api

107+ mock :: Proxy api -> Proxy context -> Server api

108108

109−instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where

110− mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config

109+instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where

110+ mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context

111111

112−instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where

112+instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where

113113 mock _ = mock (Proxy :: Proxy rest)

114114

115−instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where

116− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

115+instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where

116+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

117117

118−instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where

119− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

118+instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where

119+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

120120

121−instance HasMock rest config => HasMock (RemoteHost :> rest) config where

122− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

121+instance HasMock rest context => HasMock (RemoteHost :> rest) context where

122+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

123123

124−instance HasMock rest config => HasMock (IsSecure :> rest) config where

125− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

124+instance HasMock rest context => HasMock (IsSecure :> rest) context where

125+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

126126

127−instance HasMock rest config => HasMock (Vault :> rest) config where

128− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

127+instance HasMock rest context => HasMock (Vault :> rest) context where

128+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

129129

130−instance HasMock rest config => HasMock (HttpVersion :> rest) config where

131− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

130+instance HasMock rest context => HasMock (HttpVersion :> rest) context where

131+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

132132

133−instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)

134− => HasMock (QueryParam s a :> rest) config where

135− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

133+instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)

134+ => HasMock (QueryParam s a :> rest) context where

135+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

136136

137−instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)

138− => HasMock (QueryParams s a :> rest) config where

139− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

137+instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)

138+ => HasMock (QueryParams s a :> rest) context where

139+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

140140

141−instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where

142− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

141+instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where

142+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

143143

144−instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where

145− mock _ config = \_ -> mock (Proxy :: Proxy rest) config

144+instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where

145+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

146146

147147instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)

148− => HasMock (Verb method status ctypes a) config where

148+ => HasMock (Verb method status ctypes a) context where

149149 mock _ _ = mockArbitrary

150150

151151instance OVERLAPPING_

152152 (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),

153153 Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)

154− => HasMock (Verb method status ctypes (Headers headerTypes a)) config where

154+ => HasMock (Verb method status ctypes (Headers headerTypes a)) context where

155155 mock _ _ = mockArbitrary

156156

157−instance HasMock Raw config where

157+instance HasMock Raw context where

158158 mock _ _ = \_req respond -> do

159159 bdy <- genBody

160160 respond $ responseLBS status200 [] bdy

161161

162162 where genBody = pack <$> generate (vector 100 :: Gen [Char])

163163

164−instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) =>

165− HasMock (WithNamedConfig name subConfig rest) config where

164+instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) =>

165+ HasMock (WithNamedContext name subContext rest) context where

166166

167− mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig)

167+ mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext)

168168

169169mockArbitrary :: (MonadIO m, Arbitrary a) => m a

170170mockArbitrary = liftIO (generate arbitrary)

servant-mock/test/Servant/MockSpec.hs+1−1

@@ -23,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI

2323import Servant.Mock

2424

2525-- This declaration simply checks that all instances are in place.

26−_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]])

26+_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]])

2727

2828data Body

2929 = Body

servant-server/servant-server.cabal+4−4

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

3737 Servant

3838 Servant.Server

3939 Servant.Server.Internal

40− Servant.Server.Internal.Config

40+ Servant.Server.Internal.Context

4141 Servant.Server.Internal.Enter

4242 Servant.Server.Internal.Router

4343 Servant.Server.Internal.RoutingApplication

@@ -96,11 +96,11 @@ test-suite spec

9696 main-is: Spec.hs

9797 other-modules:

9898 Servant.Server.ErrorSpec

99− Servant.Server.Internal.ConfigSpec

99+ Servant.Server.Internal.ContextSpec

100100 Servant.Server.Internal.EnterSpec

101101 Servant.ServerSpec

102− Servant.Server.UsingConfigSpec

103− Servant.Server.UsingConfigSpec.TestCombinators

102+ Servant.Server.UsingContextSpec

103+ Servant.Server.UsingContextSpec.TestCombinators

104104 Servant.Utils.StaticFilesSpec

105105 build-depends:

106106 base == 4.*

servant-server/src/Servant/Server.hs+11−11

@@ -9,7 +9,7 @@

99module Servant.Server

1010 ( -- * Run a wai application from an API

1111 serve

12− , serveWithConfig

12+ , serveWithContext

1313

1414 , -- * Construct a wai Application from an API

1515 toApplication

@@ -38,12 +38,12 @@ module Servant.Server

3838 , generalizeNat

3939 , tweakResponse

4040

41− -- * Config

42− , Config(..)

43− , HasConfigEntry(getConfigEntry)

44− -- ** NamedConfig

45− , NamedConfig(..)

46− , descendIntoNamedConfig

41+ -- * Context

42+ , Context(..)

43+ , HasContextEntry(getContextEntry)

44+ -- ** NamedContext

45+ , NamedContext(..)

46+ , descendIntoNamedContext

4747

4848 -- * Default error type

4949 , ServantErr(..)

@@ -113,11 +113,11 @@ import Servant.Server.Internal.Enter

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

114114--

115115serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application

116−serve p = serveWithConfig p EmptyConfig

116+serve p = serveWithContext p EmptyContext

117117

118−serveWithConfig :: (HasServer layout config)

119− => Proxy layout -> Config config -> Server layout -> Application

120−serveWithConfig p config server = toApplication (runRouter (route p config d))

118+serveWithContext :: (HasServer layout context)

119+ => Proxy layout -> Context context -> Server layout -> Application

120+serveWithContext p context server = toApplication (runRouter (route p context d))

121121 where

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

123123 r = return (Route ())

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

@@ -15,7 +15,7 @@

1515

1616module Servant.Server.Internal

1717 ( module Servant.Server.Internal

18− , module Servant.Server.Internal.Config

18+ , module Servant.Server.Internal.Context

1919 , module Servant.Server.Internal.Router

2020 , module Servant.Server.Internal.RoutingApplication

2121 , module Servant.Server.Internal.ServantErr

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

5353 IsSecure(..), Header,

5454 QueryFlag, QueryParam, QueryParams,

5555 Raw, RemoteHost, ReqBody, Vault,

56− WithNamedConfig)

56+ WithNamedContext)

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

5858 AllCTRender (..),

5959 AllCTUnrender (..),

@@ -62,16 +62,16 @@ import Servant.API.ContentTypes (AcceptHeader (..),

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

6363 getResponse)

6464

65−import Servant.Server.Internal.Config

65+import Servant.Server.Internal.Context

6666import Servant.Server.Internal.Router

6767import Servant.Server.Internal.RoutingApplication

6868import Servant.Server.Internal.ServantErr

6969

7070

71−class HasServer layout config where

71+class HasServer layout context where

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

7373

74− route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router

74+ route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router

7575

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

7777

@@ -88,12 +88,12 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)

8888-- > server = listAllBooks :<|> postBook

8989-- > where listAllBooks = ...

9090-- > postBook book = ...

91−instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where

91+instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where

9292

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

9494

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

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

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

96+ (route pb context ((\ (_ :<|> b) -> b) <$> server))

9797 where pa = Proxy :: Proxy a

9898 pb = Proxy :: Proxy b

9999

@@ -117,16 +117,16 @@ captured _ = parseUrlPieceMaybe

117117-- > server = getBook

118118-- > where getBook :: Text -> ExceptT ServantErr IO Book

119119-- > getBook isbn = ...

120−instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config)

121− => HasServer (Capture capture a :> sublayout) config where

120+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)

121+ => HasServer (Capture capture a :> sublayout) context where

122122

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

124124 a -> ServerT sublayout m

125125

126− route Proxy config d =

126+ route Proxy context d =

127127 DynamicRouter $ \ first ->

128128 route (Proxy :: Proxy sublayout)

129− config

129+ context

130130 (addCapture d $ case captured captureProxy first of

131131 Nothing -> return $ Fail err404

132132 Just v -> return $ Route v

@@ -195,7 +195,7 @@ methodRouterHeaders method proxy status action = LeafRouter route'

195195

196196instance OVERLAPPABLE_

197197 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

198− ) => HasServer (Verb method status ctypes a) config where

198+ ) => HasServer (Verb method status ctypes a) context where

199199

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

201201

@@ -206,7 +206,7 @@ instance OVERLAPPABLE_

206206instance OVERLAPPING_

207207 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

208208 , GetHeaders (Headers h a)

209− ) => HasServer (Verb method status ctypes (Headers h a)) config where

209+ ) => HasServer (Verb method status ctypes (Headers h a)) context where

210210

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

212212

@@ -234,15 +234,15 @@ instance OVERLAPPING_

234234-- > server = viewReferer

235235-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer

236236-- > viewReferer referer = return referer

237−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

238− => HasServer (Header sym a :> sublayout) config where

237+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

238+ => HasServer (Header sym a :> sublayout) context where

239239

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

241241 Maybe a -> ServerT sublayout m

242242

243− route Proxy config subserver = WithRequest $ \ request ->

243+ route Proxy context subserver = WithRequest $ \ request ->

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

245− in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)

245+ in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)

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

247247

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

@@ -266,13 +266,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

266266-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]

267267-- > getBooksBy Nothing = ...return all books...

268268-- > getBooksBy (Just author) = ...return books by the given author...

269−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

270− => HasServer (QueryParam sym a :> sublayout) config where

269+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

270+ => HasServer (QueryParam sym a :> sublayout) context where

271271

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

273273 Maybe a -> ServerT sublayout m

274274

275− route Proxy config subserver = WithRequest $ \ request ->

275+ route Proxy context subserver = WithRequest $ \ request ->

276276 let querytext = parseQueryText $ rawQueryString request

277277 param =

278278 case lookup paramname querytext of

@@ -280,7 +280,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

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

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

282282 -- the right type

283− in route (Proxy :: Proxy sublayout) config (passToServer subserver param)

283+ in route (Proxy :: Proxy sublayout) context (passToServer subserver param)

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

285285

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

@@ -302,20 +302,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

302302-- > server = getBooksBy

303303-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]

304304-- > getBooksBy authors = ...return all books by these authors...

305−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

306− => HasServer (QueryParams sym a :> sublayout) config where

305+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

306+ => HasServer (QueryParams sym a :> sublayout) context where

307307

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

309309 [a] -> ServerT sublayout m

310310

311− route Proxy config subserver = WithRequest $ \ request ->

311+ route Proxy context subserver = WithRequest $ \ request ->

312312 let querytext = parseQueryText $ rawQueryString request

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

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

315315 -- corresponding values

316316 parameters = filter looksLikeParam querytext

317317 values = mapMaybe (convert . snd) parameters

318− in route (Proxy :: Proxy sublayout) config (passToServer subserver values)

318+ in route (Proxy :: Proxy sublayout) context (passToServer subserver values)

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

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

321321 convert Nothing = Nothing

@@ -333,19 +333,19 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)

333333-- > server = getBooks

334334-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]

335335-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...

336−instance (KnownSymbol sym, HasServer sublayout config)

337− => HasServer (QueryFlag sym :> sublayout) config where

336+instance (KnownSymbol sym, HasServer sublayout context)

337+ => HasServer (QueryFlag sym :> sublayout) context where

338338

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

340340 Bool -> ServerT sublayout m

341341

342− route Proxy config subserver = WithRequest $ \ request ->

342+ route Proxy context subserver = WithRequest $ \ request ->

343343 let querytext = parseQueryText $ rawQueryString request

344344 param = case lookup paramname querytext of

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

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

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

348− in route (Proxy :: Proxy sublayout) config (passToServer subserver param)

348+ in route (Proxy :: Proxy sublayout) context (passToServer subserver param)

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

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

351351 | otherwise = False

@@ -358,7 +358,7 @@ instance (KnownSymbol sym, HasServer sublayout config)

358358-- >

359359-- > server :: Server MyApi

360360-- > server = serveDirectory "/var/www/images"

361−instance HasServer Raw config where

361+instance HasServer Raw context where

362362

363363 type ServerT Raw m = Application

364364

@@ -390,14 +390,14 @@ instance HasServer Raw config where

390390-- > server = postBook

391391-- > where postBook :: Book -> ExceptT ServantErr IO Book

392392-- > postBook book = ...insert into your db...

393−instance ( AllCTUnrender list a, HasServer sublayout config

394− ) => HasServer (ReqBody list a :> sublayout) config where

393+instance ( AllCTUnrender list a, HasServer sublayout context

394+ ) => HasServer (ReqBody list a :> sublayout) context where

395395

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

397397 a -> ServerT sublayout m

398398

399− route Proxy config subserver = WithRequest $ \ request ->

400− route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))

399+ route Proxy context subserver = WithRequest $ \ request ->

400+ route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))

401401 where

402402 bodyCheck request = do

403403 -- See HTTP RFC 2616, section 7.2.1

@@ -415,40 +415,40 @@ instance ( AllCTUnrender list a, HasServer sublayout config

415415

416416-- | Make sure the incoming request starts with @"/path"@, strip it and

417417-- pass the rest of the request path to @sublayout@.

418−instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where

418+instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where

419419

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

421421

422− route Proxy config subserver = StaticRouter $

422+ route Proxy context subserver = StaticRouter $

423423 M.singleton (cs (symbolVal proxyPath))

424− (route (Proxy :: Proxy sublayout) config subserver)

424+ (route (Proxy :: Proxy sublayout) context subserver)

425425 where proxyPath = Proxy :: Proxy path

426426

427−instance HasServer api config => HasServer (RemoteHost :> api) config where

427+instance HasServer api context => HasServer (RemoteHost :> api) context where

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

429429

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

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

430+ route Proxy context subserver = WithRequest $ \req ->

431+ route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)

432432

433−instance HasServer api config => HasServer (IsSecure :> api) config where

433+instance HasServer api context => HasServer (IsSecure :> api) context where

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

435435

436− route Proxy config subserver = WithRequest $ \req ->

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

436+ route Proxy context subserver = WithRequest $ \req ->

437+ route (Proxy :: Proxy api) context (passToServer subserver $ secure req)

438438

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

440440

441−instance HasServer api config => HasServer (Vault :> api) config where

441+instance HasServer api context => HasServer (Vault :> api) context where

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

443443

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

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

444+ route Proxy context subserver = WithRequest $ \req ->

445+ route (Proxy :: Proxy api) context (passToServer subserver $ vault req)

446446

447−instance HasServer api config => HasServer (HttpVersion :> api) config where

447+instance HasServer api context => HasServer (HttpVersion :> api) context where

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

449449

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

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

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

451+ route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)

452452

453453pathIsEmpty :: Request -> Bool

454454pathIsEmpty = go . pathInfo

@@ -459,19 +459,19 @@ pathIsEmpty = go . pathInfo

459459ct_wildcard :: B.ByteString

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

461461

462−-- * configs

462+-- * contexts

463463

464−instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig)

465− => HasServer (WithNamedConfig name subConfig subApi) config where

464+instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)

465+ => HasServer (WithNamedContext name subContext subApi) context where

466466

467− type ServerT (WithNamedConfig name subConfig subApi) m =

467+ type ServerT (WithNamedContext name subContext subApi) m =

468468 ServerT subApi m

469469

470− route Proxy config delayed =

471− route subProxy subConfig delayed

470+ route Proxy context delayed =

471+ route subProxy subContext delayed

472472 where

473473 subProxy :: Proxy subApi

474474 subProxy = Proxy

475475

476− subConfig :: Config subConfig

477− subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

476+ subContext :: Context subContext

477+ subContext = descendIntoNamedContext (Proxy :: Proxy name) context

servant-server/src/Servant/Server/Internal/Config.hsdeleted−99

@@ -1,99 +0,0 @@

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−-- | When calling 'Servant.Server.serve' you have to supply a configuration

19−-- value of type @'Config' configTypes@. This parameter is used to pass values

20−-- to combinators. (It shouldn't be confused with general configuration

21−-- parameters for your web app, like the port, etc.). If you don't use

22−-- combinators that require any config entries, you can just pass 'EmptyConfig'.

23−-- To create a config with entries, use the operator @(':.')@. The parameter of

24−-- the type 'Config' is a type-level list reflecting the types of the contained

25−-- config entries:

26−--

27−-- >>> :type True :. () :. EmptyConfig

28−-- True :. () :. EmptyConfig :: Config '[Bool, ()]

29−data Config configTypes where

30− EmptyConfig :: Config '[]

31− (:.) :: x -> Config xs -> Config (x ': xs)

32−infixr 5 :.

33−

34−instance Show (Config '[]) where

35− show EmptyConfig = "EmptyConfig"

36−instance (Show a, Show (Config as)) => Show (Config (a ': as)) where

37− showsPrec outerPrecedence (a :. as) =

38− showParen (outerPrecedence > 5) $

39− shows a . showString " :. " . shows as

40−

41−instance Eq (Config '[]) where

42− _ == _ = True

43−instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where

44− x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

45−

46−-- | This class is used to access config entries in 'Config's. 'getConfigEntry'

47−-- returns the first value where the type matches:

48−--

49−-- >>> getConfigEntry (True :. False :. EmptyConfig) :: Bool

50−-- True

51−--

52−-- If the 'Config' does not contain an entry of the requested type, you'll get

53−-- an error:

54−--

55−-- >>> getConfigEntry (True :. False :. EmptyConfig) :: String

56−-- ...

57−-- No instance for (HasConfigEntry '[] [Char])

58−-- ...

59−class HasConfigEntry (config :: [*]) (val :: *) where

60− getConfigEntry :: Config config -> val

61−

62−instance OVERLAPPABLE_

63− HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where

64− getConfigEntry (_ :. xs) = getConfigEntry xs

65−

66−instance OVERLAPPING_

67− HasConfigEntry (val ': xs) val where

68− getConfigEntry (x :. _) = x

69−

70−-- * support for named subconfigs

71−

72−-- | Normally config entries are accessed by their types. In case you need

73−-- to have multiple values of the same type in your 'Config' and need to access

74−-- them, we provide 'NamedConfig'. You can think of it as sub-namespaces for

75−-- 'Config's.

76−data NamedConfig (name :: Symbol) (subConfig :: [*])

77− = NamedConfig (Config subConfig)

78−

79−-- | 'descendIntoNamedConfig' allows you to access `NamedConfig's. Usually you

80−-- won't have to use it yourself but instead use a combinator like

81−-- 'Servant.API.WithNamedConfig.WithNamedConfig'.

82−--

83−-- This is how 'descendIntoNamedConfig' works:

84−--

85−-- >>> :set -XFlexibleContexts

86−-- >>> let subConfig = True :. EmptyConfig

87−-- >>> :type subConfig

88−-- subConfig :: Config '[Bool]

89−-- >>> let parentConfig = False :. (NamedConfig subConfig :: NamedConfig "subConfig" '[Bool]) :. EmptyConfig

90−-- >>> :type parentConfig

91−-- parentConfig :: Config '[Bool, NamedConfig "subConfig" '[Bool]]

92−-- >>> descendIntoNamedConfig (Proxy :: Proxy "subConfig") parentConfig :: Config '[Bool]

93−-- True :. EmptyConfig

94−descendIntoNamedConfig :: forall config name subConfig .

95− HasConfigEntry config (NamedConfig name subConfig) =>

96− Proxy (name :: Symbol) -> Config config -> Config subConfig

97−descendIntoNamedConfig Proxy config =

98− let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig

99− in subConfig

servant-server/src/Servant/Server/Internal/Context.hsnew file+99

@@ -0,0 +1,99 @@

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.Context where

14+

15+import Data.Proxy

16+import GHC.TypeLits

17+

18+-- | When calling 'Servant.Server.serve' you have to supply a context

19+-- value of type @'Context' contextTypes@. This parameter is used to pass values

20+-- to combinators. (It shouldn't be confused with general configuration

21+-- parameters for your web app, like the port, etc.). If you don't use

22+-- combinators that require any context entries, you can just use `serve` (or

23+-- pass 'EmptyContext'). To create a context with entries, use the operator

24+-- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting

25+-- the types of the contained context entries:

26+--

27+-- >>> :type True :. () :. EmptyContext

28+-- True :. () :. EmptyContext :: Context '[Bool, ()]

29+data Context contextTypes where

30+ EmptyContext :: Context '[]

31+ (:.) :: x -> Context xs -> Context (x ': xs)

32+infixr 5 :.

33+

34+instance Show (Context '[]) where

35+ show EmptyContext = "EmptyContext"

36+instance (Show a, Show (Context as)) => Show (Context (a ': as)) where

37+ showsPrec outerPrecedence (a :. as) =

38+ showParen (outerPrecedence > 5) $

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

40+

41+instance Eq (Context '[]) where

42+ _ == _ = True

43+instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

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

45+

46+-- | This class is used to access context entries in 'Context's. 'getContextEntry'

47+-- returns the first value where the type matches:

48+--

49+-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool

50+-- True

51+--

52+-- If the 'Context' does not contain an entry of the requested type, you'll get

53+-- an error:

54+--

55+-- >>> getContextEntry (True :. False :. EmptyContext) :: String

56+-- ...

57+-- No instance for (HasContextEntry '[] [Char])

58+-- ...

59+class HasContextEntry (context :: [*]) (val :: *) where

60+ getContextEntry :: Context context -> val

61+

62+instance OVERLAPPABLE_

63+ HasContextEntry xs val => HasContextEntry (notIt ': xs) val where

64+ getContextEntry (_ :. xs) = getContextEntry xs

65+

66+instance OVERLAPPING_

67+ HasContextEntry (val ': xs) val where

68+ getContextEntry (x :. _) = x

69+

70+-- * support for named subcontexts

71+

72+-- | Normally context entries are accessed by their types. In case you need

73+-- to have multiple values of the same type in your 'Context' and need to access

74+-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for

75+-- 'Context's.

76+data NamedContext (name :: Symbol) (subContext :: [*])

77+ = NamedContext (Context subContext)

78+

79+-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you

80+-- won't have to use it yourself but instead use a combinator like

81+-- 'Servant.API.WithNamedContext.WithNamedContext'.

82+--

83+-- This is how 'descendIntoNamedContext' works:

84+--

85+-- >>> :set -XFlexibleContexts

86+-- >>> let subContext = True :. EmptyContext

87+-- >>> :type subContext

88+-- subContext :: Context '[Bool]

89+-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext

90+-- >>> :type parentContext

91+-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]]

92+-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool]

93+-- True :. EmptyContext

94+descendIntoNamedContext :: forall context name subContext .

95+ HasContextEntry context (NamedContext name subContext) =>

96+ Proxy (name :: Symbol) -> Context context -> Context subContext

97+descendIntoNamedContext Proxy context =

98+ let NamedContext subContext = getContextEntry context :: NamedContext name subContext

99+ in subContext

servant-server/test/Servant/Server/Internal/ConfigSpec.hsdeleted−61

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

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/ContextSpec.hsnew file+61

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

1+{-# LANGUAGE DataKinds #-}

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

3+module Servant.Server.Internal.ContextSpec (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.Context

11+

12+spec :: Spec

13+spec = do

14+ describe "getContextEntry" $ do

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

16+ let cxt = 'a' :. EmptyContext

17+ getContextEntry cxt `shouldBe` 'a'

18+

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

20+ let cxt = 'a' :. 'b' :. EmptyContext

21+ getContextEntry cxt `shouldBe` 'a'

22+

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

24+ let cxt = 'a' :. EmptyContext

25+ x = getContextEntry cxt :: Bool

26+ shouldNotTypecheck x

27+

28+ context "Show instance" $ do

29+ let cxt = 'a' :. True :. EmptyContext

30+ it "has a Show instance" $ do

31+ show cxt `shouldBe` "'a' :. True :. EmptyContext"

32+

33+ context "bracketing" $ do

34+ it "works" $ do

35+ show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"

36+

37+ it "works with operators" $ do

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

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

40+

41+ describe "descendIntoNamedContext" $ do

42+ let cxt :: Context [Char, NamedContext "sub" '[Char]]

43+ cxt =

44+ 'a' :.

45+ (NamedContext subContext :: NamedContext "sub" '[Char])

46+ :. EmptyContext

47+ subContext = 'b' :. EmptyContext

48+ it "allows extracting subcontexts" $ do

49+ descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext

50+

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

52+ getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char])

53+ `shouldBe` 'b'

54+

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

56+ let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int]

57+ shouldNotTypecheck (show x)

58+

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

60+ let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char]

61+ shouldNotTypecheck (show x)

servant-server/test/Servant/Server/UsingConfigSpec.hsdeleted−125

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

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− serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−

12−-- | These are custom combinators for Servant.Server.UsingConfigSpec.

13−--

14−-- (For writing your own combinators you need to import Internal modules, for

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

16−-- separate from Servant.Server.UsingConfigSpec to test that the module imports

17−-- work out this way.)

18−module Servant.Server.UsingConfigSpec.TestCombinators where

19−

20−import GHC.TypeLits

21−

22−import Servant

23−import Servant.Server.Internal.Config

24−import Servant.Server.Internal.RoutingApplication

25−

26−data ExtractFromConfig

27−

28−instance (HasConfigEntry config String, HasServer subApi config) =>

29− HasServer (ExtractFromConfig :> subApi) config where

30−

31− type ServerT (ExtractFromConfig :> subApi) m =

32− String -> ServerT subApi m

33−

34− route Proxy config delayed =

35− route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))

36− where

37− subProxy :: Proxy subApi

38− subProxy = Proxy

39−

40− inject config f = f (getConfigEntry config)

41−

42−data InjectIntoConfig

43−

44−instance (HasServer subApi (String ': config)) =>

45− HasServer (InjectIntoConfig :> subApi) config where

46−

47− type ServerT (InjectIntoConfig :> subApi) m =

48− ServerT subApi m

49−

50− route Proxy config delayed =

51− route subProxy newConfig delayed

52− where

53− subProxy :: Proxy subApi

54− subProxy = Proxy

55−

56− newConfig = ("injected" :: String) :. config

57−

58−data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])

59−

60−instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) =>

61− HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where

62−

63− type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =

64− ServerT subApi m

65−

66− route Proxy config delayed =

67− route subProxy subConfig delayed

68− where

69− subProxy :: Proxy subApi

70− subProxy = Proxy

71−

72− subConfig :: Config subConfig

73− subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

6+module Servant.Server.UsingContextSpec 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.UsingContextSpec.TestCombinators

15+

16+spec :: Spec

17+spec = do

18+ spec1

19+ spec2

20+ spec3

21+ spec4

22+

23+-- * API

24+

25+type OneEntryAPI =

26+ ExtractFromContext :> Get '[JSON] String

27+

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

29+testServer s = return s

30+

31+oneEntryApp :: Application

32+oneEntryApp =

33+ serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer

34+ where

35+ context :: Context '[String]

36+ context = "contextEntry" :. EmptyContext

37+

38+type OneEntryTwiceAPI =

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

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

41+

42+oneEntryTwiceApp :: Application

43+oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $

44+ testServer :<|>

45+ testServer

46+ where

47+ context :: Context '[String]

48+ context = "contextEntryTwice" :. EmptyContext

49+

50+-- * tests

51+

52+spec1 :: Spec

53+spec1 = do

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

55+ with (return oneEntryApp) $ do

56+ it "allows retrieving a ContextEntry" $ do

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

58+

59+ with (return oneEntryTwiceApp) $ do

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

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

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

63+

64+type InjectAPI =

65+ InjectIntoContext :> "untagged" :> ExtractFromContext :>

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

67+ InjectIntoContext :> "tagged" :> ExtractFromContext :>

68+ Get '[JSON] String

69+

70+injectApp :: Application

71+injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $

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

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

74+ where

75+ context = EmptyContext

76+

77+spec2 :: Spec

78+spec2 = do

79+ with (return injectApp) $ do

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

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

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

83+

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

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

86+

87+type WithBirdfaceAPI =

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

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

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

91+

92+withBirdfaceApp :: Application

93+withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $

94+ testServer :<|>

95+ testServer

96+ where

97+ context :: Context '[String, (NamedContext "sub" '[String])]

98+ context =

99+ "firstEntry" :.

100+ (NamedContext ("secondEntry" :. EmptyContext)) :.

101+ EmptyContext

102+

103+spec3 :: Spec

104+spec3 = do

105+ with (return withBirdfaceApp) $ do

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

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

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

109+

110+type NamedContextAPI =

111+ WithNamedContext "sub" '[String] (

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

113+

114+namedContextApp :: Application

115+namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return

116+ where

117+ context :: Context '[NamedContext "sub" '[String]]

118+ context = NamedContext ("descend" :. EmptyContext) :. EmptyContext

119+

120+spec4 :: Spec

121+spec4 = do

122+ with (return namedContextApp) $ do

123+ describe "WithNamedContext" $ do

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

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

servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hsnew file+72

@@ -0,0 +1,72 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+-- | These are custom combinators for Servant.Server.UsingContextSpec.

13+--

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

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

16+-- separate from Servant.Server.UsingContextSpec to test that the module imports

17+-- work out this way.)

18+module Servant.Server.UsingContextSpec.TestCombinators where

19+

20+import GHC.TypeLits

21+

22+import Servant

23+import Servant.Server.Internal.RoutingApplication

24+

25+data ExtractFromContext

26+

27+instance (HasContextEntry context String, HasServer subApi context) =>

28+ HasServer (ExtractFromContext :> subApi) context where

29+

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

31+ String -> ServerT subApi m

32+

33+ route Proxy context delayed =

34+ route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))

35+ where

36+ subProxy :: Proxy subApi

37+ subProxy = Proxy

38+

39+ inject context f = f (getContextEntry context)

40+

41+data InjectIntoContext

42+

43+instance (HasServer subApi (String ': context)) =>

44+ HasServer (InjectIntoContext :> subApi) context where

45+

46+ type ServerT (InjectIntoContext :> subApi) m =

47+ ServerT subApi m

48+

49+ route Proxy context delayed =

50+ route subProxy newContext delayed

51+ where

52+ subProxy :: Proxy subApi

53+ subProxy = Proxy

54+

55+ newContext = ("injected" :: String) :. context

56+

57+data NamedContextWithBirdface (name :: Symbol) (subContext :: [*])

58+

59+instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) =>

60+ HasServer (NamedContextWithBirdface name subContext :> subApi) context where

61+

62+ type ServerT (NamedContextWithBirdface name subContext :> subApi) m =

63+ ServerT subApi m

64+

65+ route Proxy context delayed =

66+ route subProxy subContext delayed

67+ where

68+ subProxy :: Proxy subApi

69+ subProxy = Proxy

70+

71+ subContext :: Context subContext

72+ subContext = descendIntoNamedContext (Proxy :: Proxy name) context

servant-server/test/Servant/ServerSpec.hs+6−6

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

4949 StdMethod (..), Verb, addHeader)

5050import Servant.API.Internal.Test.ComprehensiveAPI

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

52− serve, serveWithConfig, Config(EmptyConfig))

52+ serve, serveWithContext, Context(EmptyContext))

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

5454 shouldBe, shouldContain)

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

@@ -61,16 +61,16 @@ import Servant.Server.Internal.RoutingApplication

6161import Servant.Server.Internal.Router

6262 (tweakResponse, runRouter,

6363 Router, Router'(LeafRouter))

64−import Servant.Server.Internal.Config

65− (Config(..), NamedConfig(..))

64+import Servant.Server.Internal.Context

65+ (Context(..), NamedContext(..))

6666

6767-- * comprehensive api test

6868

6969-- This declaration simply checks that all instances are in place.

70−_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig

70+_ = serveWithContext comprehensiveAPI comprehensiveApiContext

7171

72−comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]]

73−comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig

72+comprehensiveApiContext :: Context '[NamedContext "foo" '[]]

73+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

7474

7575-- * Specs

7676

servant/servant.cabal+1−1

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

4141 Servant.API.Sub

4242 Servant.API.Vault

4343 Servant.API.Verbs

44− Servant.API.WithNamedConfig

44+ Servant.API.WithNamedContext

4545 Servant.Utils.Links

4646 build-depends:

4747 base >=4.7 && <5

servant/src/Servant/API.hs+3−3

@@ -23,8 +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

26+ module Servant.API.WithNamedContext,

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

2828

2929 -- * Actual endpoints, distinguished by HTTP method

3030 module Servant.API.Verbs,

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

9090 PutNoContent, PutNonAuthoritative,

9191 ReflectMethod (reflectMethod),

9292 Verb, StdMethod(..))

93−import Servant.API.WithNamedConfig (WithNamedConfig)

93+import Servant.API.WithNamedContext (WithNamedContext)

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

9595 URI (..), safeLink)

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

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+1−1

@@ -30,7 +30,7 @@ type ComprehensiveAPI =

3030 Vault :> GET :<|>

3131 Verb 'POST 204 '[JSON] () :<|>

3232 Verb 'POST 204 '[JSON] Int :<|>

33− WithNamedConfig "foo" '[] GET

33+ WithNamedContext "foo" '[] GET

3434

3535comprehensiveAPI :: Proxy ComprehensiveAPI

3636comprehensiveAPI = Proxy

servant/src/Servant/API/WithNamedConfig.hsdeleted−21

@@ -1,21 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE KindSignatures #-}

3−

4−module Servant.API.WithNamedConfig where

5−

6−import GHC.TypeLits

7−

8−-- | 'WithNamedConfig' names a specific tagged configuration to use for the

9−-- combinators in the API. (See also in @servant-server@,

10−-- @Servant.Server.Config@.) For example:

11−--

12−-- > type UseNamedConfigAPI = WithNamedConfig "myConfig" '[String] (

13−-- > ReqBody '[JSON] Int :> Get '[JSON] Int)

14−--

15−-- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with

16−-- type tag "myConfig" as their configuration.

17−--

18−-- 'Config's are only relevant for @servant-server@.

19−--

20−-- For more information, see the tutorial.

21−data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi

servant/src/Servant/API/WithNamedContext.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

4+module Servant.API.WithNamedContext where

6+import GHC.TypeLits

8+-- | 'WithNamedContext' names a specific tagged context to use for the

9+-- combinators in the API. (See also in @servant-server@,

10+-- @Servant.Server.Context@.) For example:

11+--

12+-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] (

13+-- > ReqBody '[JSON] Int :> Get '[JSON] Int)

14+--

15+-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with

16+-- type tag "myContext" as their context.

17+--

18+-- 'Context's are only relevant for @servant-server@.

19+--

20+-- For more information, see the tutorial.

21+data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi