git.iko.soy/typeable/servant
on master help sign in
Simplify verb combinators.

Create a single 'Verb' combinator with parameters for status code and method. Make existing combinators type synonyms of 'Verb'.

commitcda8bcf17cbe5a23696fcf0e320f1d8ec99d0505 authorJulian K. Arni <jkarni@gmail.com> dateFri 27 Nov 2015, 02:05 (11 years ago) parent3d0ae36
19 files changed+279−602
compare with master
unifiedsplit
servant-client/src/Servant/Client.hs+44−124 servant-client/src/Servant/Common/Req.hs+11−8 servant-client/test/Servant/ClientSpec.hs+2−2 servant-docs/src/Servant/Docs/Internal.hs+32−31 servant-server/src/Servant/Server/Internal.hs+43−206 servant-server/test/Servant/Server/ErrorSpec.hs+1−1 servant-server/test/Servant/Server/Internal/EnterSpec.hs+1−1 servant-server/test/Servant/ServerSpec.hs+22−26 servant-server/test/Servant/Utils/StaticFilesSpec.hs+1−6 servant/servant.cabal+1−5 servant/src/Servant/API.hs+6−17 servant/src/Servant/API/ContentTypes.hs+47−19 servant/src/Servant/API/Delete.hs−24 servant/src/Servant/API/Get.hs−22 servant/src/Servant/API/Patch.hs−29 servant/src/Servant/API/Post.hs−27 servant/src/Servant/API/Put.hs−25 servant/src/Servant/API/Verbs.hs+60 servant/src/Servant/Utils/Links.hs+8−29
servant-client/src/Servant/Client.hs+44−124
@@ -4,6 +4,7 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE InstanceSigs #-}
66{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeFamilies #-}
910{-# LANGUAGE TypeOperators #-}
@@ -44,7 +45,7 @@ import Servant.Common.Req
4445-- | 'client' allows you to produce operations to query an API from a client.
4546--
4647-- > 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
4849-- >
4950-- > myApi :: Proxy MyApi
5051-- > myApi = Proxy
@@ -118,62 +119,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
118119
119120 where p = unpack (toUrlPiece val)
120121
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.
125122instance OVERLAPPABLE_
126− (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
127− type Client (Delete cts' a) = ExceptT ServantError IO a
123+ -- Note [Non-Empty Content Types]
124+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
125+ ) => HasClient (Verb method status cts' a) where
126+ type Client (Verb method status cts' a) = ExceptT ServantError IO a
128127 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)
130130
131131instance OVERLAPPING_
132− HasClient (Delete cts ()) where
133− type Client (Delete cts ()) = ExceptT ServantError IO ()
132+ (ReflectMethod method) => HasClient (Verb method status cts ()) where
133+ type Client (Verb method status cts ()) = ExceptT ServantError IO ()
134134 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)
136137
137−-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
138−-- corresponding headers.
139138instance OVERLAPPING_
140− ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
141− ) => HasClient (Delete cts' (Headers ls a)) where
142− type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
139+ -- Note [Non-Empty Content Types]
140+ ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
141+ ) => HasClient (Verb method status cts' (Headers ls a)) where
142+ type Client (Verb method status cts' (Headers ls a))
143+ = ExceptT ServantError IO (Headers ls a)
143144 clientWithRoute Proxy req baseurl manager = do
144− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
145+ let method = reflectMethod (Proxy :: Proxy method)
146+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
145147 return $ Headers { getResponse = resp
146148 , getHeadersHList = buildHeadersTo hdrs
147149 }
148150
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.
167151instance OVERLAPPING_
168− ( MimeUnrender ct a, BuildHeadersTo ls
169− ) => HasClient (Get (ct ': cts) (Headers ls a)) where
170− type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
152+ ( BuildHeadersTo ls, ReflectMethod method
153+ ) => HasClient (Verb method status cts (Headers ls ())) where
154+ type Client (Verb method status cts (Headers ls ()))
155+ = ExceptT ServantError IO (Headers ls ())
171156 clientWithRoute Proxy req baseurl manager = do
172− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
173− return $ Headers { getResponse = resp
157+ let method = reflectMethod (Proxy :: Proxy method)
158+ hdrs <- performRequestNoBody method req baseurl manager
159+ return $ Headers { getResponse = ()
174160 , getHeadersHList = buildHeadersTo hdrs
175161 }
176162
163+
177164-- | If you use a 'Header' in one of your endpoints in your API,
178165-- the corresponding querying function will automatically take
179166-- an additional argument of the type specified by your 'Header',
@@ -217,90 +204,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
217204
218205 where hname = symbolVal (Proxy :: Proxy sym)
219206
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−
304207-- | If you use a 'QueryParam' in one of your endpoints in your API,
305208-- the corresponding querying function will automatically take
306209-- an additional argument of the type specified by your 'QueryParam',
@@ -503,3 +406,20 @@ instance HasClient api => HasClient (IsSecure :> api) where
503406
504407 clientWithRoute Proxy req baseurl manager =
505408 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
142142 Right response -> do
143143 let status = Client.responseStatus response
144144 body = Client.responseBody response
145− hrds = Client.responseHeaders response
145+ hdrs = Client.responseHeaders response
146146 status_code = statusCode status
147147 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
148148 Nothing -> pure $ "application"//"octet-stream"
@@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do
151151 Just t' -> pure t'
152152 unless (status_code >= 200 && status_code < 300) $
153153 throwE $ FailureResponse status ct body
154− return (status_code, body, ct, hrds, response)
154+ return (status_code, body, ct, hdrs, response)
155155
156156
157157performRequestCT :: MimeUnrender ct result =>
158− Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
158+ Proxy ct -> Method -> Req -> BaseUrl -> Manager
159+ -> ExceptT ServantError IO ([HTTP.Header], result)
159160performRequestCT ct reqMethod req reqHost manager = do
160161 let acceptCT = contentType ct
161− (_status, respBody, respCT, hrds, _response) <-
162+ (_status, respBody, respCT, hdrs, _response) <-
162163 performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
163164 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
164165 case mimeUnrender ct respBody of
165166 Left err -> throwE $ DecodeFailure err respCT respBody
166− Right val -> return (hrds, val)
167+ Right val -> return (hdrs, val)
167168
168−performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
169−performRequestNoBody reqMethod req reqHost manager =
170− void $ performRequest reqMethod req reqHost manager
169+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
170+ -> ExceptT ServantError IO [HTTP.Header]
171+performRequestNoBody reqMethod req reqHost manager = do
172+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
173+ return hdrs
171174
172175catchConnectionError :: IO a -> IO (Either ServantError a)
173176catchConnectionError action =
servant-client/test/Servant/ClientSpec.hs+2−2
@@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
9090
9191type Api =
9292 "get" :> Get '[JSON] Person
93− :<|> "deleteEmpty" :> Delete '[] ()
93+ :<|> "deleteEmpty" :> Delete '[JSON] ()
9494 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
9595 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
9696 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
283283 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
284284
285285data WrappedApi where
286− WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,
286+ WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
287287 HasClient api, Client api ~ ExceptT ServantError IO ()) =>
288288 Proxy api -> WrappedApi
289289
servant-docs/src/Servant/Docs/Internal.hs+32−31
@@ -476,8 +476,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
476476
477477-- | Synthesise a sample value of a type, encoded in the specified media types.
478478sampleByteString
479− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
480− => Proxy ctypes
479+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
480+ => Proxy (ct ': cts)
481481 -> Proxy a
482482 -> [(M.MediaType, ByteString)]
483483sampleByteString ctypes@Proxy Proxy =
@@ -486,8 +486,8 @@ sampleByteString ctypes@Proxy Proxy =
486486-- | Synthesise a list of sample values of a particular type, encoded in the
487487-- specified media types.
488488sampleByteStrings
489− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
490− => Proxy ctypes
489+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
490+ => Proxy (ct ': cts)
491491 -> Proxy a
492492 -> [(Text, M.MediaType, ByteString)]
493493sampleByteStrings ctypes@Proxy Proxy =
@@ -689,21 +689,21 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
689689
690690
691691instance OVERLAPPABLE_
692− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
693− => HasDocs (Delete cts a) where
692+ (ToSample a, AllMimeRender (ct ': cts) a)
693+ => HasDocs (Delete (ct ': cts) a) where
694694 docsFor Proxy (endpoint, action) DocOptions{..} =
695695 single endpoint' action'
696696
697697 where endpoint' = endpoint & method .~ DocDELETE
698698 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
699699 & response.respTypes .~ allMime t
700− t = Proxy :: Proxy cts
700+ t = Proxy :: Proxy (ct ': cts)
701701 p = Proxy :: Proxy a
702702
703703instance OVERLAPPING_
704− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
704+ (ToSample a, AllMimeRender (ct ': cts) a
705705 , AllHeaderSamples ls , GetHeaders (HList ls) )
706− => HasDocs (Delete cts (Headers ls a)) where
706+ => HasDocs (Delete (ct ': cts) (Headers ls a)) where
707707 docsFor Proxy (endpoint, action) DocOptions{..} =
708708 single endpoint' action'
709709
@@ -712,25 +712,26 @@ instance OVERLAPPING_
712712 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
713713 & response.respTypes .~ allMime t
714714 & response.respHeaders .~ hdrs
715− t = Proxy :: Proxy cts
715+ t = Proxy :: Proxy (ct ': cts)
716716 p = Proxy :: Proxy a
717717
718718instance OVERLAPPABLE_
719− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
720− => HasDocs (Get cts a) where
719+ (ToSample a, AllMimeRender (ct ': cts) a)
720+ => HasDocs (Get (ct ': cts) a) where
721+>>>>>>> Simplify verb combinators.
721722 docsFor Proxy (endpoint, action) DocOptions{..} =
722723 single endpoint' action'
723724
724725 where endpoint' = endpoint & method .~ DocGET
725726 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
726727 & response.respTypes .~ allMime t
727− t = Proxy :: Proxy cts
728+ t = Proxy :: Proxy (ct ': cts)
728729 p = Proxy :: Proxy a
729730
730731instance OVERLAPPING_
731− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
732+ (ToSample a, AllMimeRender (ct ': cts) a
732733 , AllHeaderSamples ls , GetHeaders (HList ls) )
733− => HasDocs (Get cts (Headers ls a)) where
734+ => HasDocs (Get (ct ': cts) (Headers ls a)) where
734735 docsFor Proxy (endpoint, action) DocOptions{..} =
735736 single endpoint' action'
736737
@@ -739,7 +740,7 @@ instance OVERLAPPING_
739740 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
740741 & response.respTypes .~ allMime t
741742 & response.respHeaders .~ hdrs
742− t = Proxy :: Proxy cts
743+ t = Proxy :: Proxy (ct ': cts)
743744 p = Proxy :: Proxy a
744745
745746instance (KnownSymbol sym, HasDocs sublayout)
@@ -752,8 +753,8 @@ instance (KnownSymbol sym, HasDocs sublayout)
752753 headername = pack $ symbolVal (Proxy :: Proxy sym)
753754
754755instance OVERLAPPABLE_
755− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
756− => HasDocs (Post cts a) where
756+ (ToSample a, AllMimeRender (ct ': cts) a)
757+ => HasDocs (Post (ct ': cts) a) where
757758 docsFor Proxy (endpoint, action) DocOptions{..} =
758759 single endpoint' action'
759760
@@ -761,13 +762,13 @@ instance OVERLAPPABLE_
761762 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
762763 & response.respTypes .~ allMime t
763764 & response.respStatus .~ 201
764− t = Proxy :: Proxy cts
765+ t = Proxy :: Proxy (ct ': cts)
765766 p = Proxy :: Proxy a
766767
767768instance OVERLAPPING_
768− (ToSample a, IsNonEmpty cts, AllMimeRender cts a
769+ (ToSample a, AllMimeRender (ct ': cts) a
769770 , AllHeaderSamples ls , GetHeaders (HList ls) )
770− => HasDocs (Post cts (Headers ls a)) where
771+ => HasDocs (Post (ct ': cts) (Headers ls a)) where
771772 docsFor Proxy (endpoint, action) DocOptions{..} =
772773 single endpoint' action'
773774
@@ -777,12 +778,12 @@ instance OVERLAPPING_
777778 & response.respTypes .~ allMime t
778779 & response.respStatus .~ 201
779780 & response.respHeaders .~ hdrs
780− t = Proxy :: Proxy cts
781+ t = Proxy :: Proxy (ct ': cts)
781782 p = Proxy :: Proxy a
782783
783784instance OVERLAPPABLE_
784− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
785− => HasDocs (Put cts a) where
785+ (ToSample a, AllMimeRender (ct ': cts) a)
786+ => HasDocs (Put (ct ': cts) a) where
786787 docsFor Proxy (endpoint, action) DocOptions{..} =
787788 single endpoint' action'
788789
@@ -790,13 +791,13 @@ instance OVERLAPPABLE_
790791 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
791792 & response.respTypes .~ allMime t
792793 & response.respStatus .~ 200
793− t = Proxy :: Proxy cts
794+ t = Proxy :: Proxy (ct ': cts)
794795 p = Proxy :: Proxy a
795796
796797instance OVERLAPPING_
797− ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
798+ ( ToSample a, AllMimeRender (ct ': cts) a,
798799 AllHeaderSamples ls , GetHeaders (HList ls) )
799− => HasDocs (Put cts (Headers ls a)) where
800+ => HasDocs (Put (ct ': cts) (Headers ls a)) where
800801 docsFor Proxy (endpoint, action) DocOptions{..} =
801802 single endpoint' action'
802803
@@ -806,7 +807,7 @@ instance OVERLAPPING_
806807 & response.respTypes .~ allMime t
807808 & response.respStatus .~ 200
808809 & response.respHeaders .~ hdrs
809− t = Proxy :: Proxy cts
810+ t = Proxy :: Proxy (ct ': cts)
810811 p = Proxy :: Proxy a
811812
812813instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
@@ -849,8 +850,8 @@ instance HasDocs Raw where
849850-- example data. However, there's no reason to believe that the instances of
850851-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
851852-- both are even defined) for any particular type.
852−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
853− => HasDocs (ReqBody cts a :> sublayout) where
853+instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
854+ => HasDocs (ReqBody (ct ': cts) a :> sublayout) where
854855
855856 docsFor Proxy (endpoint, action) =
856857 docsFor sublayoutP (endpoint, action')
@@ -858,7 +859,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
858859 where sublayoutP = Proxy :: Proxy sublayout
859860 action' = action & rqbody .~ sampleByteString t p
860861 & rqtypes .~ allMime t
861− t = Proxy :: Proxy cts
862+ t = Proxy :: Proxy (ct ': cts)
862863 p = Proxy :: Proxy a
863864
864865instance (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
2121#if !MIN_VERSION_base(4,8,0)
2222import Control.Applicative ((<$>))
2323#endif
24−import Control.Monad.Trans.Except (ExceptT)
25−import qualified Data.ByteString as B
26−import qualified Data.ByteString.Lazy as BL
27−import qualified Data.Map as M
28−import Data.Maybe (fromMaybe, mapMaybe)
29−import Data.String (fromString)
30−import Data.String.Conversions (ConvertibleStrings, cs, (<>))
31−import Data.Text (Text)
24+import Control.Monad.Trans.Except (ExceptT)
25+import qualified Data.ByteString as B
26+import qualified Data.ByteString.Lazy as BL
27+import qualified Data.Map as M
28+import Data.Maybe (fromMaybe, mapMaybe)
29+import Data.String (fromString)
30+import Data.String.Conversions (cs, (<>))
31+import Data.Text (Text)
3232import Data.Typeable
33−import GHC.TypeLits (KnownSymbol, symbolVal)
34−import Network.HTTP.Types hiding (Header, ResponseHeaders)
35−import Network.Socket (SockAddr)
36−import Network.Wai (Application, lazyRequestBody,
37− rawQueryString, requestHeaders,
38− requestMethod, responseLBS, remoteHost,
39− isSecure, vault, httpVersion, Response,
40− Request, pathInfo)
33+import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
34+ symbolVal)
35+import Network.HTTP.Types hiding (Header, ResponseHeaders)
36+import Network.Socket (SockAddr)
37+import Network.Wai (Application, Request, Response,
38+ httpVersion, isSecure,
39+ lazyRequestBody, pathInfo,
40+ rawQueryString, remoteHost,
41+ requestHeaders, requestMethod,
42+ responseLBS, vault)
43+import Web.HttpApiData (FromHttpApiData)
44+import Web.HttpApiData.Internal (parseHeaderMaybe,
45+ parseQueryParamMaybe,
46+ parseUrlPieceMaybe)
47+
4148import Servant.API ((:<|>) (..), (:>), Capture,
42− Delete, Get, Header,
43− IsSecure(..), Patch, Post, Put,
49+ Verb, ReflectMethod(reflectMethod),
50+ IsSecure(..), Header,
4451 QueryFlag, QueryParam, QueryParams,
4552 Raw, RemoteHost, ReqBody, Vault)
4653import Servant.API.ContentTypes (AcceptHeader (..),
@@ -55,8 +62,6 @@ import Servant.Server.Internal.Router
5562import Servant.Server.Internal.RoutingApplication
5663import Servant.Server.Internal.ServantErr
5764
58−import Web.HttpApiData (FromHttpApiData)
59−import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
6065
6166class HasServer layout where
6267 type ServerT layout (m :: * -> *) :: *
@@ -129,12 +134,12 @@ allowedMethodHead method request = method == methodGet && requestMethod request
129134allowedMethod :: Method -> Request -> Bool
130135allowedMethod method request = allowedMethodHead method request || requestMethod request == method
131136
132−processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
133− => Maybe (a, BL.ByteString) -> Status -> Method
137+processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
134138 -> Maybe [(HeaderName, B.ByteString)]
135139 -> Request -> RouteResult Response
136140processMethodRouter handleA status method headers request = case handleA of
137141 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
142+ Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) ""
138143 Just (contentT, body) -> Route $ responseLBS status hdrs bdy
139144 where
140145 bdy = if allowedMethodHead method request then "" else body
@@ -160,7 +165,7 @@ methodRouter method proxy status action = LeafRouter route'
160165 | pathIsEmpty request =
161166 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
162167 in runAction (action `addMethodCheck` methodCheck method request
163− `addAcceptCheck` acceptCheck proxy accH
168+ `addAcceptCheck` acceptCheck proxy accH
164169 ) respond $ \ output -> do
165170 let handleA = handleAcceptH proxy (AcceptHeader accH) output
166171 processMethodRouter handleA status method Nothing request
@@ -176,95 +181,34 @@ methodRouterHeaders method proxy status action = LeafRouter route'
176181 | pathIsEmpty request =
177182 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
178183 in runAction (action `addMethodCheck` methodCheck method request
179− `addAcceptCheck` acceptCheck proxy accH
184+ `addAcceptCheck` acceptCheck proxy accH
180185 ) respond $ \ output -> do
181186 let headers = getHeaders output
182187 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
183188 processMethodRouter handleA status method (Just headers) request
184189 | otherwise = respond $ Fail err404
185190
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.
208191instance OVERLAPPABLE_
209− ( AllCTRender ctypes a
210− ) => HasServer (Delete ctypes a) where
211−
212− type ServerT (Delete ctypes a) m = m a
213−
214− route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
192+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
193+ ) => HasServer (Verb method status ctypes a) where
215194
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
220196
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)
222200
223−-- Add response headers
224201instance OVERLAPPING_
225− ( GetHeaders (Headers h v), AllCTRender ctypes v
226− ) => HasServer (Delete ctypes (Headers h v)) 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
202+instance
203+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
204+ , GetHeaders (Headers h a)
205+ ) => HasServer (Verb method status ctypes (Headers h a)) where
231206
232−-- | When implementing the handler for a 'Get' endpoint,
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
207+ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
247208
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)
268212
269213-- | If you use 'Header' in one of the endpoints for your API,
270214-- this automatically requires your server-side handler to be a function
@@ -297,113 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
297241 in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
298242 where str = fromString $ symbolVal (Proxy :: Proxy sym)
299243
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−
407244-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
408245-- this automatically requires your server-side handler to be a function
409246-- 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"
162162
163163 it "should continue when URLs don't match" $ do
164164 request methodPost "" [jsonCT, jsonAccept] jsonBody
165− `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }
165+ `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
166166
167167 it "should continue when methods don't match" $ do
168168 request methodGet "a" [jsonCT, jsonAccept] jsonBody
servant-server/test/Servant/Server/Internal/EnterSpec.hs+1−1
@@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do
5252
5353 it "allows running arbitrary monads" $ do
5454 get "int" `shouldRespondWith` "1797"
55− post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
55+ post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
5656
5757 with (return (serve combinedAPI combinedReaderServer)) $ do
5858 it "allows combnation of enters" $ do
servant-server/test/Servant/ServerSpec.hs+22−26
@@ -130,15 +130,21 @@ captureSpec = do
130130
131131
132132type GetApi = Get '[JSON] Person
133− :<|> "empty" :> Get '[] ()
134− :<|> "post" :> Post '[] ()
133+ :<|> "empty" :> Get '[JSON] ()
134+ :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ())
135+ :<|> "post" :> Post '[JSON] ()
136+
135137getApi :: Proxy GetApi
136138getApi = Proxy
137139
138140getSpec :: Spec
139141getSpec = do
140142 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+
142148 with (return $ serve getApi server) $ do
143149
144150 it "allows to GET a Person" $ do
@@ -150,8 +156,8 @@ getSpec = do
150156 post "/" "" `shouldRespondWith` 405
151157 post "/empty" "" `shouldRespondWith` 405
152158
153− it "returns 204 if the type is '()'" $ do
154− get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
159+ it "returns headers" $ do
160+ get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] }
155161
156162 it "returns 406 if the Accept header is not supported" $ do
157163 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
@@ -161,7 +167,10 @@ getSpec = do
161167headSpec :: Spec
162168headSpec = do
163169 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 ()
165174 with (return $ serve getApi server) $ do
166175
167176 it "allows to GET a Person" $ do
@@ -177,10 +186,6 @@ headSpec = do
177186 post "/" "" `shouldRespondWith` 405
178187 post "/empty" "" `shouldRespondWith` 405
179188
180− it "returns 204 if the type is '()'" $ do
181− response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
182− return response `shouldRespondWith` ""{ matchStatus = 204 }
183−
184189 it "returns 406 if the Accept header is not supported" $ do
185190 Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
186191 `shouldRespondWith` 406
@@ -272,7 +277,7 @@ queryParamSpec = do
272277type PostApi =
273278 ReqBody '[JSON] Person :> Post '[JSON] Integer
274279 :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
275− :<|> "empty" :> Post '[] ()
280+ :<|> "empty" :> Post '[JSON] ()
276281
277282postApi :: Proxy PostApi
278283postApi = Proxy
@@ -287,25 +292,22 @@ postSpec = do
287292
288293 it "allows to POST a Person" $ do
289294 post' "/" (encode alice) `shouldRespondWith` "42"{
290− matchStatus = 201
295+ matchStatus = 200
291296 }
292297
293298 it "allows alternative routes if all have request bodies" $ do
294299 post' "/bla" (encode alice) `shouldRespondWith` "42"{
295− matchStatus = 201
300+ matchStatus = 200
296301 }
297302
298303 it "handles trailing '/' gracefully" $ do
299304 post' "/bla/" (encode alice) `shouldRespondWith` "42"{
300− matchStatus = 201
305+ matchStatus = 200
301306 }
302307
303308 it "correctly rejects invalid request bodies with status 400" $ do
304309 post' "/" "some invalid body" `shouldRespondWith` 400
305310
306− it "returns 204 if the type is '()'" $ do
307− post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
308−
309311 it "responds with 415 if the request body media type is unsupported" $ do
310312 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
311313 , "application/nonsense")]
@@ -314,7 +316,7 @@ postSpec = do
314316type PutApi =
315317 ReqBody '[JSON] Person :> Put '[JSON] Integer
316318 :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
317− :<|> "empty" :> Put '[] ()
319+ :<|> "empty" :> Put '[JSON] ()
318320
319321putApi :: Proxy PutApi
320322putApi = Proxy
@@ -345,9 +347,6 @@ putSpec = do
345347 it "correctly rejects invalid request bodies with status 400" $ do
346348 put' "/" "some invalid body" `shouldRespondWith` 400
347349
348− it "returns 204 if the type is '()'" $ do
349− put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
350−
351350 it "responds with 415 if the request body media type is unsupported" $ do
352351 let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
353352 , "application/nonsense")]
@@ -356,7 +355,7 @@ putSpec = do
356355type PatchApi =
357356 ReqBody '[JSON] Person :> Patch '[JSON] Integer
358357 :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
359− :<|> "empty" :> Patch '[] ()
358+ :<|> "empty" :> Patch '[JSON] ()
360359
361360patchApi :: Proxy PatchApi
362361patchApi = Proxy
@@ -387,9 +386,6 @@ patchSpec = do
387386 it "correctly rejects invalid request bodies with status 400" $ do
388387 patch' "/" "some invalid body" `shouldRespondWith` 400
389388
390− it "returns 204 if the type is '()'" $ do
391− patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
392−
393389 it "responds with 415 if the request body media type is unsupported" $ do
394390 let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
395391 , "application/nonsense")]
@@ -505,7 +501,7 @@ responseHeadersSpec :: Spec
505501responseHeadersSpec = describe "ResponseHeaders" $ do
506502 with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
507503
508− let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
504+ let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)]
509505
510506 it "includes the headers in the response" $
511507 forM_ methods $ \(method, expected) ->
servant-server/test/Servant/Utils/StaticFilesSpec.hs+1−6
@@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)
1515import Test.Hspec (Spec, around_, describe, it)
1616import Test.Hspec.Wai (get, shouldRespondWith, with)
1717
18−import Servant.API (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 ((:>))
18+import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
2419import Servant.Server (Server, serve)
2520import Servant.ServerSpec (Person (Person))
2621import Servant.Utils.StaticFiles (serveDirectory)
servant/servant.cabal+1−5
@@ -29,14 +29,9 @@ library
2929 Servant.API.Alternative
3030 Servant.API.Capture
3131 Servant.API.ContentTypes
32− Servant.API.Delete
33− Servant.API.Get
3432 Servant.API.Header
3533 Servant.API.HttpVersion
3634 Servant.API.IsSecure
37− Servant.API.Patch
38− Servant.API.Post
39− Servant.API.Put
4035 Servant.API.QueryParam
4136 Servant.API.Raw
4237 Servant.API.RemoteHost
@@ -44,6 +39,7 @@ library
4439 Servant.API.ResponseHeaders
4540 Servant.API.Sub
4641 Servant.API.Vault
42+ Servant.API.Verbs
4743 Servant.Utils.Links
4844 build-depends:
4945 base >=4.7 && <5
servant/src/Servant/API.hs+6−17
@@ -25,16 +25,7 @@ module Servant.API (
2525 -- | Access the location for arbitrary data to be shared by applications and middleware
2626
2727 -- * Actual endpoints, distinguished by HTTP method
28− module Servant.API.Get,
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
28+ module Servant.API.Verbs,
3829
3930 -- * Content Types
4031 module Servant.API.ContentTypes,
@@ -64,14 +55,9 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
6455 MimeRender (..),
6556 MimeUnrender (..), OctetStream,
6657 PlainText, ToFormUrlEncoded (..))
67−import Servant.API.Delete (Delete)
68−import Servant.API.Get (Get)
6958import Servant.API.Header (Header (..))
7059import Servant.API.HttpVersion (HttpVersion (..))
7160import Servant.API.IsSecure (IsSecure (..))
72−import Servant.API.Patch (Patch)
73−import Servant.API.Post (Post)
74−import Servant.API.Put (Put)
7561import Servant.API.QueryParam (QueryFlag, QueryParam,
7662 QueryParams)
7763import Servant.API.Raw (Raw)
@@ -84,7 +70,10 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
8470 getHeadersHList, getResponse)
8571import Servant.API.Sub ((:>))
8672import 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)
8876import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
8977 URI (..), safeLink)
90−
78+import Web.HttpApiData (FromHttpApiData (..),
79+ ToHttpApiData (..))
servant/src/Servant/API/ContentTypes.hs+47−19
@@ -2,6 +2,7 @@
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE DeriveDataTypeable #-}
5+{-# LANGUAGE DeriveGeneric #-}
56{-# LANGUAGE FlexibleInstances #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE OverloadedStrings #-}
@@ -10,6 +11,9 @@
1011{-# LANGUAGE TypeFamilies #-}
1112{-# LANGUAGE TypeOperators #-}
1213{-# LANGUAGE UndecidableInstances #-}
14+#if !MIN_VERSION_base(4,8,0)
15+{-# LANGUAGE OverlappingInstances #-}
16+#endif
1317{-# OPTIONS_HADDOCK not-home #-}
1418
1519-- | A collection of basic Content-Types (also known as Internet Media
@@ -19,7 +23,7 @@
1923--
2024-- Content-Types are used in `ReqBody` and the method combinators:
2125--
22−-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book
26+-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
2327--
2428-- Meaning the endpoint accepts requests of Content-Type @application/json@
2529-- or @text/plain;charset-utf8@, and returns data in either one of those
@@ -62,7 +66,6 @@ module Servant.API.ContentTypes
6266 , AllMimeUnrender(..)
6367 , FromFormUrlEncoded(..)
6468 , ToFormUrlEncoded(..)
65− , IsNonEmpty
6669 , eitherDecodeLenient
6770 , canHandleAcceptH
6871 ) where
@@ -91,7 +94,7 @@ import qualified Data.Text.Encoding as TextS
9194import qualified Data.Text.Lazy as TextL
9295import qualified Data.Text.Lazy.Encoding as TextL
9396import Data.Typeable
94−import GHC.Exts (Constraint)
97+import GHC.Generics (Generic)
9598import qualified Network.HTTP.Media as M
9699import Network.URI (escapeURIString,
97100 isUnreserved, unEscapeString)
@@ -137,7 +140,7 @@ instance Accept OctetStream where
137140 contentType _ = "application" M.// "octet-stream"
138141
139142newtype AcceptHeader = AcceptHeader BS.ByteString
140− deriving (Eq, Show)
143+ deriving (Eq, Show, Read, Typeable, Generic)
141144
142145-- * Render (serializing)
143146
@@ -159,19 +162,22 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
159162class Accept ctype => MimeRender ctype a where
160163 mimeRender :: Proxy ctype -> a -> ByteString
161164
162−class (AllMimeRender list a) => AllCTRender (list :: [*]) a where
165+class (AllMime list) => AllCTRender (list :: [*]) a where
163166 -- If the Accept header can be matched, returns (Just) a tuple of the
164167 -- Content-Type and response (serialization of @a@ into the appropriate
165168 -- mimetype).
166169 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
167170
168−instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
171+instance
172+#if MIN_VERSION_base(4,8,0)
173+ {-# OVERLAPPABLE #-}
174+#endif
175+ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
169176 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
170− where pctyps = Proxy :: Proxy ctyps
177+ where pctyps = Proxy :: Proxy (ct ': cts)
171178 amrs = allMimeRender pctyps val
172179 lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
173180
174−
175181--------------------------------------------------------------------------
176182-- * Unrender
177183
@@ -199,14 +205,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
199205class Accept ctype => MimeUnrender ctype a where
200206 mimeUnrender :: Proxy ctype -> ByteString -> Either String a
201207
202−class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
208+class AllCTUnrender (list :: [*]) a where
203209 handleCTypeH :: Proxy list
204210 -> ByteString -- Content-Type header
205211 -> ByteString -- Request body
206212 -> Maybe (Either String a)
207213
208−instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
209− ) => AllCTUnrender ctyps a where
214+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
210215 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
211216 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
212217
@@ -247,8 +252,7 @@ instance ( MimeRender ctyp a
247252 where pctyp = Proxy :: Proxy ctyp
248253 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
249254
250−
251−instance AllMimeRender '[] a where
255+instance AllMimeRender '[] () where
252256 allMimeRender _ _ = []
253257
254258--------------------------------------------------------------------------
@@ -270,21 +274,25 @@ instance ( MimeUnrender ctyp a
270274 where pctyp = Proxy :: Proxy ctyp
271275 pctyps = Proxy :: Proxy ctyps
272276
273−type family IsNonEmpty (list :: [*]) :: Constraint where
274− IsNonEmpty (x ': xs) = ()
275−
276−
277277--------------------------------------------------------------------------
278278-- * MimeRender Instances
279279
280280-- | `encode`
281−instance ToJSON a => MimeRender JSON a where
281+instance
282+#if MIN_VERSION_base(4,8,0)
283+ {-# OVERLAPPABLE #-}
284+#endif
285+ ToJSON a => MimeRender JSON a where
282286 mimeRender _ = encode
283287
284288-- | @encodeFormUrlEncoded . toFormUrlEncoded@
285289-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
286290-- holds if every element of x is non-null (i.e., not @("", "")@)
287−instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
291+instance
292+#if MIN_VERSION_base(4,8,0)
293+ {-# OVERLAPPABLE #-}
294+#endif
295+ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
288296 mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
289297
290298-- | `TextL.encodeUtf8`
@@ -307,6 +315,26 @@ instance MimeRender OctetStream ByteString where
307315instance MimeRender OctetStream BS.ByteString where
308316 mimeRender _ = fromStrict
309317
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 _ _ = ""
310338
311339--------------------------------------------------------------------------
312340-- * 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 @@
7474-- >>> safeLink api bad_link
7575-- ...
7676-- 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))
7880-- (IsElem'
7981-- ("hello" :> Delete '[JSON] ())
8082-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
@@ -119,11 +121,7 @@ import Servant.API.Capture ( Capture )
119121import Servant.API.ReqBody ( ReqBody )
120122import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
121123import Servant.API.Header ( Header )
122−import Servant.API.Get ( Get )
123−import Servant.API.Post ( Post )
124−import Servant.API.Put ( Put )
125−import Servant.API.Patch ( Patch )
126−import Servant.API.Delete ( Delete )
124+import Servant.API.Verbs ( Verb )
127125import Servant.API.Sub ( type (:>) )
128126import Servant.API.Raw ( Raw )
129127import Servant.API.Alternative ( type (:<|>) )
@@ -177,11 +175,8 @@ type family IsElem endpoint api :: Constraint where
177175 IsElem sa (QueryParam x y :> sb) = IsElem sa sb
178176 IsElem sa (QueryParams x y :> sb) = IsElem sa sb
179177 IsElem sa (QueryFlag x :> sb) = IsElem sa sb
180− IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
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'
178+ IsElem (Verb m s ct typ) (Verb m s ct' typ)
179+ = IsSubList ct ct'
185180 IsElem e e = ()
186181 IsElem e a = IsElem' e a
187182
@@ -303,24 +298,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
303298 toLink _ = toLink (Proxy :: Proxy sub)
304299
305300-- Verb (terminal) instances
306−instance HasLink (Get y r) 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
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
301+instance HasLink (Verb m s ct a) where
302+ type MkLink (Verb m s ct a) = URI
324303 toLink _ = linkURI
325304
326305instance HasLink Raw where