git.iko.soy/typeable/servant
on master help sign in
Simplify verb combinators.
cda8bcfJulian K. Arni
servant-client/src/Servant/Client.hs+44−124
compare with master
unifiedsplit
@@ -4,6 +4,7 @@
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE InstanceSigs #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
@@ -44,7 +45,7 @@ import Servant.Common.Req
44-- | 'client' allows you to produce operations to query an API from a client.
45-- | 'client' allows you to produce operations to query an API from a client.
45--
46--
46-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
47-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
47−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
48+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
48-- >
49-- >
49-- > myApi :: Proxy MyApi
50-- > myApi :: Proxy MyApi
50-- > myApi = Proxy
51-- > myApi = Proxy
@@ -118,62 +119,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
118
119
119 where p = unpack (toUrlPiece val)
120 where p = unpack (toUrlPiece val)
120
121
121−-- | If you have a 'Delete' endpoint in your API, the client
122−-- side querying function that is created when calling 'client'
123−-- will just require an argument that specifies the scheme, host
124−-- and port to send the request to.
125instance OVERLAPPABLE_
122instance OVERLAPPABLE_
123+ -- Note [Non-Empty Content Types]
126− (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
124+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
125+ ) => HasClient (Verb method status cts' a) where
127− type Client (Delete cts' a) = ExceptT ServantError IO a
126+ type Client (Verb method status cts' a) = ExceptT ServantError IO a
128 clientWithRoute Proxy req baseurl manager =
127 clientWithRoute Proxy req baseurl manager =
129− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
128+ snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
129+ where method = reflectMethod (Proxy :: Proxy method)
130
130
131instance OVERLAPPING_
131instance OVERLAPPING_
132− HasClient (Delete cts ()) where
132+ (ReflectMethod method) => HasClient (Verb method status cts ()) where
133− type Client (Delete cts ()) = ExceptT ServantError IO ()
133+ type Client (Verb method status cts ()) = ExceptT ServantError IO ()
134 clientWithRoute Proxy req baseurl manager =
134 clientWithRoute Proxy req baseurl manager =
135− void $ performRequestNoBody H.methodDelete req baseurl manager
135+ void $ performRequestNoBody method req baseurl manager
136+ where method = reflectMethod (Proxy :: Proxy method)
136
137
137−-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
138−-- corresponding headers.
139instance OVERLAPPING_
138instance OVERLAPPING_
139+ -- Note [Non-Empty Content Types]
140− ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
140+ ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
141− ) => HasClient (Delete cts' (Headers ls a)) where
141+ ) => HasClient (Verb method status cts' (Headers ls a)) where
142+ type Client (Verb method status cts' (Headers ls a))
142− type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
143+ = ExceptT ServantError IO (Headers ls a)
143 clientWithRoute Proxy req baseurl manager = do
144 clientWithRoute Proxy req baseurl manager = do
145+ let method = reflectMethod (Proxy :: Proxy method)
144− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
146+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
145 return $ Headers { getResponse = resp
147 return $ Headers { getResponse = resp
146 , getHeadersHList = buildHeadersTo hdrs
148 , getHeadersHList = buildHeadersTo hdrs
147 }
149 }
148
150
149−-- | If you have a 'Get' endpoint in your API, the client
150−-- side querying function that is created when calling 'client'
151−-- will just require an argument that specifies the scheme, host
152−-- and port to send the request to.
153−instance OVERLAPPABLE_
154− (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
155− type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
156− clientWithRoute Proxy req baseurl manager =
157− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
158−
159−instance OVERLAPPING_
160− HasClient (Get (ct ': cts) ()) where
161− type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
162− clientWithRoute Proxy req baseurl manager =
163− performRequestNoBody H.methodGet req baseurl manager
164−
165−-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
166−-- corresponding headers.
167instance OVERLAPPING_
151instance OVERLAPPING_
168− ( MimeUnrender ct a, BuildHeadersTo ls
152+ ( BuildHeadersTo ls, ReflectMethod method
169− ) => HasClient (Get (ct ': cts) (Headers ls a)) where
153+ ) => HasClient (Verb method status cts (Headers ls ())) where
154+ type Client (Verb method status cts (Headers ls ()))
170− type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
155+ = ExceptT ServantError IO (Headers ls ())
171 clientWithRoute Proxy req baseurl manager = do
156 clientWithRoute Proxy req baseurl manager = do
172− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
157+ let method = reflectMethod (Proxy :: Proxy method)
158+ hdrs <- performRequestNoBody method req baseurl manager
173− return $ Headers { getResponse = resp
159+ return $ Headers { getResponse = ()
174 , getHeadersHList = buildHeadersTo hdrs
160 , getHeadersHList = buildHeadersTo hdrs
175 }
161 }
176
162
163+
177-- | If you use a 'Header' in one of your endpoints in your API,
164-- | If you use a 'Header' in one of your endpoints in your API,
178-- the corresponding querying function will automatically take
165-- the corresponding querying function will automatically take
179-- an additional argument of the type specified by your 'Header',
166-- an additional argument of the type specified by your 'Header',
@@ -217,90 +204,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
217
204
218 where hname = symbolVal (Proxy :: Proxy sym)
205 where hname = symbolVal (Proxy :: Proxy sym)
219
206
220−-- | If you have a 'Post' endpoint in your API, the client
221−-- side querying function that is created when calling 'client'
222−-- will just require an argument that specifies the scheme, host
223−-- and port to send the request to.
224−instance OVERLAPPABLE_
225− (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
226− type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
227− clientWithRoute Proxy req baseurl manager =
228− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
229−
230−instance OVERLAPPING_
231− HasClient (Post (ct ': cts) ()) where
232− type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
233− clientWithRoute Proxy req baseurl manager =
234− void $ performRequestNoBody H.methodPost req baseurl manager
235−
236−-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
237−-- corresponding headers.
238−instance OVERLAPPING_
239− ( MimeUnrender ct a, BuildHeadersTo ls
240− ) => HasClient (Post (ct ': cts) (Headers ls a)) where
241− type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
242− clientWithRoute Proxy req baseurl manager = do
243− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
244− return $ Headers { getResponse = resp
245− , getHeadersHList = buildHeadersTo hdrs
246− }
247−
248−-- | If you have a 'Put' endpoint in your API, the client
249−-- side querying function that is created when calling 'client'
250−-- will just require an argument that specifies the scheme, host
251−-- and port to send the request to.
252−instance OVERLAPPABLE_
253− (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
254− type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
255− clientWithRoute Proxy req baseurl manager =
256− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
257−
258−instance OVERLAPPING_
259− HasClient (Put (ct ': cts) ()) where
260− type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
261− clientWithRoute Proxy req baseurl manager =
262− void $ performRequestNoBody H.methodPut req baseurl manager
263−
264−-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
265−-- corresponding headers.
266−instance OVERLAPPING_
267− ( MimeUnrender ct a, BuildHeadersTo ls
268− ) => HasClient (Put (ct ': cts) (Headers ls a)) where
269− type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
270− clientWithRoute Proxy req baseurl manager= do
271− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
272− return $ Headers { getResponse = resp
273− , getHeadersHList = buildHeadersTo hdrs
274− }
275−
276−-- | If you have a 'Patch' endpoint in your API, the client
277−-- side querying function that is created when calling 'client'
278−-- will just require an argument that specifies the scheme, host
279−-- and port to send the request to.
280−instance OVERLAPPABLE_
281− (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
282− type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
283− clientWithRoute Proxy req baseurl manager =
284− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
285−
286−instance OVERLAPPING_
287− HasClient (Patch (ct ': cts) ()) where
288− type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
289− clientWithRoute Proxy req baseurl manager =
290− void $ performRequestNoBody H.methodPatch req baseurl manager
291−
292−-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
293−-- corresponding headers.
294−instance OVERLAPPING_
295− ( MimeUnrender ct a, BuildHeadersTo ls
296− ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
297− type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
298− clientWithRoute Proxy req baseurl manager = do
299− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
300− return $ Headers { getResponse = resp
301− , getHeadersHList = buildHeadersTo hdrs
302− }
303−
304-- | If you use a 'QueryParam' in one of your endpoints in your API,
207-- | If you use a 'QueryParam' in one of your endpoints in your API,
305-- the corresponding querying function will automatically take
208-- the corresponding querying function will automatically take
306-- an additional argument of the type specified by your 'QueryParam',
209-- an additional argument of the type specified by your 'QueryParam',
@@ -503,3 +406,20 @@ instance HasClient api => HasClient (IsSecure :> api) where
503
406
504 clientWithRoute Proxy req baseurl manager =
407 clientWithRoute Proxy req baseurl manager =
505 clientWithRoute (Proxy :: Proxy api) req baseurl manager
408 clientWithRoute (Proxy :: Proxy api) req baseurl manager
409+
410+
411+{- Note [Non-Empty Content Types]
412+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
413+Rather than have
414+
415+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...
416+
417+It may seem to make more sense to have:
418+
419+ instance (...) => ... (ct ': cts) ...
420+
421+But this means that if another instance exists that does *not* require
422+non-empty lists, but is otherwise more specific, no instance will be overall
423+more specific. This in turns generally means adding yet another instance (one
424+for empty and one for non-empty lists).
425+-}
servant-client/src/Servant/Common/Req.hs+11−8
@@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do
142 Right response -> do
142 Right response -> do
143 let status = Client.responseStatus response
143 let status = Client.responseStatus response
144 body = Client.responseBody response
144 body = Client.responseBody response
145− hrds = Client.responseHeaders response
145+ hdrs = Client.responseHeaders response
146 status_code = statusCode status
146 status_code = statusCode status
147 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
147 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
148 Nothing -> pure $ "application"//"octet-stream"
148 Nothing -> pure $ "application"//"octet-stream"
@@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do
151 Just t' -> pure t'
151 Just t' -> pure t'
152 unless (status_code >= 200 && status_code < 300) $
152 unless (status_code >= 200 && status_code < 300) $
153 throwE $ FailureResponse status ct body
153 throwE $ FailureResponse status ct body
154− return (status_code, body, ct, hrds, response)
154+ return (status_code, body, ct, hdrs, response)
155
155
156
156
157performRequestCT :: MimeUnrender ct result =>
157performRequestCT :: MimeUnrender ct result =>
158+ Proxy ct -> Method -> Req -> BaseUrl -> Manager
158− Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
159+ -> ExceptT ServantError IO ([HTTP.Header], result)
159performRequestCT ct reqMethod req reqHost manager = do
160performRequestCT ct reqMethod req reqHost manager = do
160 let acceptCT = contentType ct
161 let acceptCT = contentType ct
161− (_status, respBody, respCT, hrds, _response) <-
162+ (_status, respBody, respCT, hdrs, _response) <-
162 performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
163 performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
163 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
164 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
164 case mimeUnrender ct respBody of
165 case mimeUnrender ct respBody of
165 Left err -> throwE $ DecodeFailure err respCT respBody
166 Left err -> throwE $ DecodeFailure err respCT respBody
166− Right val -> return (hrds, val)
167+ Right val -> return (hdrs, val)
167
168
168−performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
169+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
169−performRequestNoBody reqMethod req reqHost manager =
170+ -> ExceptT ServantError IO [HTTP.Header]
171+performRequestNoBody reqMethod req reqHost manager = do
170− void $ performRequest reqMethod req reqHost manager
172+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
173+ return hdrs
171
174
172catchConnectionError :: IO a -> IO (Either ServantError a)
175catchConnectionError :: IO a -> IO (Either ServantError a)
173catchConnectionError action =
176catchConnectionError action =
servant-client/test/Servant/ClientSpec.hs+2−2
@@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
90
90
91type Api =
91type Api =
92 "get" :> Get '[JSON] Person
92 "get" :> Get '[JSON] Person
93− :<|> "deleteEmpty" :> Delete '[] ()
93+ :<|> "deleteEmpty" :> Delete '[JSON] ()
94 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
94 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
95 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
95 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
96 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
96 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
283 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
283 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
284
284
285data WrappedApi where
285data WrappedApi where
286− WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,
286+ WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
287 HasClient api, Client api ~ ExceptT ServantError IO ()) =>
287 HasClient api, Client api ~ ExceptT ServantError IO ()) =>
288 Proxy api -> WrappedApi
288 Proxy api -> WrappedApi
289
289
servant-docs/src/Servant/Docs/Internal.hs+32−31
@@ -476,8 +476,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
476
476
477-- | Synthesise a sample value of a type, encoded in the specified media types.
477-- | Synthesise a sample value of a type, encoded in the specified media types.
478sampleByteString
478sampleByteString
479− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
479+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
480− => Proxy ctypes
480+ => Proxy (ct ': cts)
481 -> Proxy a
481 -> Proxy a
482 -> [(M.MediaType, ByteString)]
482 -> [(M.MediaType, ByteString)]
483sampleByteString ctypes@Proxy Proxy =
483sampleByteString ctypes@Proxy Proxy =
@@ -486,8 +486,8 @@ sampleByteString ctypes@Proxy Proxy =
486-- | Synthesise a list of sample values of a particular type, encoded in the
486-- | Synthesise a list of sample values of a particular type, encoded in the
487-- specified media types.
487-- specified media types.
488sampleByteStrings
488sampleByteStrings
489− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
489+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
490− => Proxy ctypes
490+ => Proxy (ct ': cts)
491 -> Proxy a
491 -> Proxy a
492 -> [(Text, M.MediaType, ByteString)]
492 -> [(Text, M.MediaType, ByteString)]
493sampleByteStrings ctypes@Proxy Proxy =
493sampleByteStrings ctypes@Proxy Proxy =
@@ -689,21 +689,21 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
689
689
690
690
691instance OVERLAPPABLE_
691instance OVERLAPPABLE_
692− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
692+ (ToSample a, AllMimeRender (ct ': cts) a)
693− => HasDocs (Delete cts a) where
693+ => HasDocs (Delete (ct ': cts) a) where
694 docsFor Proxy (endpoint, action) DocOptions{..} =
694 docsFor Proxy (endpoint, action) DocOptions{..} =
695 single endpoint' action'
695 single endpoint' action'
696
696
697 where endpoint' = endpoint & method .~ DocDELETE
697 where endpoint' = endpoint & method .~ DocDELETE
698 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
698 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
699 & response.respTypes .~ allMime t
699 & response.respTypes .~ allMime t
700− t = Proxy :: Proxy cts
700+ t = Proxy :: Proxy (ct ': cts)
701 p = Proxy :: Proxy a
701 p = Proxy :: Proxy a
702
702
703instance OVERLAPPING_
703instance OVERLAPPING_
704− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
704+ (ToSample a, AllMimeRender (ct ': cts) a
705 , AllHeaderSamples ls , GetHeaders (HList ls) )
705 , AllHeaderSamples ls , GetHeaders (HList ls) )
706− => HasDocs (Delete cts (Headers ls a)) where
706+ => HasDocs (Delete (ct ': cts) (Headers ls a)) where
707 docsFor Proxy (endpoint, action) DocOptions{..} =
707 docsFor Proxy (endpoint, action) DocOptions{..} =
708 single endpoint' action'
708 single endpoint' action'
709
709
@@ -712,25 +712,26 @@ instance OVERLAPPING_
712 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
712 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
713 & response.respTypes .~ allMime t
713 & response.respTypes .~ allMime t
714 & response.respHeaders .~ hdrs
714 & response.respHeaders .~ hdrs
715− t = Proxy :: Proxy cts
715+ t = Proxy :: Proxy (ct ': cts)
716 p = Proxy :: Proxy a
716 p = Proxy :: Proxy a
717
717
718instance OVERLAPPABLE_
718instance OVERLAPPABLE_
719− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
719+ (ToSample a, AllMimeRender (ct ': cts) a)
720− => HasDocs (Get cts a) where
720+ => HasDocs (Get (ct ': cts) a) where
721+>>>>>>> Simplify verb combinators.
721 docsFor Proxy (endpoint, action) DocOptions{..} =
722 docsFor Proxy (endpoint, action) DocOptions{..} =
722 single endpoint' action'
723 single endpoint' action'
723
724
724 where endpoint' = endpoint & method .~ DocGET
725 where endpoint' = endpoint & method .~ DocGET
725 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
726 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
726 & response.respTypes .~ allMime t
727 & response.respTypes .~ allMime t
727− t = Proxy :: Proxy cts
728+ t = Proxy :: Proxy (ct ': cts)
728 p = Proxy :: Proxy a
729 p = Proxy :: Proxy a
729
730
730instance OVERLAPPING_
731instance OVERLAPPING_
731− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
732+ (ToSample a, AllMimeRender (ct ': cts) a
732 , AllHeaderSamples ls , GetHeaders (HList ls) )
733 , AllHeaderSamples ls , GetHeaders (HList ls) )
733− => HasDocs (Get cts (Headers ls a)) where
734+ => HasDocs (Get (ct ': cts) (Headers ls a)) where
734 docsFor Proxy (endpoint, action) DocOptions{..} =
735 docsFor Proxy (endpoint, action) DocOptions{..} =
735 single endpoint' action'
736 single endpoint' action'
736
737
@@ -739,7 +740,7 @@ instance OVERLAPPING_
739 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
740 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
740 & response.respTypes .~ allMime t
741 & response.respTypes .~ allMime t
741 & response.respHeaders .~ hdrs
742 & response.respHeaders .~ hdrs
742− t = Proxy :: Proxy cts
743+ t = Proxy :: Proxy (ct ': cts)
743 p = Proxy :: Proxy a
744 p = Proxy :: Proxy a
744
745
745instance (KnownSymbol sym, HasDocs sublayout)
746instance (KnownSymbol sym, HasDocs sublayout)
@@ -752,8 +753,8 @@ instance (KnownSymbol sym, HasDocs sublayout)
752 headername = pack $ symbolVal (Proxy :: Proxy sym)
753 headername = pack $ symbolVal (Proxy :: Proxy sym)
753
754
754instance OVERLAPPABLE_
755instance OVERLAPPABLE_
755− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
756+ (ToSample a, AllMimeRender (ct ': cts) a)
756− => HasDocs (Post cts a) where
757+ => HasDocs (Post (ct ': cts) a) where
757 docsFor Proxy (endpoint, action) DocOptions{..} =
758 docsFor Proxy (endpoint, action) DocOptions{..} =
758 single endpoint' action'
759 single endpoint' action'
759
760
@@ -761,13 +762,13 @@ instance OVERLAPPABLE_
761 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
762 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
762 & response.respTypes .~ allMime t
763 & response.respTypes .~ allMime t
763 & response.respStatus .~ 201
764 & response.respStatus .~ 201
764− t = Proxy :: Proxy cts
765+ t = Proxy :: Proxy (ct ': cts)
765 p = Proxy :: Proxy a
766 p = Proxy :: Proxy a
766
767
767instance OVERLAPPING_
768instance OVERLAPPING_
768− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
769+ (ToSample a, AllMimeRender (ct ': cts) a
769 , AllHeaderSamples ls , GetHeaders (HList ls) )
770 , AllHeaderSamples ls , GetHeaders (HList ls) )
770− => HasDocs (Post cts (Headers ls a)) where
771+ => HasDocs (Post (ct ': cts) (Headers ls a)) where
771 docsFor Proxy (endpoint, action) DocOptions{..} =
772 docsFor Proxy (endpoint, action) DocOptions{..} =
772 single endpoint' action'
773 single endpoint' action'
773
774
@@ -777,12 +778,12 @@ instance OVERLAPPING_
777 & response.respTypes .~ allMime t
778 & response.respTypes .~ allMime t
778 & response.respStatus .~ 201
779 & response.respStatus .~ 201
779 & response.respHeaders .~ hdrs
780 & response.respHeaders .~ hdrs
780− t = Proxy :: Proxy cts
781+ t = Proxy :: Proxy (ct ': cts)
781 p = Proxy :: Proxy a
782 p = Proxy :: Proxy a
782
783
783instance OVERLAPPABLE_
784instance OVERLAPPABLE_
784− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
785+ (ToSample a, AllMimeRender (ct ': cts) a)
785− => HasDocs (Put cts a) where
786+ => HasDocs (Put (ct ': cts) a) where
786 docsFor Proxy (endpoint, action) DocOptions{..} =
787 docsFor Proxy (endpoint, action) DocOptions{..} =
787 single endpoint' action'
788 single endpoint' action'
788
789
@@ -790,13 +791,13 @@ instance OVERLAPPABLE_
790 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
791 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
791 & response.respTypes .~ allMime t
792 & response.respTypes .~ allMime t
792 & response.respStatus .~ 200
793 & response.respStatus .~ 200
793− t = Proxy :: Proxy cts
794+ t = Proxy :: Proxy (ct ': cts)
794 p = Proxy :: Proxy a
795 p = Proxy :: Proxy a
795
796
796instance OVERLAPPING_
797instance OVERLAPPING_
797− ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
798+ ( ToSample a, AllMimeRender (ct ': cts) a,
798 AllHeaderSamples ls , GetHeaders (HList ls) )
799 AllHeaderSamples ls , GetHeaders (HList ls) )
799− => HasDocs (Put cts (Headers ls a)) where
800+ => HasDocs (Put (ct ': cts) (Headers ls a)) where
800 docsFor Proxy (endpoint, action) DocOptions{..} =
801 docsFor Proxy (endpoint, action) DocOptions{..} =
801 single endpoint' action'
802 single endpoint' action'
802
803
@@ -806,7 +807,7 @@ instance OVERLAPPING_
806 & response.respTypes .~ allMime t
807 & response.respTypes .~ allMime t
807 & response.respStatus .~ 200
808 & response.respStatus .~ 200
808 & response.respHeaders .~ hdrs
809 & response.respHeaders .~ hdrs
809− t = Proxy :: Proxy cts
810+ t = Proxy :: Proxy (ct ': cts)
810 p = Proxy :: Proxy a
811 p = Proxy :: Proxy a
811
812
812instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
813instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
@@ -849,8 +850,8 @@ instance HasDocs Raw where
849-- example data. However, there's no reason to believe that the instances of
850-- example data. However, there's no reason to believe that the instances of
850-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
851-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
851-- both are even defined) for any particular type.
852-- both are even defined) for any particular type.
852−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
853+instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
853− => HasDocs (ReqBody cts a :> sublayout) where
854+ => HasDocs (ReqBody (ct ': cts) a :> sublayout) where
854
855
855 docsFor Proxy (endpoint, action) =
856 docsFor Proxy (endpoint, action) =
856 docsFor sublayoutP (endpoint, action')
857 docsFor sublayoutP (endpoint, action')
@@ -858,7 +859,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
858 where sublayoutP = Proxy :: Proxy sublayout
859 where sublayoutP = Proxy :: Proxy sublayout
859 action' = action & rqbody .~ sampleByteString t p
860 action' = action & rqbody .~ sampleByteString t p
860 & rqtypes .~ allMime t
861 & rqtypes .~ allMime t
861− t = Proxy :: Proxy cts
862+ t = Proxy :: Proxy (ct ': cts)
862 p = Proxy :: Proxy a
863 p = Proxy :: Proxy a
863
864
864instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
865instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
servant-server/src/Servant/Server/Internal.hs+43−206
@@ -21,26 +21,33 @@ module Servant.Server.Internal
21#if !MIN_VERSION_base(4,8,0)
21#if !MIN_VERSION_base(4,8,0)
22import Control.Applicative ((<$>))
22import Control.Applicative ((<$>))
23#endif
23#endif
24−import Control.Monad.Trans.Except (ExceptT)
24+import Control.Monad.Trans.Except (ExceptT)
25−import qualified Data.ByteString as B
25+import qualified Data.ByteString as B
26−import qualified Data.ByteString.Lazy as BL
26+import qualified Data.ByteString.Lazy as BL
27−import qualified Data.Map as M
27+import qualified Data.Map as M
28−import Data.Maybe (fromMaybe, mapMaybe)
28+import Data.Maybe (fromMaybe, mapMaybe)
29−import Data.String (fromString)
29+import Data.String (fromString)
30−import Data.String.Conversions (ConvertibleStrings, cs, (<>))
30+import Data.String.Conversions (cs, (<>))
31−import Data.Text (Text)
31+import Data.Text (Text)
32import Data.Typeable
32import Data.Typeable
33−import GHC.TypeLits (KnownSymbol, symbolVal)
33+import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
34+ symbolVal)
34−import Network.HTTP.Types hiding (Header, ResponseHeaders)
35+import Network.HTTP.Types hiding (Header, ResponseHeaders)
35−import Network.Socket (SockAddr)
36+import Network.Socket (SockAddr)
36−import Network.Wai (Application, lazyRequestBody,
37+import Network.Wai (Application, Request, Response,
38+ httpVersion, isSecure,
39+ lazyRequestBody, pathInfo,
37− rawQueryString, requestHeaders,
40+ rawQueryString, remoteHost,
41+ requestHeaders, requestMethod,
38− requestMethod, responseLBS, remoteHost,
42+ responseLBS, vault)
39− isSecure, vault, httpVersion, Response,
43+import Web.HttpApiData (FromHttpApiData)
40− Request, pathInfo)
44+import Web.HttpApiData.Internal (parseHeaderMaybe,
45+ parseQueryParamMaybe,
46+ parseUrlPieceMaybe)
47+
41import Servant.API ((:<|>) (..), (:>), Capture,
48import Servant.API ((:<|>) (..), (:>), Capture,
42− Delete, Get, Header,
49+ Verb, ReflectMethod(reflectMethod),
43− IsSecure(..), Patch, Post, Put,
50+ IsSecure(..), Header,
44 QueryFlag, QueryParam, QueryParams,
51 QueryFlag, QueryParam, QueryParams,
45 Raw, RemoteHost, ReqBody, Vault)
52 Raw, RemoteHost, ReqBody, Vault)
46import Servant.API.ContentTypes (AcceptHeader (..),
53import Servant.API.ContentTypes (AcceptHeader (..),
@@ -55,8 +62,6 @@ import Servant.Server.Internal.Router
55import Servant.Server.Internal.RoutingApplication
62import Servant.Server.Internal.RoutingApplication
56import Servant.Server.Internal.ServantErr
63import Servant.Server.Internal.ServantErr
57
64
58−import Web.HttpApiData (FromHttpApiData)
59−import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
60
65
61class HasServer layout where
66class HasServer layout where
62 type ServerT layout (m :: * -> *) :: *
67 type ServerT layout (m :: * -> *) :: *
@@ -129,12 +134,12 @@ allowedMethodHead method request = method == methodGet && requestMethod request
129allowedMethod :: Method -> Request -> Bool
134allowedMethod :: Method -> Request -> Bool
130allowedMethod method request = allowedMethodHead method request || requestMethod request == method
135allowedMethod method request = allowedMethodHead method request || requestMethod request == method
131
136
132−processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
133− => Maybe (a, BL.ByteString) -> Status -> Method
137+processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
134 -> Maybe [(HeaderName, B.ByteString)]
138 -> Maybe [(HeaderName, B.ByteString)]
135 -> Request -> RouteResult Response
139 -> Request -> RouteResult Response
136processMethodRouter handleA status method headers request = case handleA of
140processMethodRouter handleA status method headers request = case handleA of
137 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
141 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
142+ Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) ""
138 Just (contentT, body) -> Route $ responseLBS status hdrs bdy
143 Just (contentT, body) -> Route $ responseLBS status hdrs bdy
139 where
144 where
140 bdy = if allowedMethodHead method request then "" else body
145 bdy = if allowedMethodHead method request then "" else body
@@ -160,7 +165,7 @@ methodRouter method proxy status action = LeafRouter route'
160 | pathIsEmpty request =
165 | pathIsEmpty request =
161 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
166 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
162 in runAction (action `addMethodCheck` methodCheck method request
167 in runAction (action `addMethodCheck` methodCheck method request
163− `addAcceptCheck` acceptCheck proxy accH
168+ `addAcceptCheck` acceptCheck proxy accH
164 ) respond $ \ output -> do
169 ) respond $ \ output -> do
165 let handleA = handleAcceptH proxy (AcceptHeader accH) output
170 let handleA = handleAcceptH proxy (AcceptHeader accH) output
166 processMethodRouter handleA status method Nothing request
171 processMethodRouter handleA status method Nothing request
@@ -176,95 +181,34 @@ methodRouterHeaders method proxy status action = LeafRouter route'
176 | pathIsEmpty request =
181 | pathIsEmpty request =
177 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
182 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
178 in runAction (action `addMethodCheck` methodCheck method request
183 in runAction (action `addMethodCheck` methodCheck method request
179− `addAcceptCheck` acceptCheck proxy accH
184+ `addAcceptCheck` acceptCheck proxy accH
180 ) respond $ \ output -> do
185 ) respond $ \ output -> do
181 let headers = getHeaders output
186 let headers = getHeaders output
182 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
187 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
183 processMethodRouter handleA status method (Just headers) request
188 processMethodRouter handleA status method (Just headers) request
184 | otherwise = respond $ Fail err404
189 | otherwise = respond $ Fail err404
185
190
186−methodRouterEmpty :: Method
187− -> Delayed (ExceptT ServantErr IO ())
188− -> Router
189−methodRouterEmpty method action = LeafRouter route'
190− where
191− route' request respond
192− | pathIsEmpty request = do
193− runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
194− Route $! responseLBS noContent204 [] ""
195− | otherwise = respond $ Fail err404
196−
197−-- | If you have a 'Delete' endpoint in your API,
198−-- the handler for this endpoint is meant to delete
199−-- a resource.
200−--
201−-- The code of the handler will, just like
202−-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
203−-- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@.
204−-- The 'Int' represents the status code and the 'String' a message
205−-- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to
206−-- painlessly error out if the conditions for a successful deletion
207−-- are not met.
208instance OVERLAPPABLE_
191instance OVERLAPPABLE_
209− ( AllCTRender ctypes a
192+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
210− ) => HasServer (Delete ctypes a) where
193+ ) => HasServer (Verb method status ctypes a) where
211−
212− type ServerT (Delete ctypes a) m = m a
213−
214− route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
215
194
216−instance OVERLAPPING_
217− HasServer (Delete ctypes ()) where
218−
219− type ServerT (Delete ctypes ()) m = m ()
195+ type ServerT (Verb method status ctypes a) m = m a
220
196
221− route Proxy = methodRouterEmpty methodDelete
197+ route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
198+ where method = reflectMethod (Proxy :: Proxy method)
199+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
222
200
223−-- Add response headers
224instance OVERLAPPING_
201instance OVERLAPPING_
225− ( GetHeaders (Headers h v), AllCTRender ctypes v
202+instance
203+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
204+ , GetHeaders (Headers h a)
226− ) => HasServer (Delete ctypes (Headers h v)) where
205+ ) => HasServer (Verb method status ctypes (Headers h a)) where
227−
228− type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
229−
230− route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
231
206
232−-- | When implementing the handler for a 'Get' endpoint,
207+ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
233−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
234−-- and 'Servant.API.Put.Put', the handler code runs in the
235−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
236−-- the status code and the 'String' a message, returned in case of
237−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
238−-- to quickly fail if some conditions are not met.
239−--
240−-- If successfully returning a value, we use the type-level list, combined
241−-- with the request's @Accept@ header, to encode the value for you
242−-- (returning a status code of 200). If there was no @Accept@ header or it
243−-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
244−-- list.
245−instance OVERLAPPABLE_
246− ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
247
208
248− type ServerT (Get ctypes a) m = m a
249−
250− route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
251−
252−-- '()' ==> 204 No Content
253−instance OVERLAPPING_
254− HasServer (Get ctypes ()) where
255−
256− type ServerT (Get ctypes ()) m = m ()
257−
258− route Proxy = methodRouterEmpty methodGet
259−
260−-- Add response headers
261−instance OVERLAPPING_
262− ( GetHeaders (Headers h v), AllCTRender ctypes v
263− ) => HasServer (Get ctypes (Headers h v)) where
264−
265− type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
266−
267− route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
209+ route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
210+ where method = reflectMethod (Proxy :: Proxy method)
211+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
268
212
269-- | If you use 'Header' in one of the endpoints for your API,
213-- | If you use 'Header' in one of the endpoints for your API,
270-- this automatically requires your server-side handler to be a function
214-- this automatically requires your server-side handler to be a function
@@ -297,113 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
297 in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
241 in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
298 where str = fromString $ symbolVal (Proxy :: Proxy sym)
242 where str = fromString $ symbolVal (Proxy :: Proxy sym)
299
243
300−-- | When implementing the handler for a 'Post' endpoint,
301−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
302−-- and 'Servant.API.Put.Put', the handler code runs in the
303−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
304−-- the status code and the 'String' a message, returned in case of
305−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
306−-- to quickly fail if some conditions are not met.
307−--
308−-- If successfully returning a value, we use the type-level list, combined
309−-- with the request's @Accept@ header, to encode the value for you
310−-- (returning a status code of 201). If there was no @Accept@ header or it
311−-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
312−-- list.
313−instance OVERLAPPABLE_
314− ( AllCTRender ctypes a
315− ) => HasServer (Post ctypes a) where
316−
317− type ServerT (Post ctypes a) m = m a
318−
319− route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
320−
321−instance OVERLAPPING_
322− HasServer (Post ctypes ()) where
323−
324− type ServerT (Post ctypes ()) m = m ()
325−
326− route Proxy = methodRouterEmpty methodPost
327−
328−-- Add response headers
329−instance OVERLAPPING_
330− ( GetHeaders (Headers h v), AllCTRender ctypes v
331− ) => HasServer (Post ctypes (Headers h v)) where
332−
333− type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
334−
335− route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
336−
337−-- | When implementing the handler for a 'Put' endpoint,
338−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
339−-- and 'Servant.API.Post.Post', the handler code runs in the
340−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
341−-- the status code and the 'String' a message, returned in case of
342−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
343−-- to quickly fail if some conditions are not met.
344−--
345−-- If successfully returning a value, we use the type-level list, combined
346−-- with the request's @Accept@ header, to encode the value for you
347−-- (returning a status code of 200). If there was no @Accept@ header or it
348−-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
349−-- list.
350−instance OVERLAPPABLE_
351− ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
352−
353− type ServerT (Put ctypes a) m = m a
354−
355− route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
356−
357−instance OVERLAPPING_
358− HasServer (Put ctypes ()) where
359−
360− type ServerT (Put ctypes ()) m = m ()
361−
362− route Proxy = methodRouterEmpty methodPut
363−
364−-- Add response headers
365−instance OVERLAPPING_
366− ( GetHeaders (Headers h v), AllCTRender ctypes v
367− ) => HasServer (Put ctypes (Headers h v)) where
368−
369− type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
370−
371− route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
372−
373−-- | When implementing the handler for a 'Patch' endpoint,
374−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
375−-- and 'Servant.API.Put.Put', the handler code runs in the
376−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
377−-- the status code and the 'String' a message, returned in case of
378−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
379−-- to quickly fail if some conditions are not met.
380−--
381−-- If successfully returning a value, we just require that its type has
382−-- a 'ToJSON' instance and servant takes care of encoding it for you,
383−-- yielding status code 200 along the way.
384−instance OVERLAPPABLE_
385− ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
386−
387− type ServerT (Patch ctypes a) m = m a
388−
389− route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
390−
391−instance OVERLAPPING_
392− HasServer (Patch ctypes ()) where
393−
394− type ServerT (Patch ctypes ()) m = m ()
395−
396− route Proxy = methodRouterEmpty methodPatch
397−
398−-- Add response headers
399−instance OVERLAPPING_
400− ( GetHeaders (Headers h v), AllCTRender ctypes v
401− ) => HasServer (Patch ctypes (Headers h v)) where
402−
403− type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
404−
405− route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
406−
407-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
244-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
408-- this automatically requires your server-side handler to be a function
245-- this automatically requires your server-side handler to be a function
409-- that takes an argument of type @'Maybe' 'Text'@.
246-- that takes an argument of type @'Maybe' 'Text'@.
servant-server/test/Servant/Server/ErrorSpec.hs+1−1
@@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search"
162
162
163 it "should continue when URLs don't match" $ do
163 it "should continue when URLs don't match" $ do
164 request methodPost "" [jsonCT, jsonAccept] jsonBody
164 request methodPost "" [jsonCT, jsonAccept] jsonBody
165− `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }
165+ `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
166
166
167 it "should continue when methods don't match" $ do
167 it "should continue when methods don't match" $ do
168 request methodGet "a" [jsonCT, jsonAccept] jsonBody
168 request methodGet "a" [jsonCT, jsonAccept] jsonBody
servant-server/test/Servant/Server/Internal/EnterSpec.hs+1−1
@@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do
52
52
53 it "allows running arbitrary monads" $ do
53 it "allows running arbitrary monads" $ do
54 get "int" `shouldRespondWith` "1797"
54 get "int" `shouldRespondWith` "1797"
55− post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
55+ post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
56
56
57 with (return (serve combinedAPI combinedReaderServer)) $ do
57 with (return (serve combinedAPI combinedReaderServer)) $ do
58 it "allows combnation of enters" $ do
58 it "allows combnation of enters" $ do
servant-server/test/Servant/ServerSpec.hs+22−26
@@ -130,15 +130,21 @@ captureSpec = do
130
130
131
131
132type GetApi = Get '[JSON] Person
132type GetApi = Get '[JSON] Person
133− :<|> "empty" :> Get '[] ()
133+ :<|> "empty" :> Get '[JSON] ()
134+ :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ())
134− :<|> "post" :> Post '[] ()
135+ :<|> "post" :> Post '[JSON] ()
136+
135getApi :: Proxy GetApi
137getApi :: Proxy GetApi
136getApi = Proxy
138getApi = Proxy
137
139
138getSpec :: Spec
140getSpec :: Spec
139getSpec = do
141getSpec = do
140 describe "Servant.API.Get" $ do
142 describe "Servant.API.Get" $ do
141− let server = return alice :<|> return () :<|> return ()
143+ let server = return alice
144+ :<|> return ()
145+ :<|> return (addHeader 5 ())
146+ :<|> return ()
147+
142 with (return $ serve getApi server) $ do
148 with (return $ serve getApi server) $ do
143
149
144 it "allows to GET a Person" $ do
150 it "allows to GET a Person" $ do
@@ -150,8 +156,8 @@ getSpec = do
150 post "/" "" `shouldRespondWith` 405
156 post "/" "" `shouldRespondWith` 405
151 post "/empty" "" `shouldRespondWith` 405
157 post "/empty" "" `shouldRespondWith` 405
152
158
153− it "returns 204 if the type is '()'" $ do
159+ it "returns headers" $ do
154− get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
160+ get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] }
155
161
156 it "returns 406 if the Accept header is not supported" $ do
162 it "returns 406 if the Accept header is not supported" $ do
157 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
163 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
@@ -161,7 +167,10 @@ getSpec = do
161headSpec :: Spec
167headSpec :: Spec
162headSpec = do
168headSpec = do
163 describe "Servant.API.Head" $ do
169 describe "Servant.API.Head" $ do
164− let server = return alice :<|> return () :<|> return ()
170+ let server = return alice
171+ :<|> return ()
172+ :<|> return (addHeader 5 ())
173+ :<|> return ()
165 with (return $ serve getApi server) $ do
174 with (return $ serve getApi server) $ do
166
175
167 it "allows to GET a Person" $ do
176 it "allows to GET a Person" $ do
@@ -177,10 +186,6 @@ headSpec = do
177 post "/" "" `shouldRespondWith` 405
186 post "/" "" `shouldRespondWith` 405
178 post "/empty" "" `shouldRespondWith` 405
187 post "/empty" "" `shouldRespondWith` 405
179
188
180− it "returns 204 if the type is '()'" $ do
181− response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
182− return response `shouldRespondWith` ""{ matchStatus = 204 }
183−
184 it "returns 406 if the Accept header is not supported" $ do
189 it "returns 406 if the Accept header is not supported" $ do
185 Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
190 Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
186 `shouldRespondWith` 406
191 `shouldRespondWith` 406
@@ -272,7 +277,7 @@ queryParamSpec = do
272type PostApi =
277type PostApi =
273 ReqBody '[JSON] Person :> Post '[JSON] Integer
278 ReqBody '[JSON] Person :> Post '[JSON] Integer
274 :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
279 :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
275− :<|> "empty" :> Post '[] ()
280+ :<|> "empty" :> Post '[JSON] ()
276
281
277postApi :: Proxy PostApi
282postApi :: Proxy PostApi
278postApi = Proxy
283postApi = Proxy
@@ -287,25 +292,22 @@ postSpec = do
287
292
288 it "allows to POST a Person" $ do
293 it "allows to POST a Person" $ do
289 post' "/" (encode alice) `shouldRespondWith` "42"{
294 post' "/" (encode alice) `shouldRespondWith` "42"{
290− matchStatus = 201
295+ matchStatus = 200
291 }
296 }
292
297
293 it "allows alternative routes if all have request bodies" $ do
298 it "allows alternative routes if all have request bodies" $ do
294 post' "/bla" (encode alice) `shouldRespondWith` "42"{
299 post' "/bla" (encode alice) `shouldRespondWith` "42"{
295− matchStatus = 201
300+ matchStatus = 200
296 }
301 }
297
302
298 it "handles trailing '/' gracefully" $ do
303 it "handles trailing '/' gracefully" $ do
299 post' "/bla/" (encode alice) `shouldRespondWith` "42"{
304 post' "/bla/" (encode alice) `shouldRespondWith` "42"{
300− matchStatus = 201
305+ matchStatus = 200
301 }
306 }
302
307
303 it "correctly rejects invalid request bodies with status 400" $ do
308 it "correctly rejects invalid request bodies with status 400" $ do
304 post' "/" "some invalid body" `shouldRespondWith` 400
309 post' "/" "some invalid body" `shouldRespondWith` 400
305
310
306− it "returns 204 if the type is '()'" $ do
307− post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
308−
309 it "responds with 415 if the request body media type is unsupported" $ do
311 it "responds with 415 if the request body media type is unsupported" $ do
310 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
312 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
311 , "application/nonsense")]
313 , "application/nonsense")]
@@ -314,7 +316,7 @@ postSpec = do
314type PutApi =
316type PutApi =
315 ReqBody '[JSON] Person :> Put '[JSON] Integer
317 ReqBody '[JSON] Person :> Put '[JSON] Integer
316 :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
318 :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
317− :<|> "empty" :> Put '[] ()
319+ :<|> "empty" :> Put '[JSON] ()
318
320
319putApi :: Proxy PutApi
321putApi :: Proxy PutApi
320putApi = Proxy
322putApi = Proxy
@@ -345,9 +347,6 @@ putSpec = do
345 it "correctly rejects invalid request bodies with status 400" $ do
347 it "correctly rejects invalid request bodies with status 400" $ do
346 put' "/" "some invalid body" `shouldRespondWith` 400
348 put' "/" "some invalid body" `shouldRespondWith` 400
347
349
348− it "returns 204 if the type is '()'" $ do
349− put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
350−
351 it "responds with 415 if the request body media type is unsupported" $ do
350 it "responds with 415 if the request body media type is unsupported" $ do
352 let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
351 let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
353 , "application/nonsense")]
352 , "application/nonsense")]
@@ -356,7 +355,7 @@ putSpec = do
356type PatchApi =
355type PatchApi =
357 ReqBody '[JSON] Person :> Patch '[JSON] Integer
356 ReqBody '[JSON] Person :> Patch '[JSON] Integer
358 :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
357 :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
359− :<|> "empty" :> Patch '[] ()
358+ :<|> "empty" :> Patch '[JSON] ()
360
359
361patchApi :: Proxy PatchApi
360patchApi :: Proxy PatchApi
362patchApi = Proxy
361patchApi = Proxy
@@ -387,9 +386,6 @@ patchSpec = do
387 it "correctly rejects invalid request bodies with status 400" $ do
386 it "correctly rejects invalid request bodies with status 400" $ do
388 patch' "/" "some invalid body" `shouldRespondWith` 400
387 patch' "/" "some invalid body" `shouldRespondWith` 400
389
388
390− it "returns 204 if the type is '()'" $ do
391− patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
392−
393 it "responds with 415 if the request body media type is unsupported" $ do
389 it "responds with 415 if the request body media type is unsupported" $ do
394 let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
390 let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
395 , "application/nonsense")]
391 , "application/nonsense")]
@@ -505,7 +501,7 @@ responseHeadersSpec :: Spec
505responseHeadersSpec = describe "ResponseHeaders" $ do
501responseHeadersSpec = describe "ResponseHeaders" $ do
506 with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
502 with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
507
503
508− let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
504+ let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)]
509
505
510 it "includes the headers in the response" $
506 it "includes the headers in the response" $
511 forM_ methods $ \(method, expected) ->
507 forM_ methods $ \(method, expected) ->
servant-server/test/Servant/Utils/StaticFilesSpec.hs+1−6
@@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)
15import Test.Hspec (Spec, around_, describe, it)
15import Test.Hspec (Spec, around_, describe, it)
16import Test.Hspec.Wai (get, shouldRespondWith, with)
16import Test.Hspec.Wai (get, shouldRespondWith, with)
17
17
18−import Servant.API (JSON)
18+import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
19−import Servant.API.Alternative ((:<|>) ((:<|>)))
20−import Servant.API.Capture (Capture)
21−import Servant.API.Get (Get)
22−import Servant.API.Raw (Raw)
23−import Servant.API.Sub ((:>))
24import Servant.Server (Server, serve)
19import Servant.Server (Server, serve)
25import Servant.ServerSpec (Person (Person))
20import Servant.ServerSpec (Person (Person))
26import Servant.Utils.StaticFiles (serveDirectory)
21import Servant.Utils.StaticFiles (serveDirectory)
servant/servant.cabal+1−5
@@ -29,14 +29,9 @@ library
29 Servant.API.Alternative
29 Servant.API.Alternative
30 Servant.API.Capture
30 Servant.API.Capture
31 Servant.API.ContentTypes
31 Servant.API.ContentTypes
32− Servant.API.Delete
33− Servant.API.Get
34 Servant.API.Header
32 Servant.API.Header
35 Servant.API.HttpVersion
33 Servant.API.HttpVersion
36 Servant.API.IsSecure
34 Servant.API.IsSecure
37− Servant.API.Patch
38− Servant.API.Post
39− Servant.API.Put
40 Servant.API.QueryParam
35 Servant.API.QueryParam
41 Servant.API.Raw
36 Servant.API.Raw
42 Servant.API.RemoteHost
37 Servant.API.RemoteHost
@@ -44,6 +39,7 @@ library
44 Servant.API.ResponseHeaders
39 Servant.API.ResponseHeaders
45 Servant.API.Sub
40 Servant.API.Sub
46 Servant.API.Vault
41 Servant.API.Vault
42+ Servant.API.Verbs
47 Servant.Utils.Links
43 Servant.Utils.Links
48 build-depends:
44 build-depends:
49 base >=4.7 && <5
45 base >=4.7 && <5
servant/src/Servant/API.hs+6−17
@@ -25,16 +25,7 @@ module Servant.API (
25 -- | Access the location for arbitrary data to be shared by applications and middleware
25 -- | Access the location for arbitrary data to be shared by applications and middleware
26
26
27 -- * Actual endpoints, distinguished by HTTP method
27 -- * Actual endpoints, distinguished by HTTP method
28− module Servant.API.Get,
28+ module Servant.API.Verbs,
29− -- | @GET@ requests
30− module Servant.API.Post,
31− -- | @POST@ requests
32− module Servant.API.Delete,
33− -- | @DELETE@ requests
34− module Servant.API.Put,
35− -- | @PUT@ requests
36− module Servant.API.Patch,
37− -- | @PATCH@ requests
38
29
39 -- * Content Types
30 -- * Content Types
40 module Servant.API.ContentTypes,
31 module Servant.API.ContentTypes,
@@ -64,14 +55,9 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
64 MimeRender (..),
55 MimeRender (..),
65 MimeUnrender (..), OctetStream,
56 MimeUnrender (..), OctetStream,
66 PlainText, ToFormUrlEncoded (..))
57 PlainText, ToFormUrlEncoded (..))
67−import Servant.API.Delete (Delete)
68−import Servant.API.Get (Get)
69import Servant.API.Header (Header (..))
58import Servant.API.Header (Header (..))
70import Servant.API.HttpVersion (HttpVersion (..))
59import Servant.API.HttpVersion (HttpVersion (..))
71import Servant.API.IsSecure (IsSecure (..))
60import Servant.API.IsSecure (IsSecure (..))
72−import Servant.API.Patch (Patch)
73−import Servant.API.Post (Post)
74−import Servant.API.Put (Put)
75import Servant.API.QueryParam (QueryFlag, QueryParam,
61import Servant.API.QueryParam (QueryFlag, QueryParam,
76 QueryParams)
62 QueryParams)
77import Servant.API.Raw (Raw)
63import Servant.API.Raw (Raw)
@@ -84,7 +70,10 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
84 getHeadersHList, getResponse)
70 getHeadersHList, getResponse)
85import Servant.API.Sub ((:>))
71import Servant.API.Sub ((:>))
86import Servant.API.Vault (Vault)
72import Servant.API.Vault (Vault)
87−import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
73+import Servant.API.Verbs (Delete, Get, Patch, Post, Put,
74+ ReflectMethod (reflectMethod),
75+ Verb)
88import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
76import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
89 URI (..), safeLink)
77 URI (..), safeLink)
90−
78+import Web.HttpApiData (FromHttpApiData (..),
79+ ToHttpApiData (..))
servant/src/Servant/API/ContentTypes.hs+47−19
@@ -2,6 +2,7 @@
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5+{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
@@ -10,6 +11,9 @@
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
14+#if !MIN_VERSION_base(4,8,0)
15+{-# LANGUAGE OverlappingInstances #-}
16+#endif
13{-# OPTIONS_HADDOCK not-home #-}
17{-# OPTIONS_HADDOCK not-home #-}
14
18
15-- | A collection of basic Content-Types (also known as Internet Media
19-- | A collection of basic Content-Types (also known as Internet Media
@@ -19,7 +23,7 @@
19--
23--
20-- Content-Types are used in `ReqBody` and the method combinators:
24-- Content-Types are used in `ReqBody` and the method combinators:
21--
25--
22−-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book
26+-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
23--
27--
24-- Meaning the endpoint accepts requests of Content-Type @application/json@
28-- Meaning the endpoint accepts requests of Content-Type @application/json@
25-- or @text/plain;charset-utf8@, and returns data in either one of those
29-- or @text/plain;charset-utf8@, and returns data in either one of those
@@ -62,7 +66,6 @@ module Servant.API.ContentTypes
62 , AllMimeUnrender(..)
66 , AllMimeUnrender(..)
63 , FromFormUrlEncoded(..)
67 , FromFormUrlEncoded(..)
64 , ToFormUrlEncoded(..)
68 , ToFormUrlEncoded(..)
65− , IsNonEmpty
66 , eitherDecodeLenient
69 , eitherDecodeLenient
67 , canHandleAcceptH
70 , canHandleAcceptH
68 ) where
71 ) where
@@ -91,7 +94,7 @@ import qualified Data.Text.Encoding as TextS
91import qualified Data.Text.Lazy as TextL
94import qualified Data.Text.Lazy as TextL
92import qualified Data.Text.Lazy.Encoding as TextL
95import qualified Data.Text.Lazy.Encoding as TextL
93import Data.Typeable
96import Data.Typeable
94−import GHC.Exts (Constraint)
97+import GHC.Generics (Generic)
95import qualified Network.HTTP.Media as M
98import qualified Network.HTTP.Media as M
96import Network.URI (escapeURIString,
99import Network.URI (escapeURIString,
97 isUnreserved, unEscapeString)
100 isUnreserved, unEscapeString)
@@ -137,7 +140,7 @@ instance Accept OctetStream where
137 contentType _ = "application" M.// "octet-stream"
140 contentType _ = "application" M.// "octet-stream"
138
141
139newtype AcceptHeader = AcceptHeader BS.ByteString
142newtype AcceptHeader = AcceptHeader BS.ByteString
140− deriving (Eq, Show)
143+ deriving (Eq, Show, Read, Typeable, Generic)
141
144
142-- * Render (serializing)
145-- * Render (serializing)
143
146
@@ -159,19 +162,22 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
159class Accept ctype => MimeRender ctype a where
162class Accept ctype => MimeRender ctype a where
160 mimeRender :: Proxy ctype -> a -> ByteString
163 mimeRender :: Proxy ctype -> a -> ByteString
161
164
162−class (AllMimeRender list a) => AllCTRender (list :: [*]) a where
165+class (AllMime list) => AllCTRender (list :: [*]) a where
163 -- If the Accept header can be matched, returns (Just) a tuple of the
166 -- If the Accept header can be matched, returns (Just) a tuple of the
164 -- Content-Type and response (serialization of @a@ into the appropriate
167 -- Content-Type and response (serialization of @a@ into the appropriate
165 -- mimetype).
168 -- mimetype).
166 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
169 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
167
170
171+instance
172+#if MIN_VERSION_base(4,8,0)
173+ {-# OVERLAPPABLE #-}
174+#endif
168−instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
175+ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
169 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
176 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
170− where pctyps = Proxy :: Proxy ctyps
177+ where pctyps = Proxy :: Proxy (ct ': cts)
171 amrs = allMimeRender pctyps val
178 amrs = allMimeRender pctyps val
172 lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
179 lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
173
180
174−
175--------------------------------------------------------------------------
181--------------------------------------------------------------------------
176-- * Unrender
182-- * Unrender
177
183
@@ -199,14 +205,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
199class Accept ctype => MimeUnrender ctype a where
205class Accept ctype => MimeUnrender ctype a where
200 mimeUnrender :: Proxy ctype -> ByteString -> Either String a
206 mimeUnrender :: Proxy ctype -> ByteString -> Either String a
201
207
202−class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
208+class AllCTUnrender (list :: [*]) a where
203 handleCTypeH :: Proxy list
209 handleCTypeH :: Proxy list
204 -> ByteString -- Content-Type header
210 -> ByteString -- Content-Type header
205 -> ByteString -- Request body
211 -> ByteString -- Request body
206 -> Maybe (Either String a)
212 -> Maybe (Either String a)
207
213
208−instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
209− ) => AllCTUnrender ctyps a where
214+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
210 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
215 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
211 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
216 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
212
217
@@ -247,8 +252,7 @@ instance ( MimeRender ctyp a
247 where pctyp = Proxy :: Proxy ctyp
252 where pctyp = Proxy :: Proxy ctyp
248 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
253 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
249
254
250−
251−instance AllMimeRender '[] a where
255+instance AllMimeRender '[] () where
252 allMimeRender _ _ = []
256 allMimeRender _ _ = []
253
257
254--------------------------------------------------------------------------
258--------------------------------------------------------------------------
@@ -270,21 +274,25 @@ instance ( MimeUnrender ctyp a
270 where pctyp = Proxy :: Proxy ctyp
274 where pctyp = Proxy :: Proxy ctyp
271 pctyps = Proxy :: Proxy ctyps
275 pctyps = Proxy :: Proxy ctyps
272
276
273−type family IsNonEmpty (list :: [*]) :: Constraint where
274− IsNonEmpty (x ': xs) = ()
275−
276−
277--------------------------------------------------------------------------
277--------------------------------------------------------------------------
278-- * MimeRender Instances
278-- * MimeRender Instances
279
279
280-- | `encode`
280-- | `encode`
281+instance
282+#if MIN_VERSION_base(4,8,0)
283+ {-# OVERLAPPABLE #-}
284+#endif
281−instance ToJSON a => MimeRender JSON a where
285+ ToJSON a => MimeRender JSON a where
282 mimeRender _ = encode
286 mimeRender _ = encode
283
287
284-- | @encodeFormUrlEncoded . toFormUrlEncoded@
288-- | @encodeFormUrlEncoded . toFormUrlEncoded@
285-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
289-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
286-- holds if every element of x is non-null (i.e., not @("", "")@)
290-- holds if every element of x is non-null (i.e., not @("", "")@)
291+instance
292+#if MIN_VERSION_base(4,8,0)
293+ {-# OVERLAPPABLE #-}
294+#endif
287−instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
295+ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
288 mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
296 mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
289
297
290-- | `TextL.encodeUtf8`
298-- | `TextL.encodeUtf8`
@@ -307,6 +315,26 @@ instance MimeRender OctetStream ByteString where
307instance MimeRender OctetStream BS.ByteString where
315instance MimeRender OctetStream BS.ByteString where
308 mimeRender _ = fromStrict
316 mimeRender _ = fromStrict
309
317
318+instance
319+#if MIN_VERSION_base(4,8,0)
320+ {-# OVERLAPPING #-}
321+#endif
322+ MimeRender JSON () where
323+ mimeRender _ _ = ""
324+
325+instance
326+#if MIN_VERSION_base(4,8,0)
327+ {-# OVERLAPPING #-}
328+#endif
329+ MimeRender PlainText () where
330+ mimeRender _ _ = ""
331+
332+instance
333+#if MIN_VERSION_base(4,8,0)
334+ {-# OVERLAPPING #-}
335+#endif
336+ MimeRender OctetStream () where
337+ mimeRender _ _ = ""
310
338
311--------------------------------------------------------------------------
339--------------------------------------------------------------------------
312-- * MimeUnrender Instances
340-- * MimeUnrender Instances
servant/src/Servant/API/Delete.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# OPTIONS_HADDOCK not-home #-}
5−module Servant.API.Delete (Delete) where
6−
7−import Data.Typeable (Typeable)
8−
9−-- | Combinator for DELETE requests.
10−--
11−-- Example:
12−--
13−-- >>> -- DELETE /books/:isbn
14−-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] ()
15−data Delete (contentTypes :: [*]) a
16− deriving Typeable
17−
18−
19−-- $setup
20−-- >>> import Servant.API
21−-- >>> import Data.Aeson
22−-- >>> import Data.Text
23−-- >>> data Book
24−-- >>> instance ToJSON Book where { toJSON = undefined }
servant/src/Servant/API/Get.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# OPTIONS_HADDOCK not-home #-}
5−module Servant.API.Get (Get) where
6−
7−import Data.Typeable (Typeable)
8−
9−-- | Endpoint for simple GET requests. Serves the result as JSON.
10−--
11−-- Example:
12−--
13−-- >>> type MyApi = "books" :> Get '[JSON] [Book]
14−data Get (contentTypes :: [*]) a
15− deriving Typeable
16−
17−-- $setup
18−-- >>> import Servant.API
19−-- >>> import Data.Aeson
20−-- >>> import Data.Text
21−-- >>> data Book
22−-- >>> instance ToJSON Book where { toJSON = undefined }
servant/src/Servant/API/Patch.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# OPTIONS_HADDOCK not-home #-}
5−module Servant.API.Patch (Patch) where
6−
7−import Data.Typeable (Typeable)
8−
9−-- | Endpoint for PATCH requests. The type variable represents the type of the
10−-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
11−-- that).
12−--
13−-- If the HTTP response is empty, only () is supported.
14−--
15−-- Example:
16−--
17−-- >>> -- PATCH /books
18−-- >>> -- with a JSON encoded Book as the request body
19−-- >>> -- returning the just-created Book
20−-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book
21−data Patch (contentTypes :: [*]) a
22− deriving Typeable
23−
24−-- $setup
25−-- >>> import Servant.API
26−-- >>> import Data.Aeson
27−-- >>> import Data.Text
28−-- >>> data Book
29−-- >>> instance ToJSON Book where { toJSON = undefined }
servant/src/Servant/API/Post.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# OPTIONS_HADDOCK not-home #-}
5−module Servant.API.Post (Post) where
6−
7−import Data.Typeable (Typeable)
8−
9−-- | Endpoint for POST requests. The type variable represents the type of the
10−-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
11−-- that).
12−--
13−-- Example:
14−--
15−-- >>> -- POST /books
16−-- >>> -- with a JSON encoded Book as the request body
17−-- >>> -- returning the just-created Book
18−-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
19−data Post (contentTypes :: [*]) a
20− deriving Typeable
21−
22−-- $setup
23−-- >>> import Servant.API
24−-- >>> import Data.Aeson
25−-- >>> import Data.Text
26−-- >>> data Book
27−-- >>> instance ToJSON Book where { toJSON = undefined }
servant/src/Servant/API/Put.hsdeleted−25
@@ -1,25 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# OPTIONS_HADDOCK not-home #-}
5−module Servant.API.Put (Put) where
6−
7−import Data.Typeable (Typeable)
8−
9−-- | Endpoint for PUT requests, usually used to update a ressource.
10−-- The type @a@ is the type of the response body that's returned.
11−--
12−-- Example:
13−--
14−-- >>> -- PUT /books/:isbn
15−-- >>> -- with a Book as request body, returning the updated Book
16−-- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book
17−data Put (contentTypes :: [*]) a
18− deriving Typeable
19−
20−-- $setup
21−-- >>> import Servant.API
22−-- >>> import Data.Aeson
23−-- >>> import Data.Text
24−-- >>> data Book
25−-- >>> instance ToJSON Book where { toJSON = undefined }
servant/src/Servant/API/Verbs.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE PolyKinds #-}
6+module Servant.API.Verbs where
7+
8+import Data.Typeable (Typeable)
9+import GHC.Generics (Generic)
10+import GHC.TypeLits (Nat)
11+import Network.HTTP.Types.Method (Method, StdMethod (..),
12+ methodDelete, methodGet, methodHead,
13+ methodPatch, methodPost, methodPut)
14+
15+-- | @Verb@ is a general type for representing HTTP verbs/methods. For
16+-- convenience, type synonyms for each verb with a 200 response code are
17+-- provided, but you are free to define your own:
18+--
19+-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a
20+data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a
21+ deriving (Typeable, Generic)
22+
23+-- 'GET' with 200 status code.
24+type Get contentTypes a = Verb 'GET 200 contentTypes a
25+
26+-- 'POST' with 200 status code.
27+type Post contentTypes a = Verb 'POST 200 contentTypes a
28+
29+-- 'PUT' with 200 status code.
30+type Put contentTypes a = Verb 'PUT 200 contentTypes a
31+
32+-- 'DELETE' with 200 status code.
33+type Delete contentTypes a = Verb 'DELETE 200 contentTypes a
34+
35+-- 'PATCH' with 200 status code.
36+type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
37+
38+-- 'HEAD' with 200 status code.
39+type Head contentTypes a = Verb 'HEAD 200 contentTypes a
40+
41+class ReflectMethod a where
42+ reflectMethod :: proxy a -> Method
43+
44+instance ReflectMethod 'GET where
45+ reflectMethod _ = methodGet
46+
47+instance ReflectMethod 'POST where
48+ reflectMethod _ = methodPost
49+
50+instance ReflectMethod 'PUT where
51+ reflectMethod _ = methodPut
52+
53+instance ReflectMethod 'DELETE where
54+ reflectMethod _ = methodDelete
55+
56+instance ReflectMethod 'PATCH where
57+ reflectMethod _ = methodPatch
58+
59+instance ReflectMethod 'HEAD where
60+ reflectMethod _ = methodHead
servant/src/Servant/Utils/Links.hs+8−29
@@ -74,7 +74,9 @@
74-- >>> safeLink api bad_link
74-- >>> safeLink api bad_link
75-- ...
75-- ...
76-- Could not deduce (Or
76-- Could not deduce (Or
77−-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
77+-- (IsElem'
78+-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ())
79+-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int))
78-- (IsElem'
80-- (IsElem'
79-- ("hello" :> Delete '[JSON] ())
81-- ("hello" :> Delete '[JSON] ())
80-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
82-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
@@ -119,11 +121,7 @@ import Servant.API.Capture ( Capture )
119import Servant.API.ReqBody ( ReqBody )
121import Servant.API.ReqBody ( ReqBody )
120import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
122import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
121import Servant.API.Header ( Header )
123import Servant.API.Header ( Header )
122−import Servant.API.Get ( Get )
124+import Servant.API.Verbs ( Verb )
123−import Servant.API.Post ( Post )
124−import Servant.API.Put ( Put )
125−import Servant.API.Patch ( Patch )
126−import Servant.API.Delete ( Delete )
127import Servant.API.Sub ( type (:>) )
125import Servant.API.Sub ( type (:>) )
128import Servant.API.Raw ( Raw )
126import Servant.API.Raw ( Raw )
129import Servant.API.Alternative ( type (:<|>) )
127import Servant.API.Alternative ( type (:<|>) )
@@ -177,11 +175,8 @@ type family IsElem endpoint api :: Constraint where
177 IsElem sa (QueryParam x y :> sb) = IsElem sa sb
175 IsElem sa (QueryParam x y :> sb) = IsElem sa sb
178 IsElem sa (QueryParams x y :> sb) = IsElem sa sb
176 IsElem sa (QueryParams x y :> sb) = IsElem sa sb
179 IsElem sa (QueryFlag x :> sb) = IsElem sa sb
177 IsElem sa (QueryFlag x :> sb) = IsElem sa sb
180− IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
178+ IsElem (Verb m s ct typ) (Verb m s ct' typ)
181− IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'
182− IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'
183− IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'
184− IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
179+ = IsSubList ct ct'
185 IsElem e e = ()
180 IsElem e e = ()
186 IsElem e a = IsElem' e a
181 IsElem e a = IsElem' e a
187
182
@@ -303,24 +298,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
303 toLink _ = toLink (Proxy :: Proxy sub)
298 toLink _ = toLink (Proxy :: Proxy sub)
304
299
305-- Verb (terminal) instances
300-- Verb (terminal) instances
306−instance HasLink (Get y r) where
301+instance HasLink (Verb m s ct a) where
307− type MkLink (Get y r) = URI
308− toLink _ = linkURI
309−
310−instance HasLink (Post y r) where
311− type MkLink (Post y r) = URI
302+ type MkLink (Verb m s ct a) = URI
312− toLink _ = linkURI
313−
314−instance HasLink (Put y r) where
315− type MkLink (Put y r) = URI
316− toLink _ = linkURI
317−
318−instance HasLink (Patch y r) where
319− type MkLink (Patch y r) = URI
320− toLink _ = linkURI
321−
322−instance HasLink (Delete y r) where
323− type MkLink (Delete y r) = URI
324 toLink _ = linkURI
303 toLink _ = linkURI
325
304
326instance HasLink Raw where
305instance HasLink Raw where