git.iko.soy/typeable/servant
on master help sign in
config: remove HasConfig and make HasServer take `config` as a parameter
df09f86Sönke Hahn
servant-client/test/Servant/ClientSpec.hs+2−3
compare with master
unifiedsplit
@@ -288,9 +288,8 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
288 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
288 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
289
289
290data WrappedApi where
290data WrappedApi where
291− WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
291+ WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
292− , HasConfig api '[], HasClient api
293− , Client api ~ ExceptT ServantError IO ()) =>
292+ HasClient api, Client api ~ ExceptT ServantError IO ()) =>
294 Proxy api -> WrappedApi
293 Proxy api -> WrappedApi
295
294
296
295
servant-examples/auth-combinator/auth-combinator.hs+6−3
@@ -1,10 +1,13 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
8
11
9import Data.Aeson
12import Data.Aeson
10import Data.ByteString (ByteString)
13import Data.ByteString (ByteString)
@@ -32,10 +35,10 @@ isGoodCookie ref password = do
32
35
33data AuthProtected
36data AuthProtected
34
37
38+instance (HasConfigEntry config DBConnection, HasServer rest config)
35−instance HasServer rest => HasServer (AuthProtected :> rest) where
39+ => HasServer (AuthProtected :> rest) config where
40+
36 type ServerT (AuthProtected :> rest) m = ServerT rest m
41 type ServerT (AuthProtected :> rest) m = ServerT rest m
37− type HasConfig (AuthProtected :> rest) config =
38− (HasConfigEntry config DBConnection, HasConfig rest config)
39
42
40 route Proxy config subserver = WithRequest $ \ request ->
43 route Proxy config subserver = WithRequest $ \ request ->
41 route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
44 route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
servant-mock/example/main.hs+1−1
@@ -20,4 +20,4 @@ api :: Proxy API
20api = Proxy
20api = Proxy
21
21
22main :: IO ()
22main :: IO ()
23−main = run 8080 (serve api EmptyConfig $ mock api)
23+main = run 8080 (serve api EmptyConfig $ mock api Proxy)
servant-mock/src/Servant/Mock.hs+40−36
@@ -2,8 +2,9 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
9{-# OPTIONS_GHC -fno-warn-orphans #-}
10{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -66,6 +67,7 @@ import Network.HTTP.Types.Status
66import Network.Wai
67import Network.Wai
67import Servant
68import Servant
68import Servant.API.ContentTypes
69import Servant.API.ContentTypes
70+import Servant.Server.Internal.Config
69import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
71import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
70import Test.QuickCheck.Gen (Gen, generate)
72import Test.QuickCheck.Gen (Gen, generate)
71
73
@@ -73,7 +75,7 @@ import Test.QuickCheck.Gen (Gen, generate)
73-- than turns them into random-response-generating
75-- than turns them into random-response-generating
74-- request handlers, hence providing an instance for
76-- request handlers, hence providing an instance for
75-- all the combinators of the core /servant/ library.
77-- all the combinators of the core /servant/ library.
76−class HasServer api => HasMock api where
78+class HasServer api config => HasMock api config where
77 -- | Calling this method creates request handlers of
79 -- | Calling this method creates request handlers of
78 -- the right type to implement the API described by
80 -- the right type to implement the API described by
79 -- @api@ that just generate random response values of
81 -- @api@ that just generate random response values of
@@ -103,65 +105,67 @@ class HasServer api => HasMock api where
103 -- So under the hood, 'mock' uses the 'IO' bit to generate
105 -- So under the hood, 'mock' uses the 'IO' bit to generate
104 -- random values of type 'User' and 'Book' every time these
106 -- random values of type 'User' and 'Book' every time these
105 -- endpoints are requested.
107 -- endpoints are requested.
106− mock :: Proxy api -> Server api
108+ mock :: Proxy api -> Proxy config -> Server api
107
109
108−instance (HasMock a, HasMock b) => HasMock (a :<|> b) where
110+instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where
109− mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b)
111+ mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config
110
112
111−instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where
113+instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where
112 mock _ = mock (Proxy :: Proxy rest)
114 mock _ = mock (Proxy :: Proxy rest)
113
115
114−instance (KnownSymbol s, FromHttpApiData a, HasMock rest) => HasMock (Capture s a :> rest) where
116+instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where
115− mock _ = \_ -> mock (Proxy :: Proxy rest)
117+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
116
118
117−instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where
119+instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where
118− mock _ = \_ -> mock (Proxy :: Proxy rest)
120+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
119
121
120−instance HasMock rest => HasMock (RemoteHost :> rest) where
122+instance HasMock rest config => HasMock (RemoteHost :> rest) config where
121− mock _ = \_ -> mock (Proxy :: Proxy rest)
123+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
122
124
123−instance HasMock rest => HasMock (IsSecure :> rest) where
125+instance HasMock rest config => HasMock (IsSecure :> rest) config where
124− mock _ = \_ -> mock (Proxy :: Proxy rest)
126+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
125
127
126−instance HasMock rest => HasMock (Vault :> rest) where
128+instance HasMock rest config => HasMock (Vault :> rest) config where
127− mock _ = \_ -> mock (Proxy :: Proxy rest)
129+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
128
130
129−instance HasMock rest => HasMock (HttpVersion :> rest) where
131+instance HasMock rest config => HasMock (HttpVersion :> rest) config where
130− mock _ = \_ -> mock (Proxy :: Proxy rest)
132+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
131
133
132−instance (KnownSymbol s, FromHttpApiData a, HasMock rest)
134+instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
133− => HasMock (QueryParam s a :> rest) where
135+ => HasMock (QueryParam s a :> rest) config where
134− mock _ = \_ -> mock (Proxy :: Proxy rest)
136+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
135
137
136−instance (KnownSymbol s, FromHttpApiData a, HasMock rest)
138+instance (KnownSymbol s, FromHttpApiData a, HasMock rest config)
137− => HasMock (QueryParams s a :> rest) where
139+ => HasMock (QueryParams s a :> rest) config where
138− mock _ = \_ -> mock (Proxy :: Proxy rest)
140+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
139
141
140−instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
142+instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where
141− mock _ = \_ -> mock (Proxy :: Proxy rest)
143+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
142
144
143−instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where
145+instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where
144− mock _ = \_ -> mock (Proxy :: Proxy rest)
146+ mock _ config = \_ -> mock (Proxy :: Proxy rest) config
145
147
146instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
148instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
147− => HasMock (Verb method status ctypes a) where
149+ => HasMock (Verb method status ctypes a) config where
148− mock _ = mockArbitrary
150+ mock _ _ = mockArbitrary
149
151
150instance OVERLAPPING_
152instance OVERLAPPING_
151 (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
153 (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
152 Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
154 Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
153− => HasMock (Verb method status ctypes (Headers headerTypes a)) where
155+ => HasMock (Verb method status ctypes (Headers headerTypes a)) config where
154− mock _ = mockArbitrary
156+ mock _ _ = mockArbitrary
155
157
156−instance HasMock Raw where
158+instance HasMock Raw config where
157− mock _ = \_req respond -> do
159+ mock _ _ = \_req respond -> do
158 bdy <- genBody
160 bdy <- genBody
159 respond $ responseLBS status200 [] bdy
161 respond $ responseLBS status200 [] bdy
160
162
161 where genBody = pack <$> generate (vector 100 :: Gen [Char])
163 where genBody = pack <$> generate (vector 100 :: Gen [Char])
162
164
165+instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) =>
163−instance HasMock rest => HasMock (WithNamedConfig name config rest) where
166+ HasMock (WithNamedConfig name subConfig rest) config where
167+
164− mock _ = mock (Proxy :: Proxy rest)
168+ mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig)
165
169
166mockArbitrary :: (MonadIO m, Arbitrary a) => m a
170mockArbitrary :: (MonadIO m, Arbitrary a) => m a
167mockArbitrary = liftIO (generate arbitrary)
171mockArbitrary = liftIO (generate arbitrary)
servant-mock/test/Servant/MockSpec.hs+6−4
@@ -1,5 +1,7 @@
1+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
5
7
@@ -21,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI
21import Servant.Mock
23import Servant.Mock
22
24
23-- This declaration simply checks that all instances are in place.
25-- This declaration simply checks that all instances are in place.
24−_ = mock comprehensiveAPI
26+_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]])
25
27
26data Body
28data Body
27 = Body
29 = Body
@@ -50,7 +52,7 @@ spec = do
50 context "Get" $ do
52 context "Get" $ do
51 let api :: Proxy (Get '[JSON] Body)
53 let api :: Proxy (Get '[JSON] Body)
52 api = Proxy
54 api = Proxy
53− app = serve api (mock api)
55+ app = serve api EmptyConfig (mock api Proxy)
54 with (return app) $ do
56 with (return app) $ do
55 it "serves arbitrary response bodies" $ do
57 it "serves arbitrary response bodies" $ do
56 get "/" `shouldRespondWith` 200{
58 get "/" `shouldRespondWith` 200{
@@ -62,8 +64,8 @@ spec = do
62 withHeader = Proxy
64 withHeader = Proxy
63 withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
65 withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
64 withoutHeader = Proxy
66 withoutHeader = Proxy
65− toApp :: HasMock api => Proxy api -> IO Application
67+ toApp :: (HasMock api '[]) => Proxy api -> IO Application
66− toApp api = return $ serve api (mock api)
68+ toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[]))
67 with (toApp withHeader) $ do
69 with (toApp withHeader) $ do
68 it "serves arbitrary response bodies" $ do
70 it "serves arbitrary response bodies" $ do
69 get "/" `shouldRespondWith` 200{
71 get "/" `shouldRespondWith` 200{
servant-server/src/Servant/Server.hs+2−2
@@ -110,8 +110,8 @@ import Servant.Server.Internal.Enter
110-- > main :: IO ()
110-- > main :: IO ()
111-- > main = Network.Wai.Handler.Warp.run 8080 app
111-- > main = Network.Wai.Handler.Warp.run 8080 app
112--
112--
113−serve :: (HasConfig layout a, HasServer layout)
113+serve :: (HasServer layout config)
114− => Proxy layout -> Config a -> Server layout -> Application
114+ => Proxy layout -> Config config -> Server layout -> Application
115serve p config server = toApplication (runRouter (route p config d))
115serve p config server = toApplication (runRouter (route p config d))
116 where
116 where
117 d = Delayed r r r (\ _ _ -> Route server)
117 d = Delayed r r r (\ _ _ -> Route server)
servant-server/src/Servant/Server/Internal.hs+27−42
@@ -4,6 +4,7 @@
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
@@ -68,11 +69,10 @@ import Servant.Server.Internal.RoutingApplication
68import Servant.Server.Internal.ServantErr
69import Servant.Server.Internal.ServantErr
69
70
70
71
71−class HasServer layout where
72+class HasServer layout config where
72 type ServerT layout (m :: * -> *) :: *
73 type ServerT layout (m :: * -> *) :: *
73− type HasConfig layout (c :: [*]) :: Constraint
74
74
75− route :: HasConfig layout config => Proxy layout -> Config config -> Delayed (Server layout) -> Router
75+ route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router
76
76
77type Server layout = ServerT layout (ExceptT ServantErr IO)
77type Server layout = ServerT layout (ExceptT ServantErr IO)
78
78
@@ -89,10 +89,9 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
89-- > server = listAllBooks :<|> postBook
89-- > server = listAllBooks :<|> postBook
90-- > where listAllBooks = ...
90-- > where listAllBooks = ...
91-- > postBook book = ...
91-- > postBook book = ...
92−instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
92+instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where
93
93
94 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)
96
95
97 route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
96 route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
98 (route pb config ((\ (_ :<|> b) -> b) <$> server))
97 (route pb config ((\ (_ :<|> b) -> b) <$> server))
@@ -119,12 +118,11 @@ captured _ = parseUrlPieceMaybe
119-- > server = getBook
118-- > server = getBook
120-- > where getBook :: Text -> ExceptT ServantErr IO Book
119-- > where getBook :: Text -> ExceptT ServantErr IO Book
121-- > getBook isbn = ...
120-- > getBook isbn = ...
122−instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
121+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config)
123− => HasServer (Capture capture a :> sublayout) where
122+ => HasServer (Capture capture a :> sublayout) config where
124
123
125 type ServerT (Capture capture a :> sublayout) m =
124 type ServerT (Capture capture a :> sublayout) m =
126 a -> ServerT sublayout m
125 a -> ServerT sublayout m
127− type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
128
126
129 route Proxy config d =
127 route Proxy config d =
130 DynamicRouter $ \ first ->
128 DynamicRouter $ \ first ->
@@ -198,10 +196,9 @@ methodRouterHeaders method proxy status action = LeafRouter route'
198
196
199instance OVERLAPPABLE_
197instance OVERLAPPABLE_
200 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
198 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
201− ) => HasServer (Verb method status ctypes a) where
199+ ) => HasServer (Verb method status ctypes a) config where
202
200
203 type ServerT (Verb method status ctypes a) m = m a
201 type ServerT (Verb method status ctypes a) m = m a
204− type HasConfig (Verb method status ctypes a) c = ()
205
202
206 route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
203 route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
207 where method = reflectMethod (Proxy :: Proxy method)
204 where method = reflectMethod (Proxy :: Proxy method)
@@ -210,10 +207,9 @@ instance OVERLAPPABLE_
210instance OVERLAPPING_
207instance OVERLAPPING_
211 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
208 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
212 , GetHeaders (Headers h a)
209 , GetHeaders (Headers h a)
213− ) => HasServer (Verb method status ctypes (Headers h a)) where
210+ ) => HasServer (Verb method status ctypes (Headers h a)) config where
214
211
215 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
212 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 = ()
217
213
218 route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
214 route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
219 where method = reflectMethod (Proxy :: Proxy method)
215 where method = reflectMethod (Proxy :: Proxy method)
@@ -239,12 +235,11 @@ instance OVERLAPPING_
239-- > server = viewReferer
235-- > server = viewReferer
240-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
236-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
241-- > viewReferer referer = return referer
237-- > viewReferer referer = return referer
242−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
238+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
243− => HasServer (Header sym a :> sublayout) where
239+ => HasServer (Header sym a :> sublayout) config where
244
240
245 type ServerT (Header sym a :> sublayout) m =
241 type ServerT (Header sym a :> sublayout) m =
246 Maybe a -> ServerT sublayout m
242 Maybe a -> ServerT sublayout m
247− type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
248
243
249 route Proxy config subserver = WithRequest $ \ request ->
244 route Proxy config subserver = WithRequest $ \ request ->
250 let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
245 let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
@@ -272,12 +267,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
272-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
267-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
273-- > getBooksBy Nothing = ...return all books...
268-- > getBooksBy Nothing = ...return all books...
274-- > getBooksBy (Just author) = ...return books by the given author...
269-- > getBooksBy (Just author) = ...return books by the given author...
275−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
270+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
276− => HasServer (QueryParam sym a :> sublayout) where
271+ => HasServer (QueryParam sym a :> sublayout) config where
277
272
278 type ServerT (QueryParam sym a :> sublayout) m =
273 type ServerT (QueryParam sym a :> sublayout) m =
279 Maybe a -> ServerT sublayout m
274 Maybe a -> ServerT sublayout m
280− type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
281
275
282 route Proxy config subserver = WithRequest $ \ request ->
276 route Proxy config subserver = WithRequest $ \ request ->
283 let querytext = parseQueryText $ rawQueryString request
277 let querytext = parseQueryText $ rawQueryString request
@@ -309,12 +303,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
309-- > server = getBooksBy
303-- > server = getBooksBy
310-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
304-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
311-- > getBooksBy authors = ...return all books by these authors...
305-- > getBooksBy authors = ...return all books by these authors...
312−instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
306+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config)
313− => HasServer (QueryParams sym a :> sublayout) where
307+ => HasServer (QueryParams sym a :> sublayout) config where
314
308
315 type ServerT (QueryParams sym a :> sublayout) m =
309 type ServerT (QueryParams sym a :> sublayout) m =
316 [a] -> ServerT sublayout m
310 [a] -> ServerT sublayout m
317− type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
318
311
319 route Proxy config subserver = WithRequest $ \ request ->
312 route Proxy config subserver = WithRequest $ \ request ->
320 let querytext = parseQueryText $ rawQueryString request
313 let querytext = parseQueryText $ rawQueryString request
@@ -341,12 +334,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
341-- > server = getBooks
334-- > server = getBooks
342-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
335-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
343-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
336-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
344−instance (KnownSymbol sym, HasServer sublayout)
337+instance (KnownSymbol sym, HasServer sublayout config)
345− => HasServer (QueryFlag sym :> sublayout) where
338+ => HasServer (QueryFlag sym :> sublayout) config where
346
339
347 type ServerT (QueryFlag sym :> sublayout) m =
340 type ServerT (QueryFlag sym :> sublayout) m =
348 Bool -> ServerT sublayout m
341 Bool -> ServerT sublayout m
349− type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
350
342
351 route Proxy config subserver = WithRequest $ \ request ->
343 route Proxy config subserver = WithRequest $ \ request ->
352 let querytext = parseQueryText $ rawQueryString request
344 let querytext = parseQueryText $ rawQueryString request
@@ -367,10 +359,9 @@ instance (KnownSymbol sym, HasServer sublayout)
367-- >
359-- >
368-- > server :: Server MyApi
360-- > server :: Server MyApi
369-- > server = serveDirectory "/var/www/images"
361-- > server = serveDirectory "/var/www/images"
370−instance HasServer Raw where
362+instance HasServer Raw config where
371
363
372 type ServerT Raw m = Application
364 type ServerT Raw m = Application
373− type HasConfig Raw c = ()
374
365
375 route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
366 route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
376 r <- runDelayed rawApplication
367 r <- runDelayed rawApplication
@@ -400,12 +391,11 @@ instance HasServer Raw where
400-- > server = postBook
391-- > server = postBook
401-- > where postBook :: Book -> ExceptT ServantErr IO Book
392-- > where postBook :: Book -> ExceptT ServantErr IO Book
402-- > postBook book = ...insert into your db...
393-- > postBook book = ...insert into your db...
403−instance ( AllCTUnrender list a, HasServer sublayout
394+instance ( AllCTUnrender list a, HasServer sublayout config
404− ) => HasServer (ReqBody list a :> sublayout) where
395+ ) => HasServer (ReqBody list a :> sublayout) config where
405
396
406 type ServerT (ReqBody list a :> sublayout) m =
397 type ServerT (ReqBody list a :> sublayout) m =
407 a -> ServerT sublayout m
398 a -> ServerT sublayout m
408− type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
409
399
410 route Proxy config subserver = WithRequest $ \ request ->
400 route Proxy config subserver = WithRequest $ \ request ->
411 route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
401 route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
@@ -426,42 +416,37 @@ instance ( AllCTUnrender list a, HasServer sublayout
426
416
427-- | Make sure the incoming request starts with @"/path"@, strip it and
417-- | Make sure the incoming request starts with @"/path"@, strip it and
428-- pass the rest of the request path to @sublayout@.
418-- pass the rest of the request path to @sublayout@.
429−instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
419+instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where
430
420
431 type ServerT (path :> sublayout) m = ServerT sublayout m
421 type ServerT (path :> sublayout) m = ServerT sublayout m
432− type HasConfig (path :> sublayout) c = HasConfig sublayout c
433
422
434 route Proxy config subserver = StaticRouter $
423 route Proxy config subserver = StaticRouter $
435 M.singleton (cs (symbolVal proxyPath))
424 M.singleton (cs (symbolVal proxyPath))
436 (route (Proxy :: Proxy sublayout) config subserver)
425 (route (Proxy :: Proxy sublayout) config subserver)
437 where proxyPath = Proxy :: Proxy path
426 where proxyPath = Proxy :: Proxy path
438
427
439−instance HasServer api => HasServer (RemoteHost :> api) where
428+instance HasServer api config => HasServer (RemoteHost :> api) config where
440 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
429 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
441− type HasConfig (RemoteHost :> api) c = HasConfig api c
442
430
443 route Proxy config subserver = WithRequest $ \req ->
431 route Proxy config subserver = WithRequest $ \req ->
444 route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
432 route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
445
433
446−instance HasServer api => HasServer (IsSecure :> api) where
434+instance HasServer api config => HasServer (IsSecure :> api) config where
447 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
435 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
448− type HasConfig (IsSecure :> api) c = HasConfig api c
449
436
450 route Proxy config subserver = WithRequest $ \req ->
437 route Proxy config subserver = WithRequest $ \req ->
451 route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
438 route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
452
439
453 where secure req = if isSecure req then Secure else NotSecure
440 where secure req = if isSecure req then Secure else NotSecure
454
441
455−instance HasServer api => HasServer (Vault :> api) where
442+instance HasServer api config => HasServer (Vault :> api) config where
456 type ServerT (Vault :> api) m = Vault -> ServerT api m
443 type ServerT (Vault :> api) m = Vault -> ServerT api m
457− type HasConfig (Vault :> api) c = HasConfig api c
458
444
459 route Proxy config subserver = WithRequest $ \req ->
445 route Proxy config subserver = WithRequest $ \req ->
460 route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
446 route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
461
447
462−instance HasServer api => HasServer (HttpVersion :> api) where
448+instance HasServer api config => HasServer (HttpVersion :> api) config where
463 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
449 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
464− type HasConfig (HttpVersion :> api) c = HasConfig api c
465
450
466 route Proxy config subserver = WithRequest $ \req ->
451 route Proxy config subserver = WithRequest $ \req ->
467 route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
452 route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
@@ -477,11 +462,11 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP
477
462
478-- * configs
463-- * configs
479
464
465+instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig)
480−instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where
466+ => HasServer (WithNamedConfig name subConfig subApi) config where
467+
481 type ServerT (WithNamedConfig name subConfig subApi) m =
468 type ServerT (WithNamedConfig name subConfig subApi) m =
482 ServerT subApi m
469 ServerT subApi m
483− type HasConfig (WithNamedConfig name subConfig subApi) config =
484− (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
485
470
486 route Proxy config delayed =
471 route Proxy config delayed =
487 route subProxy subConfig delayed
472 route subProxy subConfig delayed
servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs+7−12
@@ -2,6 +2,7 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
@@ -24,13 +25,11 @@ import Servant.Server.Internal.RoutingApplication
24
25
25data ExtractFromConfig
26data ExtractFromConfig
26
27
27−instance (HasServer subApi) =>
28+instance (HasConfigEntry config String, HasServer subApi config) =>
28− HasServer (ExtractFromConfig :> subApi) where
29+ HasServer (ExtractFromConfig :> subApi) config where
29
30
30 type ServerT (ExtractFromConfig :> subApi) m =
31 type ServerT (ExtractFromConfig :> subApi) m =
31 String -> ServerT subApi m
32 String -> ServerT subApi m
32− type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) =
33− (HasConfigEntry c String, HasConfig subApi c)
34
33
35 route Proxy config delayed =
34 route Proxy config delayed =
36 route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
35 route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
@@ -42,13 +41,11 @@ instance (HasServer subApi) =>
42
41
43data InjectIntoConfig
42data InjectIntoConfig
44
43
45−instance (HasServer subApi) =>
44+instance (HasServer subApi (String ': config)) =>
46− HasServer (InjectIntoConfig :> subApi) where
45+ HasServer (InjectIntoConfig :> subApi) config where
47
46
48 type ServerT (InjectIntoConfig :> subApi) m =
47 type ServerT (InjectIntoConfig :> subApi) m =
49 ServerT subApi m
48 ServerT subApi m
50− type HasConfig (InjectIntoConfig :> subApi) c =
51− (HasConfig subApi (String ': c))
52
49
53 route Proxy config delayed =
50 route Proxy config delayed =
54 route subProxy newConfig delayed
51 route subProxy newConfig delayed
@@ -60,13 +57,11 @@ instance (HasServer subApi) =>
60
57
61data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
58data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
62
59
63−instance (HasServer subApi) =>
60+instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) =>
64− HasServer (NamedConfigWithBirdface name subConfig :> subApi) where
61+ HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where
65
62
66 type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
63 type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
67 ServerT subApi m
64 ServerT subApi m
68− type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config =
69− (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
70
65
71 route Proxy config delayed =
66 route Proxy config delayed =
72 route subProxy subConfig delayed
67 route subProxy subConfig delayed
servant-server/test/Servant/ServerSpec.hs+3−2
@@ -1,14 +1,15 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeSynonymInstances #-}
12{-# LANGUAGE TypeSynonymInstances #-}
11−{-# LANGUAGE FlexibleInstances #-}
12
13
13module Servant.ServerSpec where
14module Servant.ServerSpec where
14
15