git.iko.soy/typeable/servant
on master help sign in
Merge pull request #57 from haskell-servant/jkarni/pre-0.3
a058cd4Julian Arni
.gitignore+1
compare with master
unifiedsplit
@@ -21,3 +21,4 @@ cabal.config
21*.prof
21*.prof
22*.aux
22*.aux
23*.hp
23*.hp
24+Setup
scripts/shell.nix+1−3
@@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
13 ../servant-jquery {}) "--ghc-options=-Werror";
13 ../servant-jquery {}) "--ghc-options=-Werror";
14 servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
14 servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
15 {}) "--ghc-options=-Werror";
15 {}) "--ghc-options=-Werror";
16− servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
17− {}) "--ghc-options=-Werror";
18 };
16 };
19 };
17 };
20in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [
18in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [
21− servant servant-server servant-client servant-jquery servant-docs servant-examples
19+ servant servant-server servant-client servant-jquery servant-docs
22])
20])
scripts/start-sandbox.shnew file+30
@@ -0,0 +1,30 @@
1+#!/bin/bash -
2+#===============================================================================
3+#
4+# FILE: start-sandbox.sh
5+#
6+# USAGE: ./start-sandbox.sh
7+#
8+# DESCRIPTION: Create sandbox at top-level and add all packages as add-source
9+#
10+# REQUIREMENTS: bash >= 4
11+#===============================================================================
12+
13+set -o nounset
14+set -o errexit
15+
16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
17+SOURCES_TXT="$( dirname $DIR)/sources.txt"
18+CABAL=${CABAL:-cabal}
19+
20+declare -a SOURCES
21+readarray -t SOURCES < "$SOURCES_TXT"
22+
23+prepare_sandbox () {
24+ $CABAL sandbox init
25+ for s in ${SOURCES[@]} ; do
26+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)
27+ done
28+}
29+
30+prepare_sandbox
servant-blaze/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2015, Julian K. Arni
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
servant-blaze/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-blaze/servant-blaze.cabalnew file+28
@@ -0,0 +1,28 @@
1+-- Initial servant-blaze.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+name: servant-blaze
5+version: 0.1.0.0
6+synopsis: Blaze-html support for servant
7+-- description:
8+homepage: http://haskell-servant.github.io/
9+license: BSD3
10+license-file: LICENSE
11+author: Julian K. Arni
12+maintainer: jkarni@gmail.com
13+-- copyright:
14+category: Web
15+build-type: Simple
16+-- extra-source-files:
17+cabal-version: >=1.10
18+
19+library
20+ exposed-modules: Servant.HTML.Blaze
21+ -- other-modules:
22+ -- other-extensions:
23+ build-depends: base >=4.7 && <5
24+ , servant
25+ , http-media
26+ , blaze-html
27+ hs-source-dirs: src
28+ default-language: Haskell2010
servant-blaze/src/Servant/HTML/Blaze.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+#if !MIN_VERSION_base(4,8,0)
7+{-# LANGUAGE OverlappingInstances #-}
8+#endif
9+
10+-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s
11+-- `ToMarkup` class and `Html` datatype.
12+-- You should only need to import this module for it's instances and the
13+-- `HTML` datatype.:
14+--
15+-- >>> type Eg = Get '[HTML] a
16+--
17+-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.
18+module Servant.HTML.Blaze where
19+
20+import Data.Typeable (Typeable)
21+import qualified Network.HTTP.Media as M
22+import Servant.API (Accept (..), MimeRender (..))
23+import Text.Blaze.Html (Html, ToMarkup, toHtml)
24+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
25+
26+data HTML deriving Typeable
27+
28+-- | @text/plain;charset=utf-8@
29+instance Accept HTML where
30+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
31+
32+instance
33+#if MIN_VERSION_base(4,8,0)
34+ {-# OVERLAPPABLE #-}
35+#endif
36+ ToMarkup a => MimeRender HTML a where
37+ mimeRender _ = renderHtml . toHtml
38+
39+instance
40+#if MIN_VERSION_base(4,8,0)
41+ {-# OVERLAPPING #-}
42+#endif
43+ MimeRender HTML Html where
44+ mimeRender _ = renderHtml
45+
servant-client/CHANGELOG.md+1−1
@@ -7,7 +7,7 @@
7* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
7* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
8* Support for PATCH
8* Support for PATCH
9* Make () instances expect No Content status code, and not try to decode body.
9* Make () instances expect No Content status code, and not try to decode body.
10−* `Canonicalize` API types before generating client functions for them
10+* Add support for response headers
11
11
120.2.2
120.2.2
13-----
13-----
servant-client/src/Servant/Client.hs+104−43
@@ -16,11 +16,13 @@
16module Servant.Client
16module Servant.Client
17 ( client
17 ( client
18 , HasClient(..)
18 , HasClient(..)
19− , Client
20 , ServantError(..)
19 , ServantError(..)
21 , module Servant.Common.BaseUrl
20 , module Servant.Common.BaseUrl
22 ) where
21 ) where
23
22
23+#if !MIN_VERSION_base(4,8,0)
24+import Control.Applicative ((<$>))
25+#endif
24import Control.Monad
26import Control.Monad
25import Control.Monad.Trans.Either
27import Control.Monad.Trans.Either
26import Data.ByteString.Lazy (ByteString)
28import Data.ByteString.Lazy (ByteString)
@@ -32,8 +34,8 @@ import GHC.TypeLits
32import Network.HTTP.Client (Response)
34import Network.HTTP.Client (Response)
33import Network.HTTP.Media
35import Network.HTTP.Media
34import qualified Network.HTTP.Types as H
36import qualified Network.HTTP.Types as H
37+import qualified Network.HTTP.Types.Header as HTTP
35import Servant.API
38import Servant.API
36−import Servant.API.ContentTypes
37import Servant.Common.BaseUrl
39import Servant.Common.BaseUrl
38import Servant.Common.Req
40import Servant.Common.Req
39
41
@@ -50,17 +52,16 @@ import Servant.Common.Req
50-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
52-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
51-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
53-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
52-- > (getAllBooks :<|> postNewBook) = client myApi
54-- > (getAllBooks :<|> postNewBook) = client myApi
53−client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
55+client :: HasClient layout => Proxy layout -> Client layout
54−client p = clientWithRoute (canonicalize p) defReq
56+client p = clientWithRoute p defReq
55
57
56-- | This class lets us define how each API combinator
58-- | This class lets us define how each API combinator
57-- influences the creation of an HTTP request. It's mostly
59-- influences the creation of an HTTP request. It's mostly
58-- an internal class, you can just use 'client'.
60-- an internal class, you can just use 'client'.
59class HasClient layout where
61class HasClient layout where
60− type Client' layout :: *
62+ type Client layout :: *
61− clientWithRoute :: Proxy layout -> Req -> Client' layout
63+ clientWithRoute :: Proxy layout -> Req -> Client layout
62
64
63−type Client layout = Client' (Canonicalize layout)
64
65
65-- | A client querying function for @a ':<|>' b@ will actually hand you
66-- | A client querying function for @a ':<|>' b@ will actually hand you
66-- one function for querying @a@ and another one for querying @b@,
67-- one function for querying @a@ and another one for querying @b@,
@@ -76,7 +77,7 @@ type Client layout = Client' (Canonicalize layout)
76-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
77-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
77-- > (getAllBooks :<|> postNewBook) = client myApi
78-- > (getAllBooks :<|> postNewBook) = client myApi
78instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
79instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
79− type Client' (a :<|> b) = Client' a :<|> Client' b
80+ type Client (a :<|> b) = Client a :<|> Client b
80 clientWithRoute Proxy req =
81 clientWithRoute Proxy req =
81 clientWithRoute (Proxy :: Proxy a) req :<|>
82 clientWithRoute (Proxy :: Proxy a) req :<|>
82 clientWithRoute (Proxy :: Proxy b) req
83 clientWithRoute (Proxy :: Proxy b) req
@@ -103,8 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
103instance (KnownSymbol capture, ToText a, HasClient sublayout)
104instance (KnownSymbol capture, ToText a, HasClient sublayout)
104 => HasClient (Capture capture a :> sublayout) where
105 => HasClient (Capture capture a :> sublayout) where
105
106
106− type Client' (Capture capture a :> sublayout) =
107+ type Client (Capture capture a :> sublayout) =
107− a -> Client' sublayout
108+ a -> Client sublayout
108
109
109 clientWithRoute Proxy req val =
110 clientWithRoute Proxy req val =
110 clientWithRoute (Proxy :: Proxy sublayout) $
111 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -117,7 +118,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
117-- will just require an argument that specifies the scheme, host
118-- will just require an argument that specifies the scheme, host
118-- and port to send the request to.
119-- and port to send the request to.
119instance HasClient Delete where
120instance HasClient Delete where
120− type Client' Delete = BaseUrl -> EitherT ServantError IO ()
121+ type Client Delete = BaseUrl -> EitherT ServantError IO ()
121
122
122 clientWithRoute Proxy req host =
123 clientWithRoute Proxy req host =
123 void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
124 void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@@ -131,21 +132,36 @@ instance
131 {-# OVERLAPPABLE #-}
132 {-# OVERLAPPABLE #-}
132#endif
133#endif
133 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
134 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
134− type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
135+ type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
135 clientWithRoute Proxy req host =
136 clientWithRoute Proxy req host =
136− performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
137+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
137
138
138-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
139-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
139−-- HTTP header.
140+-- HTTP status.
140instance
141instance
141#if MIN_VERSION_base(4,8,0)
142#if MIN_VERSION_base(4,8,0)
142 {-# OVERLAPPING #-}
143 {-# OVERLAPPING #-}
143#endif
144#endif
144 HasClient (Get (ct ': cts) ()) where
145 HasClient (Get (ct ': cts) ()) where
145− type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
146+ type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
146 clientWithRoute Proxy req host =
147 clientWithRoute Proxy req host =
147 performRequestNoBody H.methodGet req [204] host
148 performRequestNoBody H.methodGet req [204] host
148
149
150+-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
151+-- corresponding headers.
152+instance
153+#if MIN_VERSION_base(4,8,0)
154+ {-# OVERLAPPING #-}
155+#endif
156+ ( MimeUnrender ct a, BuildHeadersTo ls
157+ ) => HasClient (Get (ct ': cts) (Headers ls a)) where
158+ type Client (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
159+ clientWithRoute Proxy req host = do
160+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host
161+ return $ Headers { getResponse = resp
162+ , getHeadersHList = buildHeadersTo hdrs
163+ }
164+
149-- | If you use a 'Header' in one of your endpoints in your API,
165-- | If you use a 'Header' in one of your endpoints in your API,
150-- the corresponding querying function will automatically take
166-- the corresponding querying function will automatically take
151-- an additional argument of the type specified by your 'Header',
167-- an additional argument of the type specified by your 'Header',
@@ -174,8 +190,8 @@ instance
174instance (KnownSymbol sym, ToText a, HasClient sublayout)
190instance (KnownSymbol sym, ToText a, HasClient sublayout)
175 => HasClient (Header sym a :> sublayout) where
191 => HasClient (Header sym a :> sublayout) where
176
192
177− type Client' (Header sym a :> sublayout) =
193+ type Client (Header sym a :> sublayout) =
178− Maybe a -> Client' sublayout
194+ Maybe a -> Client sublayout
179
195
180 clientWithRoute Proxy req mval =
196 clientWithRoute Proxy req mval =
181 clientWithRoute (Proxy :: Proxy sublayout) $
197 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -192,10 +208,10 @@ instance
192 {-# OVERLAPPABLE #-}
208 {-# OVERLAPPABLE #-}
193#endif
209#endif
194 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
210 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
195− type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
211+ type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
196
212
197 clientWithRoute Proxy req uri =
213 clientWithRoute Proxy req uri =
198− performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
214+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
199
215
200-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
216-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
201-- HTTP header.
217-- HTTP header.
@@ -204,10 +220,25 @@ instance
204 {-# OVERLAPPING #-}
220 {-# OVERLAPPING #-}
205#endif
221#endif
206 HasClient (Post (ct ': cts) ()) where
222 HasClient (Post (ct ': cts) ()) where
207− type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
223+ type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
208 clientWithRoute Proxy req host =
224 clientWithRoute Proxy req host =
209 void $ performRequestNoBody H.methodPost req [204] host
225 void $ performRequestNoBody H.methodPost req [204] host
210
226
227+-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
228+-- corresponding headers.
229+instance
230+#if MIN_VERSION_base(4,8,0)
231+ {-# OVERLAPPING #-}
232+#endif
233+ ( MimeUnrender ct a, BuildHeadersTo ls
234+ ) => HasClient (Post (ct ': cts) (Headers ls a)) where
235+ type Client (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
236+ clientWithRoute Proxy req host = do
237+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host
238+ return $ Headers { getResponse = resp
239+ , getHeadersHList = buildHeadersTo hdrs
240+ }
241+
211-- | If you have a 'Put' endpoint in your API, the client
242-- | If you have a 'Put' endpoint in your API, the client
212-- side querying function that is created when calling 'client'
243-- side querying function that is created when calling 'client'
213-- will just require an argument that specifies the scheme, host
244-- will just require an argument that specifies the scheme, host
@@ -217,10 +248,10 @@ instance
217 {-# OVERLAPPABLE #-}
248 {-# OVERLAPPABLE #-}
218#endif
249#endif
219 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
250 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
220− type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
251+ type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
221
252
222 clientWithRoute Proxy req host =
253 clientWithRoute Proxy req host =
223− performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
254+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
224
255
225-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
256-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
226-- HTTP header.
257-- HTTP header.
@@ -229,10 +260,25 @@ instance
229 {-# OVERLAPPING #-}
260 {-# OVERLAPPING #-}
230#endif
261#endif
231 HasClient (Put (ct ': cts) ()) where
262 HasClient (Put (ct ': cts) ()) where
232− type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
263+ type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
233 clientWithRoute Proxy req host =
264 clientWithRoute Proxy req host =
234 void $ performRequestNoBody H.methodPut req [204] host
265 void $ performRequestNoBody H.methodPut req [204] host
235
266
267+-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
268+-- corresponding headers.
269+instance
270+#if MIN_VERSION_base(4,8,0)
271+ {-# OVERLAPPING #-}
272+#endif
273+ ( MimeUnrender ct a, BuildHeadersTo ls
274+ ) => HasClient (Put (ct ': cts) (Headers ls a)) where
275+ type Client (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
276+ clientWithRoute Proxy req host = do
277+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host
278+ return $ Headers { getResponse = resp
279+ , getHeadersHList = buildHeadersTo hdrs
280+ }
281+
236-- | If you have a 'Patch' endpoint in your API, the client
282-- | If you have a 'Patch' endpoint in your API, the client
237-- side querying function that is created when calling 'client'
283-- side querying function that is created when calling 'client'
238-- will just require an argument that specifies the scheme, host
284-- will just require an argument that specifies the scheme, host
@@ -242,10 +288,10 @@ instance
242 {-# OVERLAPPABLE #-}
288 {-# OVERLAPPABLE #-}
243#endif
289#endif
244 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
290 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
245− type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
291+ type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
246
292
247 clientWithRoute Proxy req host =
293 clientWithRoute Proxy req host =
248− performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
294+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
249
295
250-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
296-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
251-- HTTP header.
297-- HTTP header.
@@ -254,10 +300,25 @@ instance
254 {-# OVERLAPPING #-}
300 {-# OVERLAPPING #-}
255#endif
301#endif
256 HasClient (Patch (ct ': cts) ()) where
302 HasClient (Patch (ct ': cts) ()) where
257− type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
303+ type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
258 clientWithRoute Proxy req host =
304 clientWithRoute Proxy req host =
259 void $ performRequestNoBody H.methodPatch req [204] host
305 void $ performRequestNoBody H.methodPatch req [204] host
260
306
307+-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
308+-- corresponding headers.
309+instance
310+#if MIN_VERSION_base(4,8,0)
311+ {-# OVERLAPPING #-}
312+#endif
313+ ( MimeUnrender ct a, BuildHeadersTo ls
314+ ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
315+ type Client (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
316+ clientWithRoute Proxy req host = do
317+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host
318+ return $ Headers { getResponse = resp
319+ , getHeadersHList = buildHeadersTo hdrs
320+ }
321+
261-- | If you use a 'QueryParam' in one of your endpoints in your API,
322-- | If you use a 'QueryParam' in one of your endpoints in your API,
262-- the corresponding querying function will automatically take
323-- the corresponding querying function will automatically take
263-- an additional argument of the type specified by your 'QueryParam',
324-- an additional argument of the type specified by your 'QueryParam',
@@ -286,8 +347,8 @@ instance
286instance (KnownSymbol sym, ToText a, HasClient sublayout)
347instance (KnownSymbol sym, ToText a, HasClient sublayout)
287 => HasClient (QueryParam sym a :> sublayout) where
348 => HasClient (QueryParam sym a :> sublayout) where
288
349
289− type Client' (QueryParam sym a :> sublayout) =
350+ type Client (QueryParam sym a :> sublayout) =
290− Maybe a -> Client' sublayout
351+ Maybe a -> Client sublayout
291
352
292 -- if mparam = Nothing, we don't add it to the query string
353 -- if mparam = Nothing, we don't add it to the query string
293 clientWithRoute Proxy req mparam =
354 clientWithRoute Proxy req mparam =
@@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
328instance (KnownSymbol sym, ToText a, HasClient sublayout)
389instance (KnownSymbol sym, ToText a, HasClient sublayout)
329 => HasClient (QueryParams sym a :> sublayout) where
390 => HasClient (QueryParams sym a :> sublayout) where
330
391
331− type Client' (QueryParams sym a :> sublayout) =
392+ type Client (QueryParams sym a :> sublayout) =
332− [a] -> Client' sublayout
393+ [a] -> Client sublayout
333
394
334 clientWithRoute Proxy req paramlist =
395 clientWithRoute Proxy req paramlist =
335 clientWithRoute (Proxy :: Proxy sublayout) $
396 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
363instance (KnownSymbol sym, HasClient sublayout)
424instance (KnownSymbol sym, HasClient sublayout)
364 => HasClient (QueryFlag sym :> sublayout) where
425 => HasClient (QueryFlag sym :> sublayout) where
365
426
366− type Client' (QueryFlag sym :> sublayout) =
427+ type Client (QueryFlag sym :> sublayout) =
367− Bool -> Client' sublayout
428+ Bool -> Client sublayout
368
429
369 clientWithRoute Proxy req flag =
430 clientWithRoute Proxy req flag =
370 clientWithRoute (Proxy :: Proxy sublayout) $
431 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout)
402instance (KnownSymbol sym, ToText a, HasClient sublayout)
463instance (KnownSymbol sym, ToText a, HasClient sublayout)
403 => HasClient (MatrixParam sym a :> sublayout) where
464 => HasClient (MatrixParam sym a :> sublayout) where
404
465
405− type Client' (MatrixParam sym a :> sublayout) =
466+ type Client (MatrixParam sym a :> sublayout) =
406− Maybe a -> Client' sublayout
467+ Maybe a -> Client sublayout
407
468
408 -- if mparam = Nothing, we don't add it to the query string
469 -- if mparam = Nothing, we don't add it to the query string
409 clientWithRoute Proxy req mparam =
470 clientWithRoute Proxy req mparam =
@@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
443instance (KnownSymbol sym, ToText a, HasClient sublayout)
504instance (KnownSymbol sym, ToText a, HasClient sublayout)
444 => HasClient (MatrixParams sym a :> sublayout) where
505 => HasClient (MatrixParams sym a :> sublayout) where
445
506
446− type Client' (MatrixParams sym a :> sublayout) =
507+ type Client (MatrixParams sym a :> sublayout) =
447− [a] -> Client' sublayout
508+ [a] -> Client sublayout
448
509
449 clientWithRoute Proxy req paramlist =
510 clientWithRoute Proxy req paramlist =
450 clientWithRoute (Proxy :: Proxy sublayout) $
511 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
478instance (KnownSymbol sym, HasClient sublayout)
539instance (KnownSymbol sym, HasClient sublayout)
479 => HasClient (MatrixFlag sym :> sublayout) where
540 => HasClient (MatrixFlag sym :> sublayout) where
480
541
481− type Client' (MatrixFlag sym :> sublayout) =
542+ type Client (MatrixFlag sym :> sublayout) =
482− Bool -> Client' sublayout
543+ Bool -> Client sublayout
483
544
484 clientWithRoute Proxy req flag =
545 clientWithRoute Proxy req flag =
485 clientWithRoute (Proxy :: Proxy sublayout) $
546 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -492,9 +553,9 @@ instance (KnownSymbol sym, HasClient sublayout)
492-- | Pick a 'Method' and specify where the server you want to query is. You get
553-- | Pick a 'Method' and specify where the server you want to query is. You get
493-- back the full `Response`.
554-- back the full `Response`.
494instance HasClient Raw where
555instance HasClient Raw where
495− type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
556+ type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
496
557
497− clientWithRoute :: Proxy Raw -> Req -> Client' Raw
558+ clientWithRoute :: Proxy Raw -> Req -> Client Raw
498 clientWithRoute Proxy req httpMethod host = do
559 clientWithRoute Proxy req httpMethod host = do
499 performRequest httpMethod req (const True) host
560 performRequest httpMethod req (const True) host
500
561
@@ -519,8 +580,8 @@ instance HasClient Raw where
519instance (MimeRender ct a, HasClient sublayout)
580instance (MimeRender ct a, HasClient sublayout)
520 => HasClient (ReqBody (ct ': cts) a :> sublayout) where
581 => HasClient (ReqBody (ct ': cts) a :> sublayout) where
521
582
522− type Client' (ReqBody (ct ': cts) a :> sublayout) =
583+ type Client (ReqBody (ct ': cts) a :> sublayout) =
523− a -> Client' sublayout
584+ a -> Client sublayout
524
585
525 clientWithRoute Proxy req body =
586 clientWithRoute Proxy req body =
526 clientWithRoute (Proxy :: Proxy sublayout) $ do
587 clientWithRoute (Proxy :: Proxy sublayout) $ do
@@ -529,7 +590,7 @@ instance (MimeRender ct a, HasClient sublayout)
529
590
530-- | Make the querying function append @path@ to the request path.
591-- | Make the querying function append @path@ to the request path.
531instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
592instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
532− type Client' (path :> sublayout) = Client' sublayout
593+ type Client (path :> sublayout) = Client sublayout
533
594
534 clientWithRoute Proxy req =
595 clientWithRoute Proxy req =
535 clientWithRoute (Proxy :: Proxy sublayout) $
596 clientWithRoute (Proxy :: Proxy sublayout) $
servant-client/src/Servant/Common/Req.hs+13−10
@@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)
22import Network.HTTP.Client.TLS
22import Network.HTTP.Client.TLS
23import Network.HTTP.Media
23import Network.HTTP.Media
24import Network.HTTP.Types
24import Network.HTTP.Types
25+import qualified Network.HTTP.Types.Header as HTTP
25import Network.URI
26import Network.URI
26import Servant.API.ContentTypes
27import Servant.API.ContentTypes
27import Servant.Common.BaseUrl
28import Servant.Common.BaseUrl
@@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
136displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
137displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
137
138
138
139
140+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl
139−performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
141+ -> EitherT ServantError IO ( Int, ByteString, MediaType
142+ , [HTTP.Header], Response ByteString)
140performRequest reqMethod req isWantedStatus reqHost = do
143performRequest reqMethod req isWantedStatus reqHost = do
141 partialRequest <- liftIO $ reqToRequest req reqHost
144 partialRequest <- liftIO $ reqToRequest req reqHost
142
145
@@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
154 Right response -> do
157 Right response -> do
155 let status = Client.responseStatus response
158 let status = Client.responseStatus response
156 body = Client.responseBody response
159 body = Client.responseBody response
160+ hrds = Client.responseHeaders response
157 status_code = statusCode status
161 status_code = statusCode status
158 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
162 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
159 Nothing -> pure $ "application"//"octet-stream"
163 Nothing -> pure $ "application"//"octet-stream"
@@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
162 Just t' -> pure t'
166 Just t' -> pure t'
163 unless (isWantedStatus status_code) $
167 unless (isWantedStatus status_code) $
164 left $ FailureResponse status ct body
168 left $ FailureResponse status ct body
165− return (status_code, body, ct, response)
169+ return (status_code, body, ct, hrds, response)
170+
166
171
167performRequestCT :: MimeUnrender ct result =>
172performRequestCT :: MimeUnrender ct result =>
168− Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result
173+ Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)
169performRequestCT ct reqMethod req wantedStatus reqHost = do
174performRequestCT ct reqMethod req wantedStatus reqHost = do
170 let acceptCT = contentType ct
175 let acceptCT = contentType ct
171− (_status, respBody, respCT, _response) <-
176+ (_status, respBody, respCT, hrds, _response) <-
172 performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
177 performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
173− unless (matches respCT (acceptCT)) $
174− left $ UnsupportedContentType respCT respBody
178+ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
175− either
179+ case mimeUnrender ct respBody of
176− (left . (\s -> DecodeFailure s respCT respBody))
180+ Left err -> left $ DecodeFailure err respCT respBody
177− return
181+ Right val -> return (hrds, val)
178− (mimeUnrender ct respBody)
179
182
180performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
183performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
181performRequestNoBody reqMethod req wantedStatus reqHost = do
184performRequestNoBody reqMethod req wantedStatus reqHost = do
servant-client/test/Servant/ClientSpec.hs+30−15
@@ -7,7 +7,7 @@
7{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
8{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
10−{-# OPTIONS_GHC -fcontext-stack=25 #-}
10+{-# OPTIONS_GHC -fcontext-stack=100 #-}
11{-# OPTIONS_GHC -fno-warn-orphans #-}
11{-# OPTIONS_GHC -fno-warn-orphans #-}
12module Servant.ClientSpec where
12module Servant.ClientSpec where
13
13
@@ -28,7 +28,8 @@ import qualified Data.Text as T
28import GHC.Generics
28import GHC.Generics
29import qualified Network.HTTP.Client as C
29import qualified Network.HTTP.Client as C
30import Network.HTTP.Media
30import Network.HTTP.Media
31−import Network.HTTP.Types
31+import Network.HTTP.Types hiding (Header)
32+import qualified Network.HTTP.Types as HTTP
32import Network.Socket
33import Network.Socket
33import Network.Wai hiding (Response)
34import Network.Wai hiding (Response)
34import Network.Wai.Handler.Warp
35import Network.Wai.Handler.Warp
@@ -74,6 +75,8 @@ instance Eq C.HttpException where
74alice :: Person
75alice :: Person
75alice = Person "Alice" 42
76alice = Person "Alice" 42
76
77
78+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
79+
77type Api =
80type Api =
78 "get" :> Get '[JSON] Person
81 "get" :> Get '[JSON] Person
79 :<|> "delete" :> Delete
82 :<|> "delete" :> Delete
@@ -93,6 +96,7 @@ type Api =
93 QueryFlag "third" :>
96 QueryFlag "third" :>
94 ReqBody '[JSON] [(String, [Rational])] :>
97 ReqBody '[JSON] [(String, [Rational])] :>
95 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
98 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
99+ :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
96api :: Proxy Api
100api :: Proxy Api
97api = Proxy
101api = Proxy
98
102
@@ -104,19 +108,20 @@ server = serve api (
104 :<|> return
108 :<|> return
105 :<|> (\ name -> case name of
109 :<|> (\ name -> case name of
106 Just "alice" -> return alice
110 Just "alice" -> return alice
107− Just name -> left (400, name ++ " not found")
111+ Just name -> left $ ServantErr 400 (name ++ " not found") "" []
108− Nothing -> left (400, "missing parameter"))
112+ Nothing -> left $ ServantErr 400 "missing parameter" "" [])
109 :<|> (\ names -> return (zipWith Person names [0..]))
113 :<|> (\ names -> return (zipWith Person names [0..]))
110 :<|> return
114 :<|> return
111 :<|> (\ name -> case name of
115 :<|> (\ name -> case name of
112 Just "alice" -> return alice
116 Just "alice" -> return alice
113− Just name -> left (400, name ++ " not found")
117+ Just name -> left $ ServantErr 400 (name ++ " not found") "" []
114− Nothing -> left (400, "missing parameter"))
118+ Nothing -> left $ ServantErr 400 "missing parameter" "" [])
115 :<|> (\ names -> return (zipWith Person names [0..]))
119 :<|> (\ names -> return (zipWith Person names [0..]))
116 :<|> return
120 :<|> return
117 :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
121 :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
118 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
122 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
119− :<|> \ a b c d -> return (a, b, c, d)
123+ :<|> (\ a b c d -> return (a, b, c, d))
124+ :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
120 )
125 )
121
126
122withServer :: (BaseUrl -> IO a) -> IO a
127withServer :: (BaseUrl -> IO a) -> IO a
@@ -132,11 +137,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
132getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
137getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
133getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
138getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
134getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
139getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
135−getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
140+getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
141+ MediaType, [HTTP.Header], C.Response ByteString)
136−getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
142+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
143+ MediaType, [HTTP.Header], C.Response ByteString)
137getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
144getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
138 -> BaseUrl
145 -> BaseUrl
139 -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
146 -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
147+getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
140( getGet
148( getGet
141 :<|> getDelete
149 :<|> getDelete
142 :<|> getCapture
150 :<|> getCapture
@@ -149,7 +157,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
149 :<|> getMatrixFlag
157 :<|> getMatrixFlag
150 :<|> getRawSuccess
158 :<|> getRawSuccess
151 :<|> getRawFailure
159 :<|> getRawFailure
152− :<|> getMultiple)
160+ :<|> getMultiple
161+ :<|> getRespHeaders)
153 = client api
162 = client api
154
163
155type FailApi =
164type FailApi =
@@ -218,7 +227,7 @@ spec = do
218 res <- runEitherT (getRawSuccess methodGet host)
227 res <- runEitherT (getRawSuccess methodGet host)
219 case res of
228 case res of
220 Left e -> assertFailure $ show e
229 Left e -> assertFailure $ show e
221− Right (code, body, ct, response) -> do
230+ Right (code, body, ct, _, response) -> do
222 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
231 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
223 C.responseBody response `shouldBe` body
232 C.responseBody response `shouldBe` body
224 C.responseStatus response `shouldBe` ok200
233 C.responseStatus response `shouldBe` ok200
@@ -227,11 +236,17 @@ spec = do
227 res <- runEitherT (getRawFailure methodGet host)
236 res <- runEitherT (getRawFailure methodGet host)
228 case res of
237 case res of
229 Left e -> assertFailure $ show e
238 Left e -> assertFailure $ show e
230− Right (code, body, ct, response) -> do
239+ Right (code, body, ct, _, response) -> do
231 (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
240 (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
232 C.responseBody response `shouldBe` body
241 C.responseBody response `shouldBe` body
233 C.responseStatus response `shouldBe` badRequest400
242 C.responseStatus response `shouldBe` badRequest400
234
243
244+ it "Returns headers appropriately" $ withServer $ \ host -> do
245+ res <- runEitherT (getRespHeaders host)
246+ case res of
247+ Left e -> assertFailure $ show e
248+ Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
249+
235 modifyMaxSuccess (const 20) $ do
250 modifyMaxSuccess (const 20) $ do
236 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
251 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
237 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
252 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@@ -246,7 +261,7 @@ spec = do
246 let test :: (WrappedApi, String) -> Spec
261 let test :: (WrappedApi, String) -> Spec
247 test (WrappedApi api, desc) =
262 test (WrappedApi api, desc) =
248 it desc $
263 it desc $
249− withWaiDaemon (return (serve api (left (500, "error message")))) $
264+ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
250 \ host -> do
265 \ host -> do
251 let getResponse :: BaseUrl -> EitherT ServantError IO ()
266 let getResponse :: BaseUrl -> EitherT ServantError IO ()
252 getResponse = client api
267 getResponse = client api
@@ -292,8 +307,8 @@ spec = do
292 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
307 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
293
308
294data WrappedApi where
309data WrappedApi where
295− WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
310+ WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
296− HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
311+ HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
297 Proxy api -> WrappedApi
312 Proxy api -> WrappedApi
298
313
299
314
servant-docs/CHANGELOG.md+3−1
@@ -5,7 +5,9 @@
5* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
5* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
6* Remove ToJSON superclass from ToSample
6* Remove ToJSON superclass from ToSample
7* Split out Internal module
7* Split out Internal module
8−* `Canonicalize` API types before generating the docs for them
8+* Add support for response headers
9+* Allow `ToSample` to return a different type than it's arguments
10+* Add Proxy argument to `ToSample`
9
11
100.3
120.3
11---
13---
servant-docs/example/greet.hs+7−4
@@ -53,14 +53,17 @@ instance ToParam (MatrixParam "lang" String) where
53 "Get the greeting message selected language. Default is en."
53 "Get the greeting message selected language. Default is en."
54 Normal
54 Normal
55
55
56−instance ToSample Greet where
56+instance ToSample Greet Greet where
57− toSample = Just $ Greet "Hello, haskeller!"
57+ toSample _ = Just $ Greet "Hello, haskeller!"
58
58
59− toSamples =
59+ toSamples _ =
60 [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
60 [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
61 , ("If you use ?capital=false", Greet "Hello, haskeller")
61 , ("If you use ?capital=false", Greet "Hello, haskeller")
62 ]
62 ]
63
63
64+instance ToSample Int Int where
65+ toSample _ = Just 1729
66+
64-- We define some introductory sections, these will appear at the top of the
67-- We define some introductory sections, these will appear at the top of the
65-- documentation.
68-- documentation.
66--
69--
@@ -84,7 +87,7 @@ type TestApi =
84
87
85 -- POST /greet with a Greet as JSON in the request body,
88 -- POST /greet with a Greet as JSON in the request body,
86 -- returns a Greet as JSON
89 -- returns a Greet as JSON
87− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
90+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)
88
91
89 -- DELETE /greet/:greetid
92 -- DELETE /greet/:greetid
90 :<|> "greet" :> Capture "greetid" Text :> Delete
93 :<|> "greet" :> Capture "greetid" Text :> Delete
servant-docs/servant-docs.cabal+4
@@ -32,8 +32,11 @@ library
32 build-depends:
32 build-depends:
33 base >=4.7 && <5
33 base >=4.7 && <5
34 , bytestring
34 , bytestring
35+ , bytestring-conversion
36+ , case-insensitive
35 , hashable
37 , hashable
36 , http-media >= 0.6
38 , http-media >= 0.6
39+ , http-types >= 0.7
37 , lens
40 , lens
38 , servant >= 0.2.1
41 , servant >= 0.2.1
39 , string-conversions
42 , string-conversions
@@ -50,6 +53,7 @@ executable greet-docs
50 build-depends:
53 build-depends:
51 base
54 base
52 , aeson
55 , aeson
56+ , bytestring-conversion
53 , lens
57 , lens
54 , servant
58 , servant
55 , servant-docs
59 , servant-docs
servant-docs/src/Servant/Docs.hs+3−3
@@ -77,10 +77,10 @@
77-- > "Get the greeting message selected language. Default is en."
77-- > "Get the greeting message selected language. Default is en."
78-- > Normal
78-- > Normal
79-- >
79-- >
80−-- > instance ToSample Greet where
80+-- > instance ToSample Greet Greet where
81−-- > toSample = Just $ Greet "Hello, haskeller!"
81+-- > toSample _ = Just $ Greet "Hello, haskeller!"
82-- >
82-- >
83−-- > toSamples =
83+-- > toSamples _ =
84-- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
84-- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
85-- > , ("If you use ?capital=false", Greet "Hello, haskeller")
85-- > , ("If you use ?capital=false", Greet "Hello, haskeller")
86-- > ]
86-- > ]
servant-docs/src/Servant/Docs/Internal.hs+142−43
@@ -1,17 +1,22 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#if !MIN_VERSION_base(4,8,0)
18+{-# LANGUAGE OverlappingInstances #-}
19+#endif
15module Servant.Docs.Internal where
20module Servant.Docs.Internal where
16
21
17#if !MIN_VERSION_base(4,8,0)
22#if !MIN_VERSION_base(4,8,0)
@@ -19,6 +24,7 @@ import Control.Applicative
19#endif
24#endif
20import Control.Lens
25import Control.Lens
21import Data.ByteString.Lazy.Char8 (ByteString)
26import Data.ByteString.Lazy.Char8 (ByteString)
27+import qualified Data.CaseInsensitive as CI
22import Data.Hashable
28import Data.Hashable
23import Data.HashMap.Strict (HashMap)
29import Data.HashMap.Strict (HashMap)
24import Data.List
30import Data.List
@@ -26,6 +32,7 @@ import Data.Maybe
26import Data.Monoid
32import Data.Monoid
27import Data.Ord (comparing)
33import Data.Ord (comparing)
28import Data.Proxy
34import Data.Proxy
35+import Data.ByteString.Conversion (ToByteString, toByteString)
29import Data.String.Conversions
36import Data.String.Conversions
30import Data.Text (Text, pack, unpack)
37import Data.Text (Text, pack, unpack)
31import GHC.Exts (Constraint)
38import GHC.Exts (Constraint)
@@ -38,6 +45,7 @@ import Servant.Utils.Links
38import qualified Data.HashMap.Strict as HM
45import qualified Data.HashMap.Strict as HM
39import qualified Data.Text as T
46import qualified Data.Text as T
40import qualified Network.HTTP.Media as M
47import qualified Network.HTTP.Media as M
48+import qualified Network.HTTP.Types as HTTP
41
49
42-- | Supported HTTP request methods
50-- | Supported HTTP request methods
43data Method = DocDELETE -- ^ the DELETE method
51data Method = DocDELETE -- ^ the DELETE method
@@ -191,9 +199,10 @@ data ParamKind = Normal | List | Flag
191-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
199-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
192-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
200-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
193data Response = Response
201data Response = Response
194− { _respStatus :: Int
202+ { _respStatus :: Int
195− , _respTypes :: [M.MediaType]
203+ , _respTypes :: [M.MediaType]
196− , _respBody :: [(Text, M.MediaType, ByteString)]
204+ , _respBody :: [(Text, M.MediaType, ByteString)]
205+ , _respHeaders :: [HTTP.Header]
197 } deriving (Eq, Ord, Show)
206 } deriving (Eq, Ord, Show)
198
207
199-- | Default response: status code 200, no response body.
208-- | Default response: status code 200, no response body.
@@ -205,7 +214,12 @@ data Response = Response
205-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
214-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
206-- > Response {_respStatus = 204, _respBody = Just "[]"}
215-- > Response {_respStatus = 204, _respBody = Just "[]"}
207defResponse :: Response
216defResponse :: Response
208−defResponse = Response 200 [] []
217+defResponse = Response
218+ { _respStatus = 200
219+ , _respTypes = []
220+ , _respBody = []
221+ , _respHeaders = []
222+ }
209
223
210-- | A datatype that represents everything that can happen
224-- | A datatype that represents everything that can happen
211-- at an endpoint, with its lenses:
225-- at an endpoint, with its lenses:
@@ -276,8 +290,8 @@ makeLenses ''Action
276
290
277-- | Generate the docs for a given API that implements 'HasDocs'. This is the
291-- | Generate the docs for a given API that implements 'HasDocs'. This is the
278-- default way to create documentation.
292-- default way to create documentation.
279−docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
293+docs :: HasDocs layout => Proxy layout -> API
280−docs p = docsFor (canonicalize p) (defEndpoint, defAction)
294+docs p = docsFor p (defEndpoint, defAction)
281
295
282-- | Closed type family, check if endpoint is exactly within API.
296-- | Closed type family, check if endpoint is exactly within API.
283
297
@@ -321,11 +335,7 @@ extraInfo p action =
321-- 'extraInfo'.
335-- 'extraInfo'.
322--
336--
323-- If you only want to add an introduction, use 'docsWithIntros'.
337-- If you only want to add an introduction, use 'docsWithIntros'.
324−docsWith :: HasDocs (Canonicalize layout)
338+docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
325− => [DocIntro]
326− -> ExtraInfo layout
327− -> Proxy layout
328− -> API
329docsWith intros (ExtraInfo endpoints) p =
339docsWith intros (ExtraInfo endpoints) p =
330 docs p & apiIntros <>~ intros
340 docs p & apiIntros <>~ intros
331 & apiEndpoints %~ HM.unionWith combineAction endpoints
341 & apiEndpoints %~ HM.unionWith combineAction endpoints
@@ -333,7 +343,7 @@ docsWith intros (ExtraInfo endpoints) p =
333
343
334-- | Generate the docs for a given API that implements 'HasDocs' with with any
344-- | Generate the docs for a given API that implements 'HasDocs' with with any
335-- number of introduction(s)
345-- number of introduction(s)
336−docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
346+docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
337docsWithIntros intros = docsWith intros mempty
347docsWithIntros intros = docsWith intros mempty
338
348
339-- | The class that abstracts away the impact of API combinators
349-- | The class that abstracts away the impact of API combinators
@@ -362,8 +372,8 @@ class HasDocs layout where
362-- > instance FromJSON Greet
372-- > instance FromJSON Greet
363-- > instance ToJSON Greet
373-- > instance ToJSON Greet
364-- >
374-- >
365−-- > instance ToSample Greet where
375+-- > instance ToSample Greet Greet where
366−-- > toSample = Just g
376+-- > toSample _ = Just g
367-- >
377-- >
368-- > where g = Greet "Hello, haskeller!"
378-- > where g = Greet "Hello, haskeller!"
369--
379--
@@ -371,34 +381,53 @@ class HasDocs layout where
371-- 'toSample': it lets you specify different responses along with
381-- 'toSample': it lets you specify different responses along with
372-- some context (as 'Text') that explains when you're supposed to
382-- some context (as 'Text') that explains when you're supposed to
373-- get the corresponding response.
383-- get the corresponding response.
374−class ToSample a where
384+class ToSample a b | a -> b where
375 {-# MINIMAL (toSample | toSamples) #-}
385 {-# MINIMAL (toSample | toSamples) #-}
376− toSample :: Maybe a
386+ toSample :: Proxy a -> Maybe b
377− toSample = snd <$> listToMaybe samples
387+ toSample _ = snd <$> listToMaybe samples
378− where samples = toSamples :: [(Text, a)]
388+ where samples = toSamples (Proxy :: Proxy a)
389+
390+ toSamples :: Proxy a -> [(Text, b)]
391+ toSamples _ = maybe [] (return . ("",)) s
392+ where s = toSample (Proxy :: Proxy a)
393+
394+instance ToSample a b => ToSample (Headers ls a) b where
395+ toSample _ = toSample (Proxy :: Proxy a)
396+ toSamples _ = toSamples (Proxy :: Proxy a)
397+
379
398
380− toSamples :: [(Text, a)]
399+class AllHeaderSamples ls where
381− toSamples = maybe [] (return . ("",)) s
400+ allHeaderToSample :: Proxy ls -> [HTTP.Header]
382− where s = toSample :: Maybe a
401+
402+instance AllHeaderSamples '[] where
403+ allHeaderToSample _ = []
404+
405+instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)
406+ => AllHeaderSamples (Header h l ': ls) where
407+ allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
408+ allHeaderToSample (Proxy :: Proxy ls)
409+ where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
410+ mkHeader (Just x) = (headerName, cs $ toByteString x)
411+ mkHeader Nothing = (headerName, "<no header sample provided>")
383
412
384-- | Synthesise a sample value of a type, encoded in the specified media types.
413-- | Synthesise a sample value of a type, encoded in the specified media types.
385sampleByteString
414sampleByteString
386− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
415+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
387 => Proxy ctypes
416 => Proxy ctypes
388 -> Proxy a
417 -> Proxy a
389 -> [(M.MediaType, ByteString)]
418 -> [(M.MediaType, ByteString)]
390sampleByteString ctypes@Proxy Proxy =
419sampleByteString ctypes@Proxy Proxy =
391− maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
420+ maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
392
421
393-- | Synthesise a list of sample values of a particular type, encoded in the
422-- | Synthesise a list of sample values of a particular type, encoded in the
394-- specified media types.
423-- specified media types.
395sampleByteStrings
424sampleByteStrings
396− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
425+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
397 => Proxy ctypes
426 => Proxy ctypes
398 -> Proxy a
427 -> Proxy a
399 -> [(Text, M.MediaType, ByteString)]
428 -> [(Text, M.MediaType, ByteString)]
400sampleByteStrings ctypes@Proxy Proxy =
429sampleByteStrings ctypes@Proxy Proxy =
401− let samples = toSamples :: [(Text, a)]
430+ let samples = toSamples (Proxy :: Proxy a)
402 enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
431 enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
403 in concatMap enc samples
432 in concatMap enc samples
404
433
@@ -580,6 +609,7 @@ markdown api = unlines $
580 "#### Response:" :
609 "#### Response:" :
581 "" :
610 "" :
582 ("- Status code " ++ show (resp ^. respStatus)) :
611 ("- Status code " ++ show (resp ^. respStatus)) :
612+ ("- Headers: " ++ show (resp ^. respHeaders)) :
583 "" :
613 "" :
584 formatTypes (resp ^. respTypes) ++
614 formatTypes (resp ^. respTypes) ++
585 bodies
615 bodies
@@ -630,7 +660,11 @@ instance HasDocs Delete where
630 action' = action & response.respBody .~ []
660 action' = action & response.respBody .~ []
631 & response.respStatus .~ 204
661 & response.respStatus .~ 204
632
662
663+instance
664+#if MIN_VERSION_base(4,8,0)
665+ {-# OVERLAPPABLe #-}
666+#endif
633−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
667+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
634 => HasDocs (Get cts a) where
668 => HasDocs (Get cts a) where
635 docsFor Proxy (endpoint, action) =
669 docsFor Proxy (endpoint, action) =
636 single endpoint' action'
670 single endpoint' action'
@@ -641,6 +675,24 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
641 t = Proxy :: Proxy cts
675 t = Proxy :: Proxy cts
642 p = Proxy :: Proxy a
676 p = Proxy :: Proxy a
643
677
678+instance
679+#if MIN_VERSION_base(4,8,0)
680+ {-# OVERLAPPING #-}
681+#endif
682+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
683+ , AllHeaderSamples ls , GetHeaders (HList ls) )
684+ => HasDocs (Get cts (Headers ls a)) where
685+ docsFor Proxy (endpoint, action) =
686+ single endpoint' action'
687+
688+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)
689+ endpoint' = endpoint & method .~ DocGET
690+ action' = action & response.respBody .~ sampleByteStrings t p
691+ & response.respTypes .~ supportedTypes t
692+ & response.respHeaders .~ hdrs
693+ t = Proxy :: Proxy cts
694+ p = Proxy :: Proxy a
695+
644instance (KnownSymbol sym, HasDocs sublayout)
696instance (KnownSymbol sym, HasDocs sublayout)
645 => HasDocs (Header sym a :> sublayout) where
697 => HasDocs (Header sym a :> sublayout) where
646 docsFor Proxy (endpoint, action) =
698 docsFor Proxy (endpoint, action) =
@@ -650,7 +702,11 @@ instance (KnownSymbol sym, HasDocs sublayout)
650 action' = over headers (|> headername) action
702 action' = over headers (|> headername) action
651 headername = pack $ symbolVal (Proxy :: Proxy sym)
703 headername = pack $ symbolVal (Proxy :: Proxy sym)
652
704
705+instance
706+#if MIN_VERSION_base(4,8,0)
707+ {-# OVERLAPPABLE #-}
708+#endif
653−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
709+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
654 => HasDocs (Post cts a) where
710 => HasDocs (Post cts a) where
655 docsFor Proxy (endpoint, action) =
711 docsFor Proxy (endpoint, action) =
656 single endpoint' action'
712 single endpoint' action'
@@ -662,7 +718,30 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
662 t = Proxy :: Proxy cts
718 t = Proxy :: Proxy cts
663 p = Proxy :: Proxy a
719 p = Proxy :: Proxy a
664
720
721+instance
722+#if MIN_VERSION_base(4,8,0)
723+ {-# OVERLAPPING #-}
724+#endif
665−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
725+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
726+ , AllHeaderSamples ls , GetHeaders (HList ls) )
727+ => HasDocs (Post cts (Headers ls a)) where
728+ docsFor Proxy (endpoint, action) =
729+ single endpoint' action'
730+
731+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)
732+ endpoint' = endpoint & method .~ DocPOST
733+ action' = action & response.respBody .~ sampleByteStrings t p
734+ & response.respTypes .~ supportedTypes t
735+ & response.respStatus .~ 201
736+ & response.respHeaders .~ hdrs
737+ t = Proxy :: Proxy cts
738+ p = Proxy :: Proxy a
739+
740+instance
741+#if MIN_VERSION_base(4,8,0)
742+ {-# OVERLAPPABLE #-}
743+#endif
744+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
666 => HasDocs (Put cts a) where
745 => HasDocs (Put cts a) where
667 docsFor Proxy (endpoint, action) =
746 docsFor Proxy (endpoint, action) =
668 single endpoint' action'
747 single endpoint' action'
@@ -674,6 +753,25 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
674 t = Proxy :: Proxy cts
753 t = Proxy :: Proxy cts
675 p = Proxy :: Proxy a
754 p = Proxy :: Proxy a
676
755
756+instance
757+#if MIN_VERSION_base(4,8,0)
758+ {-# OVERLAPPING #-}
759+#endif
760+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
761+ , AllHeaderSamples ls , GetHeaders (HList ls) )
762+ => HasDocs (Put cts (Headers ls a)) where
763+ docsFor Proxy (endpoint, action) =
764+ single endpoint' action'
765+
766+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)
767+ endpoint' = endpoint & method .~ DocPUT
768+ action' = action & response.respBody .~ sampleByteStrings t p
769+ & response.respTypes .~ supportedTypes t
770+ & response.respStatus .~ 200
771+ & response.respHeaders .~ hdrs
772+ t = Proxy :: Proxy cts
773+ p = Proxy :: Proxy a
774+
677instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
775instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
678 => HasDocs (QueryParam sym a :> sublayout) where
776 => HasDocs (QueryParam sym a :> sublayout) where
679
777
@@ -756,7 +854,8 @@ instance HasDocs Raw where
756-- example data. However, there's no reason to believe that the instances of
854-- example data. However, there's no reason to believe that the instances of
757-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
855-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
758-- both are even defined) for any particular type.
856-- both are even defined) for any particular type.
759−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
857+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout
858+ , SupportedTypes cts)
760 => HasDocs (ReqBody cts a :> sublayout) where
859 => HasDocs (ReqBody cts a :> sublayout) where
761
860
762 docsFor Proxy (endpoint, action) =
861 docsFor Proxy (endpoint, action) =
servant-docs/test/Servant/DocsSpec.hs+6−6
@@ -46,14 +46,14 @@ data Datatype1 = Datatype1 { dt1field1 :: String
46
46
47instance ToJSON Datatype1
47instance ToJSON Datatype1
48
48
49−instance ToSample Datatype1 where
49+instance ToSample Datatype1 Datatype1 where
50− toSample = Just $ Datatype1 "field 1" 13
50+ toSample _ = Just $ Datatype1 "field 1" 13
51
51
52−instance ToSample String where
52+instance ToSample String String where
53− toSample = Just "a string"
53+ toSample _ = Just "a string"
54
54
55−instance ToSample Int where
55+instance ToSample Int Int where
56− toSample = Just 17
56+ toSample _ = Just 17
57
57
58instance MimeRender PlainText Int where
58instance MimeRender PlainText Int where
59 mimeRender _ = cs . show
59 mimeRender _ = cs . show
servant-examples/auth-combinator/auth-combinator.hs+2−2
@@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password")
26data AuthProtected
26data AuthProtected
27
27
28instance HasServer rest => HasServer (AuthProtected :> rest) where
28instance HasServer rest => HasServer (AuthProtected :> rest) where
29− type ServerT' (AuthProtected :> rest) m = ServerT' rest m
29+ type ServerT (AuthProtected :> rest) m = ServerT rest m
30
30
31 route Proxy a request respond =
31 route Proxy a request respond =
32 case lookup "Cookie" (requestHeaders request) of
32 case lookup "Cookie" (requestHeaders request) of
@@ -75,4 +75,4 @@ $ curl -H "Cookie: good password" http://localhost:8080/private
75[{"ssshhh":"this is a secret"}]
75[{"ssshhh":"this is a secret"}]
76$ curl -H "Cookie: bad password" http://localhost:8080/private
76$ curl -H "Cookie: bad password" http://localhost:8080/private
77Invalid cookie.
77Invalid cookie.
78−-}
78+-}
servant-jquery/src/Servant/JQuery.hs+3−4
@@ -26,8 +26,8 @@ import Data.Proxy
26import Servant.API
26import Servant.API
27import Servant.JQuery.Internal
27import Servant.JQuery.Internal
28
28
29−jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
29+jquery :: HasJQ layout => Proxy layout -> JQ layout
30−jquery p = jqueryFor (canonicalize p) defReq
30+jquery p = jqueryFor p defReq
31
31
32-- js codegen
32-- js codegen
33generateJS :: AjaxReq -> String
33generateJS :: AjaxReq -> String
@@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
112-- | Directly generate all the javascript functions for your API
112-- | Directly generate all the javascript functions for your API
113-- from a 'Proxy' for your API type. You can then write it to
113-- from a 'Proxy' for your API type. You can then write it to
114-- a file or integrate it in a page, for example.
114-- a file or integrate it in a page, for example.
115−jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
115+jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
116− => Proxy api -> String
117jsForAPI p = jsFor (jquery p)
116jsForAPI p = jsFor (jquery p)
servant-jquery/src/Servant/JQuery/Internal.hs+18−20
@@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
194 Elem a (b ': list) = Elem a list
194 Elem a (b ': list) = Elem a list
195
195
196class HasJQ (layout :: *) where
196class HasJQ (layout :: *) where
197− type JQ' layout :: *
197+ type JQ layout :: *
198− jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
198+ jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
199−
200−type JQ layout = JQ' (Canonicalize layout)
201
199
202instance (HasJQ a, HasJQ b)
200instance (HasJQ a, HasJQ b)
203 => HasJQ (a :<|> b) where
201 => HasJQ (a :<|> b) where
204− type JQ' (a :<|> b) = JQ' a :<|> JQ' b
202+ type JQ (a :<|> b) = JQ a :<|> JQ b
205
203
206 jqueryFor Proxy req =
204 jqueryFor Proxy req =
207 jqueryFor (Proxy :: Proxy a) req
205 jqueryFor (Proxy :: Proxy a) req
@@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
209
207
210instance (KnownSymbol sym, HasJQ sublayout)
208instance (KnownSymbol sym, HasJQ sublayout)
211 => HasJQ (Capture sym a :> sublayout) where
209 => HasJQ (Capture sym a :> sublayout) where
212− type JQ' (Capture sym a :> sublayout) = JQ' sublayout
210+ type JQ (Capture sym a :> sublayout) = JQ sublayout
213
211
214 jqueryFor Proxy req =
212 jqueryFor Proxy req =
215 jqueryFor (Proxy :: Proxy sublayout) $
213 jqueryFor (Proxy :: Proxy sublayout) $
@@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
218 where str = symbolVal (Proxy :: Proxy sym)
216 where str = symbolVal (Proxy :: Proxy sym)
219
217
220instance HasJQ Delete where
218instance HasJQ Delete where
221− type JQ' Delete = AjaxReq
219+ type JQ Delete = AjaxReq
222
220
223 jqueryFor Proxy req =
221 jqueryFor Proxy req =
224 req & funcName %~ ("delete" <>)
222 req & funcName %~ ("delete" <>)
225 & reqMethod .~ "DELETE"
223 & reqMethod .~ "DELETE"
226
224
227instance Elem JSON list => HasJQ (Get list a) where
225instance Elem JSON list => HasJQ (Get list a) where
228− type JQ' (Get list a) = AjaxReq
226+ type JQ (Get list a) = AjaxReq
229
227
230 jqueryFor Proxy req =
228 jqueryFor Proxy req =
231 req & funcName %~ ("get" <>)
229 req & funcName %~ ("get" <>)
@@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
233
231
234instance (KnownSymbol sym, HasJQ sublayout)
232instance (KnownSymbol sym, HasJQ sublayout)
235 => HasJQ (Header sym a :> sublayout) where
233 => HasJQ (Header sym a :> sublayout) where
236− type JQ' (Header sym a :> sublayout) = JQ' sublayout
234+ type JQ (Header sym a :> sublayout) = JQ sublayout
237
235
238 jqueryFor Proxy req =
236 jqueryFor Proxy req =
239 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
237 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
@@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
242 subP = Proxy :: Proxy sublayout
240 subP = Proxy :: Proxy sublayout
243
241
244instance Elem JSON list => HasJQ (Post list a) where
242instance Elem JSON list => HasJQ (Post list a) where
245− type JQ' (Post list a) = AjaxReq
243+ type JQ (Post list a) = AjaxReq
246
244
247 jqueryFor Proxy req =
245 jqueryFor Proxy req =
248 req & funcName %~ ("post" <>)
246 req & funcName %~ ("post" <>)
249 & reqMethod .~ "POST"
247 & reqMethod .~ "POST"
250
248
251instance Elem JSON list => HasJQ (Put list a) where
249instance Elem JSON list => HasJQ (Put list a) where
252− type JQ' (Put list a) = AjaxReq
250+ type JQ (Put list a) = AjaxReq
253
251
254 jqueryFor Proxy req =
252 jqueryFor Proxy req =
255 req & funcName %~ ("put" <>)
253 req & funcName %~ ("put" <>)
@@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
257
255
258instance (KnownSymbol sym, HasJQ sublayout)
256instance (KnownSymbol sym, HasJQ sublayout)
259 => HasJQ (QueryParam sym a :> sublayout) where
257 => HasJQ (QueryParam sym a :> sublayout) where
260− type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
258+ type JQ (QueryParam sym a :> sublayout) = JQ sublayout
261
259
262 jqueryFor Proxy req =
260 jqueryFor Proxy req =
263 jqueryFor (Proxy :: Proxy sublayout) $
261 jqueryFor (Proxy :: Proxy sublayout) $
@@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
267
265
268instance (KnownSymbol sym, HasJQ sublayout)
266instance (KnownSymbol sym, HasJQ sublayout)
269 => HasJQ (QueryParams sym a :> sublayout) where
267 => HasJQ (QueryParams sym a :> sublayout) where
270− type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
268+ type JQ (QueryParams sym a :> sublayout) = JQ sublayout
271
269
272 jqueryFor Proxy req =
270 jqueryFor Proxy req =
273 jqueryFor (Proxy :: Proxy sublayout) $
271 jqueryFor (Proxy :: Proxy sublayout) $
@@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
277
275
278instance (KnownSymbol sym, HasJQ sublayout)
276instance (KnownSymbol sym, HasJQ sublayout)
279 => HasJQ (QueryFlag sym :> sublayout) where
277 => HasJQ (QueryFlag sym :> sublayout) where
280− type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
278+ type JQ (QueryFlag sym :> sublayout) = JQ sublayout
281
279
282 jqueryFor Proxy req =
280 jqueryFor Proxy req =
283 jqueryFor (Proxy :: Proxy sublayout) $
281 jqueryFor (Proxy :: Proxy sublayout) $
@@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
287
285
288instance (KnownSymbol sym, HasJQ sublayout)
286instance (KnownSymbol sym, HasJQ sublayout)
289 => HasJQ (MatrixParam sym a :> sublayout) where
287 => HasJQ (MatrixParam sym a :> sublayout) where
290− type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
288+ type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
291
289
292 jqueryFor Proxy req =
290 jqueryFor Proxy req =
293 jqueryFor (Proxy :: Proxy sublayout) $
291 jqueryFor (Proxy :: Proxy sublayout) $
@@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
298
296
299instance (KnownSymbol sym, HasJQ sublayout)
297instance (KnownSymbol sym, HasJQ sublayout)
300 => HasJQ (MatrixParams sym a :> sublayout) where
298 => HasJQ (MatrixParams sym a :> sublayout) where
301− type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
299+ type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
302
300
303 jqueryFor Proxy req =
301 jqueryFor Proxy req =
304 jqueryFor (Proxy :: Proxy sublayout) $
302 jqueryFor (Proxy :: Proxy sublayout) $
@@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
308
306
309instance (KnownSymbol sym, HasJQ sublayout)
307instance (KnownSymbol sym, HasJQ sublayout)
310 => HasJQ (MatrixFlag sym :> sublayout) where
308 => HasJQ (MatrixFlag sym :> sublayout) where
311− type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
309+ type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
312
310
313 jqueryFor Proxy req =
311 jqueryFor Proxy req =
314 jqueryFor (Proxy :: Proxy sublayout) $
312 jqueryFor (Proxy :: Proxy sublayout) $
@@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
317 where str = symbolVal (Proxy :: Proxy sym)
315 where str = symbolVal (Proxy :: Proxy sym)
318
316
319instance HasJQ Raw where
317instance HasJQ Raw where
320− type JQ' Raw = Method -> AjaxReq
318+ type JQ Raw = Method -> AjaxReq
321
319
322 jqueryFor Proxy req method =
320 jqueryFor Proxy req method =
323 req & funcName %~ ((toLower <$> method) <>)
321 req & funcName %~ ((toLower <$> method) <>)
324 & reqMethod .~ method
322 & reqMethod .~ method
325
323
326instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
324instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
327− type JQ' (ReqBody list a :> sublayout) = JQ' sublayout
325+ type JQ (ReqBody list a :> sublayout) = JQ sublayout
328
326
329 jqueryFor Proxy req =
327 jqueryFor Proxy req =
330 jqueryFor (Proxy :: Proxy sublayout) $
328 jqueryFor (Proxy :: Proxy sublayout) $
@@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
332
330
333instance (KnownSymbol path, HasJQ sublayout)
331instance (KnownSymbol path, HasJQ sublayout)
334 => HasJQ (path :> sublayout) where
332 => HasJQ (path :> sublayout) where
335− type JQ' (path :> sublayout) = JQ' sublayout
333+ type JQ (path :> sublayout) = JQ sublayout
336
334
337 jqueryFor Proxy req =
335 jqueryFor Proxy req =
338 jqueryFor (Proxy :: Proxy sublayout) $
336 jqueryFor (Proxy :: Proxy sublayout) $
servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs+3−3
@@ -22,7 +22,7 @@ data Authorization (sym :: Symbol) a
22
22
23instance (KnownSymbol sym, HasJQ sublayout)
23instance (KnownSymbol sym, HasJQ sublayout)
24 => HasJQ (Authorization sym a :> sublayout) where
24 => HasJQ (Authorization sym a :> sublayout) where
25− type JQ' (Authorization sym a :> sublayout) = JQ' sublayout
25+ type JQ (Authorization sym a :> sublayout) = JQ sublayout
26
26
27 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
27 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
28 req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
28 req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
@@ -35,7 +35,7 @@ data MyLovelyHorse a
35
35
36instance (HasJQ sublayout)
36instance (HasJQ sublayout)
37 => HasJQ (MyLovelyHorse a :> sublayout) where
37 => HasJQ (MyLovelyHorse a :> sublayout) where
38− type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout
38+ type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout
39
39
40 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
40 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
41 req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
41 req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
@@ -47,7 +47,7 @@ data WhatsForDinner a
47
47
48instance (HasJQ sublayout)
48instance (HasJQ sublayout)
49 => HasJQ (WhatsForDinner a :> sublayout) where
49 => HasJQ (WhatsForDinner a :> sublayout) where
50− type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout
50+ type JQ (WhatsForDinner a :> sublayout) = JQ sublayout
51
51
52 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
52 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
53 req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]
53 req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]
servant-lucid/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2015, Julian K. Arni
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
servant-lucid/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-lucid/servant-lucid.cabalnew file+28
@@ -0,0 +1,28 @@
1+-- Initial servant-lucid.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+name: servant-lucid
5+version: 0.1.0.0
6+synopsis: Servant support for lucid
7+-- description:
8+homepage: http://haskell-servant.github.io/
9+license: BSD3
10+license-file: LICENSE
11+author: Julian K. Arni
12+maintainer: jkarni@gmail.com
13+-- copyright:
14+category: Web
15+build-type: Simple
16+-- extra-source-files:
17+cabal-version: >=1.10
18+
19+library
20+ exposed-modules: Servant.HTML.Lucid
21+ -- other-modules:
22+ -- other-extensions:
23+ build-depends: base >=4.7 && <5
24+ , http-media
25+ , lucid
26+ , servant
27+ hs-source-dirs: src
28+ default-language: Haskell2010
servant-lucid/src/Servant/HTML/Lucid.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+#if !MIN_VERSION_base(4,8,0)
7+{-# LANGUAGE OverlappingInstances #-}
8+#endif
9+
10+-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
11+-- `ToHtml` class and `Html` datatype.
12+-- You should only need to import this module for it's instances and the
13+-- `HTML` datatype.:
14+--
15+-- >>> type Eg = Get '[HTML] a
16+--
17+-- Will then check that @a@ has a `ToHtml` instance, or is `Html`.
18+module Servant.HTML.Lucid where
19+
20+import Data.Typeable (Typeable)
21+import Lucid (Html, ToHtml (..), renderBS)
22+import qualified Network.HTTP.Media as M
23+import Servant.API (Accept (..), MimeRender (..))
24+
25+data HTML deriving Typeable
26+
27+-- | @text/plain;charset=utf-8@
28+instance Accept HTML where
29+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
30+
31+instance
32+#if MIN_VERSION_base(4,8,0)
33+ {-# OVERLAPPABLE #-}
34+#endif
35+ ToHtml a => MimeRender HTML a where
36+ mimeRender _ = renderBS . toHtml
37+
38+instance
39+#if MIN_VERSION_base(4,8,0)
40+ {-# OVERLAPPING #-}
41+#endif
42+ MimeRender HTML (Html a) where
43+ mimeRender _ = renderBS
servant-server/CHANGELOG.md+3−1
@@ -5,9 +5,11 @@
5* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
5* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
6* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
6* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
7* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
7* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
8−* Canonicalize API types before generating the handler types with `Server`
9* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
8* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
10* Add server support for response headers
9* Add server support for response headers
10+* Use `ServantErr` instead of `(Int,String)` in `EitherT` handlers
11+* Add `errXXX` functions for HTTP errors with sensible default reason strings
12+* Add `enter` function for applying natural transformations to handlers
11
13
120.2.4
140.2.4
13-----
15-----
servant-server/servant-server.cabal+16
@@ -36,6 +36,8 @@ library
36 Servant
36 Servant
37 Servant.Server
37 Servant.Server
38 Servant.Server.Internal
38 Servant.Server.Internal
39+ Servant.Server.Internal.ServantErr
40+ Servant.Server.Internal.Enter
39 Servant.Utils.StaticFiles
41 Servant.Utils.StaticFiles
40 build-depends:
42 build-depends:
41 base >= 4.7 && < 5
43 base >= 4.7 && < 5
@@ -45,6 +47,8 @@ library
45 , either >= 4.3 && < 4.4
47 , either >= 4.3 && < 4.4
46 , http-types >= 0.8 && < 0.9
48 , http-types >= 0.8 && < 0.9
47 , network-uri >= 2.6 && < 2.7
49 , network-uri >= 2.6 && < 2.7
50+ , mtl >= 2 && < 3
51+ , mmorph >= 1
48 , safe >= 0.3 && < 0.4
52 , safe >= 0.3 && < 0.4
49 , servant >= 0.2 && < 0.4
53 , servant >= 0.2 && < 0.4
50 , split >= 0.2 && < 0.3
54 , split >= 0.2 && < 0.3
@@ -100,6 +104,18 @@ test-suite spec
100 , temporary
104 , temporary
101 , text
105 , text
102 , transformers
106 , transformers
107+ , mtl
103 , wai
108 , wai
104 , wai-extra
109 , wai-extra
105 , warp
110 , warp
111+
112+test-suite doctests
113+ build-depends: base
114+ , servant
115+ , doctest
116+ , filemanip
117+ type: exitcode-stdio-1.0
118+ main-is: test/Doctests.hs
119+ buildable: True
120+ default-language: Haskell2010
121+ ghc-options: -threaded
servant-server/src/Servant/Server.hs+95−9
@@ -1,6 +1,7 @@
1−{-# LANGUAGE TypeFamilies #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeFamilies #-}
4
5
5-- | This module lets you implement 'Server's for defined APIs. You'll
6-- | This module lets you implement 'Server's for defined APIs. You'll
6-- most likely just need 'serve'.
7-- most likely just need 'serve'.
@@ -14,13 +15,73 @@ module Servant.Server
14 , -- * Handlers for all standard combinators
15 , -- * Handlers for all standard combinators
15 HasServer(..)
16 HasServer(..)
16 , Server
17 , Server
17− , ServerT
18+
19+ -- * Enter
20+ -- $enterDoc
21+
22+ -- ** Basic functions and datatypes
23+ , enter
24+ , (:~>)(..)
25+ -- ** `Nat` utilities
26+ , liftNat
27+ , runReaderTNat
28+ , evalStateTLNat
29+ , evalStateTSNat
30+ , logWriterTLNat
31+ , logWriterTSNat
32+#if MIN_VERSION_mtl(2,2,1)
33+ , fromExceptT
34+#endif
35+ -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
36+ , hoistNat
37+ , embedNat
38+ , squashNat
39+ , generalizeNat
40+
41+
42+ -- * Default error type
43+ , ServantErr(..)
44+ -- ** 3XX
45+ , err300
46+ , err301
47+ , err302
48+ , err303
49+ , err304
50+ , err305
51+ , err307
52+ -- ** 4XX
53+ , err400
54+ , err401
55+ , err402
56+ , err403
57+ , err404
58+ , err405
59+ , err406
60+ , err407
61+ , err409
62+ , err410
63+ , err411
64+ , err412
65+ , err413
66+ , err414
67+ , err415
68+ , err416
69+ , err417
70+ -- * 5XX
71+ , err500
72+ , err501
73+ , err502
74+ , err503
75+ , err504
76+ , err505
77+
18 ) where
78 ) where
19
79
20−import Data.Proxy (Proxy)
80+import Data.Proxy (Proxy)
21−import Network.Wai (Application)
81+import Network.Wai (Application)
22−import Servant.API (Canonicalize, canonicalize)
82+import Servant.Server.Internal
23−import Servant.Server.Internal
83+import Servant.Server.Internal.Enter
84+import Servant.Server.Internal.ServantErr
24
85
25
86
26-- * Implementing Servers
87-- * Implementing Servers
@@ -45,5 +106,30 @@ import Servant.Server.Internal
45-- >
106-- >
46-- > main :: IO ()
107-- > main :: IO ()
47-- > main = Network.Wai.Handler.Warp.run 8080 app
108-- > main = Network.Wai.Handler.Warp.run 8080 app
109+--
48−serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
110+serve :: HasServer layout => Proxy layout -> Server layout -> Application
49−serve p server = toApplication (route (canonicalize p) server)
111+serve p server = toApplication (route p server)
112+
113+
114+-- Documentation
115+
116+-- $enterDoc
117+-- Sometimes our cherished `EitherT` monad isn't quite the type you'd like for
118+-- your handlers. Maybe you want to thread some configuration in a @Reader@
119+-- monad. Or have your types ensure that your handlers don't do any IO. Enter
120+-- `enter`.
121+--
122+-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat`
123+-- newtype, to convert any number of endpoints from one type constructor to
124+-- another. For example
125+--
126+-- >>> import Control.Monad.Reader
127+-- >>> import qualified Control.Category as C
128+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
129+-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
130+-- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI
131+--
132+
133+-- $setup
134+-- >>> import Servant.API
135+-- >>> import Servant.Server
servant-server/src/Servant/Server/Internal.hs+64−73
@@ -38,7 +38,7 @@ import Network.Wai (Application, Request, Response,
38 requestMethod, responseLBS,
38 requestMethod, responseLBS,
39 strictRequestBody)
39 strictRequestBody)
40import Servant.API ((:<|>) (..), (:>), Capture,
40import Servant.API ((:<|>) (..), (:>), Capture,
41− Canonicalize, Delete, Get, Header,
41+ Delete, Get, Header,
42 MatrixFlag, MatrixParam, MatrixParams,
42 MatrixFlag, MatrixParam, MatrixParams,
43 Patch, Post, Put, QueryFlag,
43 Patch, Post, Put, QueryFlag,
44 QueryParam, QueryParams, Raw,
44 QueryParam, QueryParams, Raw,
@@ -46,9 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Capture,
46import Servant.API.ContentTypes (AcceptHeader (..),
46import Servant.API.ContentTypes (AcceptHeader (..),
47 AllCTRender (..),
47 AllCTRender (..),
48 AllCTUnrender (..))
48 AllCTUnrender (..))
49−import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
49+import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
50+ getHeaders)
50import Servant.Common.Text (FromText, fromText)
51import Servant.Common.Text (FromText, fromText)
51
52
53+import Servant.Server.Internal.ServantErr
54+
52data ReqBodyState = Uncalled
55data ReqBodyState = Uncalled
53 | Called !B.ByteString
56 | Called !B.ByteString
54 | Done !B.ByteString
57 | Done !B.ByteString
@@ -174,13 +177,11 @@ processedPathInfo r =
174 where pinfo = parsePathInfo r
177 where pinfo = parsePathInfo r
175
178
176class HasServer layout where
179class HasServer layout where
177− type ServerT' layout (m :: * -> *) :: *
180+ type ServerT layout (m :: * -> *) :: *
178
181
179− route :: Proxy layout -> Server' layout -> RoutingApplication
182+ route :: Proxy layout -> Server layout -> RoutingApplication
180
183
181−type Server layout = Server' (Canonicalize layout)
182−type Server' layout = ServerT' layout (EitherT (Int, String) IO)
184+type Server layout = ServerT layout (EitherT ServantErr IO)
183−type ServerT layout m = ServerT' (Canonicalize layout) m
184
185
185-- * Instances
186-- * Instances
186
187
@@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
197-- > postBook book = ...
198-- > postBook book = ...
198instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
199instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
199
200
200− type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
201+ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
201
202
202 route Proxy (a :<|> b) request respond =
203 route Proxy (a :<|> b) request respond =
203 route pa a request $ \mResponse ->
204 route pa a request $ \mResponse ->
@@ -231,8 +232,8 @@ captured _ = fromText
231instance (KnownSymbol capture, FromText a, HasServer sublayout)
232instance (KnownSymbol capture, FromText a, HasServer sublayout)
232 => HasServer (Capture capture a :> sublayout) where
233 => HasServer (Capture capture a :> sublayout) where
233
234
234− type ServerT' (Capture capture a :> sublayout) m =
235+ type ServerT (Capture capture a :> sublayout) m =
235− a -> ServerT' sublayout m
236+ a -> ServerT sublayout m
236
237
237 route Proxy subserver request respond = case processedPathInfo request of
238 route Proxy subserver request respond = case processedPathInfo request of
238 (first : rest)
239 (first : rest)
@@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
259-- are not met.
260-- are not met.
260instance HasServer Delete where
261instance HasServer Delete where
261
262
262− type ServerT' Delete m = m ()
263+ type ServerT Delete m = m ()
263
264
264 route Proxy action request respond
265 route Proxy action request respond
265 | pathIsEmpty request && requestMethod request == methodDelete = do
266 | pathIsEmpty request && requestMethod request == methodDelete = do
266 e <- runEitherT action
267 e <- runEitherT action
267 respond $ succeedWith $ case e of
268 respond $ succeedWith $ case e of
268− Right () ->
269− responseLBS status204 [] ""
269+ Right () -> responseLBS status204 [] ""
270− Left (status, message) ->
270+ Left err -> responseServantErr err
271− responseLBS (mkStatus status (cs message)) [] (cs message)
272 | pathIsEmpty request && requestMethod request /= methodDelete =
271 | pathIsEmpty request && requestMethod request /= methodDelete =
273 respond $ failWith WrongMethod
272 respond $ failWith WrongMethod
274 | otherwise = respond $ failWith NotFound
273 | otherwise = respond $ failWith NotFound
@@ -292,7 +291,7 @@ instance
292#endif
291#endif
293 ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
292 ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
294
293
295− type ServerT' (Get ctypes a) m = m a
294+ type ServerT (Get ctypes a) m = m a
296
295
297 route Proxy action request respond
296 route Proxy action request respond
298 | pathIsEmpty request && requestMethod request == methodGet = do
297 | pathIsEmpty request && requestMethod request == methodGet = do
@@ -304,8 +303,7 @@ instance
304 Nothing -> failWith UnsupportedMediaType
303 Nothing -> failWith UnsupportedMediaType
305 Just (contentT, body) -> succeedWith $
304 Just (contentT, body) -> succeedWith $
306 responseLBS ok200 [ ("Content-Type" , cs contentT)] body
305 responseLBS ok200 [ ("Content-Type" , cs contentT)] body
307− Left (status, message) -> succeedWith $
306+ Left err -> succeedWith $ responseServantErr err
308− responseLBS (mkStatus status (cs message)) [] (cs message)
309 | pathIsEmpty request && requestMethod request /= methodGet =
307 | pathIsEmpty request && requestMethod request /= methodGet =
310 respond $ failWith WrongMethod
308 respond $ failWith WrongMethod
311 | otherwise = respond $ failWith NotFound
309 | otherwise = respond $ failWith NotFound
@@ -317,15 +315,14 @@ instance
317#endif
315#endif
318 HasServer (Get ctypes ()) where
316 HasServer (Get ctypes ()) where
319
317
320− type ServerT' (Get ctypes ()) m = m ()
318+ type ServerT (Get ctypes ()) m = m ()
321
319
322 route Proxy action request respond
320 route Proxy action request respond
323 | pathIsEmpty request && requestMethod request == methodGet = do
321 | pathIsEmpty request && requestMethod request == methodGet = do
324 e <- runEitherT action
322 e <- runEitherT action
325 respond . succeedWith $ case e of
323 respond . succeedWith $ case e of
326 Right () -> responseLBS noContent204 [] ""
324 Right () -> responseLBS noContent204 [] ""
327− Left (status, message) ->
325+ Left err -> responseServantErr err
328− responseLBS (mkStatus status (cs message)) [] (cs message)
329 | pathIsEmpty request && requestMethod request /= methodGet =
326 | pathIsEmpty request && requestMethod request /= methodGet =
330 respond $ failWith WrongMethod
327 respond $ failWith WrongMethod
331 | otherwise = respond $ failWith NotFound
328 | otherwise = respond $ failWith NotFound
@@ -335,9 +332,10 @@ instance
335#if MIN_VERSION_base(4,8,0)
332#if MIN_VERSION_base(4,8,0)
336 {-# OVERLAPPING #-}
333 {-# OVERLAPPING #-}
337#endif
334#endif
335+ ( GetHeaders (Headers h v), AllCTRender ctypes v
338− ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
336+ ) => HasServer (Get ctypes (Headers h v)) where
339
337
340− type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)
338+ type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
341
339
342 route Proxy action request respond
340 route Proxy action request respond
343 | pathIsEmpty request && requestMethod request == methodGet = do
341 | pathIsEmpty request && requestMethod request == methodGet = do
@@ -350,8 +348,7 @@ instance
350 Nothing -> failWith UnsupportedMediaType
348 Nothing -> failWith UnsupportedMediaType
351 Just (contentT, body) -> succeedWith $
349 Just (contentT, body) -> succeedWith $
352 responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
350 responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
353− Left (status, message) -> succeedWith $
351+ Left err -> succeedWith $ responseServantErr err
354− responseLBS (mkStatus status (cs message)) [] (cs message)
355 | pathIsEmpty request && requestMethod request /= methodGet =
352 | pathIsEmpty request && requestMethod request /= methodGet =
356 respond $ failWith WrongMethod
353 respond $ failWith WrongMethod
357 | otherwise = respond $ failWith NotFound
354 | otherwise = respond $ failWith NotFound
@@ -379,8 +376,8 @@ instance
379instance (KnownSymbol sym, FromText a, HasServer sublayout)
376instance (KnownSymbol sym, FromText a, HasServer sublayout)
380 => HasServer (Header sym a :> sublayout) where
377 => HasServer (Header sym a :> sublayout) where
381
378
382− type ServerT' (Header sym a :> sublayout) m =
379+ type ServerT (Header sym a :> sublayout) m =
383− Maybe a -> ServerT' sublayout m
380+ Maybe a -> ServerT sublayout m
384
381
385 route Proxy subserver request respond = do
382 route Proxy subserver request respond = do
386 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
383 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@@ -408,7 +405,7 @@ instance
408 ( AllCTRender ctypes a
405 ( AllCTRender ctypes a
409 ) => HasServer (Post ctypes a) where
406 ) => HasServer (Post ctypes a) where
410
407
411− type ServerT' (Post ctypes a) m = m a
408+ type ServerT (Post ctypes a) m = m a
412
409
413 route Proxy action request respond
410 route Proxy action request respond
414 | pathIsEmpty request && requestMethod request == methodPost = do
411 | pathIsEmpty request && requestMethod request == methodPost = do
@@ -420,8 +417,7 @@ instance
420 Nothing -> failWith UnsupportedMediaType
417 Nothing -> failWith UnsupportedMediaType
421 Just (contentT, body) -> succeedWith $
418 Just (contentT, body) -> succeedWith $
422 responseLBS status201 [ ("Content-Type" , cs contentT)] body
419 responseLBS status201 [ ("Content-Type" , cs contentT)] body
423− Left (status, message) -> succeedWith $
420+ Left err -> succeedWith $ responseServantErr err
424− responseLBS (mkStatus status (cs message)) [] (cs message)
425 | pathIsEmpty request && requestMethod request /= methodPost =
421 | pathIsEmpty request && requestMethod request /= methodPost =
426 respond $ failWith WrongMethod
422 respond $ failWith WrongMethod
427 | otherwise = respond $ failWith NotFound
423 | otherwise = respond $ failWith NotFound
@@ -432,15 +428,14 @@ instance
432#endif
428#endif
433 HasServer (Post ctypes ()) where
429 HasServer (Post ctypes ()) where
434
430
435− type ServerT' (Post ctypes ()) m = m ()
431+ type ServerT (Post ctypes ()) m = m ()
436
432
437 route Proxy action request respond
433 route Proxy action request respond
438 | pathIsEmpty request && requestMethod request == methodPost = do
434 | pathIsEmpty request && requestMethod request == methodPost = do
439 e <- runEitherT action
435 e <- runEitherT action
440 respond . succeedWith $ case e of
436 respond . succeedWith $ case e of
441 Right () -> responseLBS noContent204 [] ""
437 Right () -> responseLBS noContent204 [] ""
442− Left (status, message) ->
438+ Left err -> responseServantErr err
443− responseLBS (mkStatus status (cs message)) [] (cs message)
444 | pathIsEmpty request && requestMethod request /= methodPost =
439 | pathIsEmpty request && requestMethod request /= methodPost =
445 respond $ failWith WrongMethod
440 respond $ failWith WrongMethod
446 | otherwise = respond $ failWith NotFound
441 | otherwise = respond $ failWith NotFound
@@ -450,9 +445,10 @@ instance
450#if MIN_VERSION_base(4,8,0)
445#if MIN_VERSION_base(4,8,0)
451 {-# OVERLAPPING #-}
446 {-# OVERLAPPING #-}
452#endif
447#endif
448+ ( GetHeaders (Headers h v), AllCTRender ctypes v
453− ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
449+ ) => HasServer (Post ctypes (Headers h v)) where
454
450
455− type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)
451+ type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
456
452
457 route Proxy action request respond
453 route Proxy action request respond
458 | pathIsEmpty request && requestMethod request == methodPost = do
454 | pathIsEmpty request && requestMethod request == methodPost = do
@@ -465,8 +461,7 @@ instance
465 Nothing -> failWith UnsupportedMediaType
461 Nothing -> failWith UnsupportedMediaType
466 Just (contentT, body) -> succeedWith $
462 Just (contentT, body) -> succeedWith $
467 responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
463 responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
468− Left (status, message) -> succeedWith $
464+ Left err -> succeedWith $ responseServantErr err
469− responseLBS (mkStatus status (cs message)) [] (cs message)
470 | pathIsEmpty request && requestMethod request /= methodPost =
465 | pathIsEmpty request && requestMethod request /= methodPost =
471 respond $ failWith WrongMethod
466 respond $ failWith WrongMethod
472 | otherwise = respond $ failWith NotFound
467 | otherwise = respond $ failWith NotFound
@@ -490,7 +485,7 @@ instance
490#endif
485#endif
491 ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
486 ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
492
487
493− type ServerT' (Put ctypes a) m = m a
488+ type ServerT (Put ctypes a) m = m a
494
489
495 route Proxy action request respond
490 route Proxy action request respond
496 | pathIsEmpty request && requestMethod request == methodPut = do
491 | pathIsEmpty request && requestMethod request == methodPut = do
@@ -502,8 +497,7 @@ instance
502 Nothing -> failWith UnsupportedMediaType
497 Nothing -> failWith UnsupportedMediaType
503 Just (contentT, body) -> succeedWith $
498 Just (contentT, body) -> succeedWith $
504 responseLBS status200 [ ("Content-Type" , cs contentT)] body
499 responseLBS status200 [ ("Content-Type" , cs contentT)] body
505− Left (status, message) -> succeedWith $
500+ Left err -> succeedWith $ responseServantErr err
506− responseLBS (mkStatus status (cs message)) [] (cs message)
507 | pathIsEmpty request && requestMethod request /= methodPut =
501 | pathIsEmpty request && requestMethod request /= methodPut =
508 respond $ failWith WrongMethod
502 respond $ failWith WrongMethod
509 | otherwise = respond $ failWith NotFound
503 | otherwise = respond $ failWith NotFound
@@ -514,15 +508,14 @@ instance
514#endif
508#endif
515 HasServer (Put ctypes ()) where
509 HasServer (Put ctypes ()) where
516
510
517− type ServerT' (Put ctypes ()) m = m ()
511+ type ServerT (Put ctypes ()) m = m ()
518
512
519 route Proxy action request respond
513 route Proxy action request respond
520 | pathIsEmpty request && requestMethod request == methodPut = do
514 | pathIsEmpty request && requestMethod request == methodPut = do
521 e <- runEitherT action
515 e <- runEitherT action
522 respond . succeedWith $ case e of
516 respond . succeedWith $ case e of
523 Right () -> responseLBS noContent204 [] ""
517 Right () -> responseLBS noContent204 [] ""
524− Left (status, message) ->
518+ Left err -> responseServantErr err
525− responseLBS (mkStatus status (cs message)) [] (cs message)
526 | pathIsEmpty request && requestMethod request /= methodPut =
519 | pathIsEmpty request && requestMethod request /= methodPut =
527 respond $ failWith WrongMethod
520 respond $ failWith WrongMethod
528 | otherwise = respond $ failWith NotFound
521 | otherwise = respond $ failWith NotFound
@@ -532,9 +525,10 @@ instance
532#if MIN_VERSION_base(4,8,0)
525#if MIN_VERSION_base(4,8,0)
533 {-# OVERLAPPING #-}
526 {-# OVERLAPPING #-}
534#endif
527#endif
528+ ( GetHeaders (Headers h v), AllCTRender ctypes v
535− ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
529+ ) => HasServer (Put ctypes (Headers h v)) where
536
530
537− type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)
531+ type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
538
532
539 route Proxy action request respond
533 route Proxy action request respond
540 | pathIsEmpty request && requestMethod request == methodPut = do
534 | pathIsEmpty request && requestMethod request == methodPut = do
@@ -547,8 +541,7 @@ instance
547 Nothing -> failWith UnsupportedMediaType
541 Nothing -> failWith UnsupportedMediaType
548 Just (contentT, body) -> succeedWith $
542 Just (contentT, body) -> succeedWith $
549 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
543 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
550− Left (status, message) -> succeedWith $
544+ Left err -> succeedWith $ responseServantErr err
551− responseLBS (mkStatus status (cs message)) [] (cs message)
552 | pathIsEmpty request && requestMethod request /= methodPut =
545 | pathIsEmpty request && requestMethod request /= methodPut =
553 respond $ failWith WrongMethod
546 respond $ failWith WrongMethod
554 | otherwise = respond $ failWith NotFound
547 | otherwise = respond $ failWith NotFound
@@ -570,7 +563,7 @@ instance
570#endif
563#endif
571 ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
564 ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
572
565
573− type ServerT' (Patch ctypes a) m = m a
566+ type ServerT (Patch ctypes a) m = m a
574
567
575 route Proxy action request respond
568 route Proxy action request respond
576 | pathIsEmpty request && requestMethod request == methodPatch = do
569 | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -582,8 +575,7 @@ instance
582 Nothing -> failWith UnsupportedMediaType
575 Nothing -> failWith UnsupportedMediaType
583 Just (contentT, body) -> succeedWith $
576 Just (contentT, body) -> succeedWith $
584 responseLBS status200 [ ("Content-Type" , cs contentT)] body
577 responseLBS status200 [ ("Content-Type" , cs contentT)] body
585− Left (status, message) -> succeedWith $
578+ Left err -> succeedWith $ responseServantErr err
586− responseLBS (mkStatus status (cs message)) [] (cs message)
587 | pathIsEmpty request && requestMethod request /= methodPatch =
579 | pathIsEmpty request && requestMethod request /= methodPatch =
588 respond $ failWith WrongMethod
580 respond $ failWith WrongMethod
589 | otherwise = respond $ failWith NotFound
581 | otherwise = respond $ failWith NotFound
@@ -594,15 +586,14 @@ instance
594#endif
586#endif
595 HasServer (Patch ctypes ()) where
587 HasServer (Patch ctypes ()) where
596
588
597− type ServerT' (Patch ctypes ()) m = m ()
589+ type ServerT (Patch ctypes ()) m = m ()
598
590
599 route Proxy action request respond
591 route Proxy action request respond
600 | pathIsEmpty request && requestMethod request == methodPatch = do
592 | pathIsEmpty request && requestMethod request == methodPatch = do
601 e <- runEitherT action
593 e <- runEitherT action
602 respond . succeedWith $ case e of
594 respond . succeedWith $ case e of
603 Right () -> responseLBS noContent204 [] ""
595 Right () -> responseLBS noContent204 [] ""
604− Left (status, message) ->
596+ Left err -> responseServantErr err
605− responseLBS (mkStatus status (cs message)) [] (cs message)
606 | pathIsEmpty request && requestMethod request /= methodPatch =
597 | pathIsEmpty request && requestMethod request /= methodPatch =
607 respond $ failWith WrongMethod
598 respond $ failWith WrongMethod
608 | otherwise = respond $ failWith NotFound
599 | otherwise = respond $ failWith NotFound
@@ -612,9 +603,10 @@ instance
612#if MIN_VERSION_base(4,8,0)
603#if MIN_VERSION_base(4,8,0)
613 {-# OVERLAPPING #-}
604 {-# OVERLAPPING #-}
614#endif
605#endif
606+ ( GetHeaders (Headers h v), AllCTRender ctypes v
615− ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
607+ ) => HasServer (Patch ctypes (Headers h v)) where
616
608
617− type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)
609+ type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
618
610
619 route Proxy action request respond
611 route Proxy action request respond
620 | pathIsEmpty request && requestMethod request == methodPatch = do
612 | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -627,8 +619,7 @@ instance
627 Nothing -> failWith UnsupportedMediaType
619 Nothing -> failWith UnsupportedMediaType
628 Just (contentT, body) -> succeedWith $
620 Just (contentT, body) -> succeedWith $
629 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
621 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
630− Left (status, message) -> succeedWith $
622+ Left err -> succeedWith $ responseServantErr err
631− responseLBS (mkStatus status (cs message)) [] (cs message)
632 | pathIsEmpty request && requestMethod request /= methodPatch =
623 | pathIsEmpty request && requestMethod request /= methodPatch =
633 respond $ failWith WrongMethod
624 respond $ failWith WrongMethod
634 | otherwise = respond $ failWith NotFound
625 | otherwise = respond $ failWith NotFound
@@ -657,8 +648,8 @@ instance
657instance (KnownSymbol sym, FromText a, HasServer sublayout)
648instance (KnownSymbol sym, FromText a, HasServer sublayout)
658 => HasServer (QueryParam sym a :> sublayout) where
649 => HasServer (QueryParam sym a :> sublayout) where
659
650
660− type ServerT' (QueryParam sym a :> sublayout) m =
651+ type ServerT (QueryParam sym a :> sublayout) m =
661− Maybe a -> ServerT' sublayout m
652+ Maybe a -> ServerT sublayout m
662
653
663 route Proxy subserver request respond = do
654 route Proxy subserver request respond = do
664 let querytext = parseQueryText $ rawQueryString request
655 let querytext = parseQueryText $ rawQueryString request
@@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
695instance (KnownSymbol sym, FromText a, HasServer sublayout)
686instance (KnownSymbol sym, FromText a, HasServer sublayout)
696 => HasServer (QueryParams sym a :> sublayout) where
687 => HasServer (QueryParams sym a :> sublayout) where
697
688
698− type ServerT' (QueryParams sym a :> sublayout) m =
689+ type ServerT (QueryParams sym a :> sublayout) m =
699− [a] -> ServerT' sublayout m
690+ [a] -> ServerT sublayout m
700
691
701 route Proxy subserver request respond = do
692 route Proxy subserver request respond = do
702 let querytext = parseQueryText $ rawQueryString request
693 let querytext = parseQueryText $ rawQueryString request
@@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
728instance (KnownSymbol sym, HasServer sublayout)
719instance (KnownSymbol sym, HasServer sublayout)
729 => HasServer (QueryFlag sym :> sublayout) where
720 => HasServer (QueryFlag sym :> sublayout) where
730
721
731− type ServerT' (QueryFlag sym :> sublayout) m =
722+ type ServerT (QueryFlag sym :> sublayout) m =
732− Bool -> ServerT' sublayout m
723+ Bool -> ServerT sublayout m
733
724
734 route Proxy subserver request respond = do
725 route Proxy subserver request respond = do
735 let querytext = parseQueryText $ rawQueryString request
726 let querytext = parseQueryText $ rawQueryString request
@@ -771,8 +762,8 @@ parseMatrixText = parseQueryText
771instance (KnownSymbol sym, FromText a, HasServer sublayout)
762instance (KnownSymbol sym, FromText a, HasServer sublayout)
772 => HasServer (MatrixParam sym a :> sublayout) where
763 => HasServer (MatrixParam sym a :> sublayout) where
773
764
774− type ServerT' (MatrixParam sym a :> sublayout) m =
765+ type ServerT (MatrixParam sym a :> sublayout) m =
775− Maybe a -> ServerT' sublayout m
766+ Maybe a -> ServerT sublayout m
776
767
777 route Proxy subserver request respond = case parsePathInfo request of
768 route Proxy subserver request respond = case parsePathInfo request of
778 (first : _)
769 (first : _)
@@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
809instance (KnownSymbol sym, FromText a, HasServer sublayout)
800instance (KnownSymbol sym, FromText a, HasServer sublayout)
810 => HasServer (MatrixParams sym a :> sublayout) where
801 => HasServer (MatrixParams sym a :> sublayout) where
811
802
812− type ServerT' (MatrixParams sym a :> sublayout) m =
803+ type ServerT (MatrixParams sym a :> sublayout) m =
813− [a] -> ServerT' sublayout m
804+ [a] -> ServerT sublayout m
814
805
815 route Proxy subserver request respond = case parsePathInfo request of
806 route Proxy subserver request respond = case parsePathInfo request of
816 (first : _)
807 (first : _)
@@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
843instance (KnownSymbol sym, HasServer sublayout)
834instance (KnownSymbol sym, HasServer sublayout)
844 => HasServer (MatrixFlag sym :> sublayout) where
835 => HasServer (MatrixFlag sym :> sublayout) where
845
836
846− type ServerT' (MatrixFlag sym :> sublayout) m =
837+ type ServerT (MatrixFlag sym :> sublayout) m =
847− Bool -> ServerT' sublayout m
838+ Bool -> ServerT sublayout m
848
839
849 route Proxy subserver request respond = case parsePathInfo request of
840 route Proxy subserver request respond = case parsePathInfo request of
850 (first : _)
841 (first : _)
@@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
872-- > server = serveDirectory "/var/www/images"
863-- > server = serveDirectory "/var/www/images"
873instance HasServer Raw where
864instance HasServer Raw where
874
865
875− type ServerT' Raw m = Application
866+ type ServerT Raw m = Application
876
867
877 route Proxy rawApplication request respond =
868 route Proxy rawApplication request respond =
878 rawApplication request (respond . succeedWith)
869 rawApplication request (respond . succeedWith)
@@ -900,8 +891,8 @@ instance HasServer Raw where
900instance ( AllCTUnrender list a, HasServer sublayout
891instance ( AllCTUnrender list a, HasServer sublayout
901 ) => HasServer (ReqBody list a :> sublayout) where
892 ) => HasServer (ReqBody list a :> sublayout) where
902
893
903− type ServerT' (ReqBody list a :> sublayout) m =
894+ type ServerT (ReqBody list a :> sublayout) m =
904− a -> ServerT' sublayout m
895+ a -> ServerT sublayout m
905
896
906 route Proxy subserver request respond = do
897 route Proxy subserver request respond = do
907 -- See HTTP RFC 2616, section 7.2.1
898 -- See HTTP RFC 2616, section 7.2.1
@@ -921,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
921-- pass the rest of the request path to @sublayout@.
912-- pass the rest of the request path to @sublayout@.
922instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
913instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
923
914
924− type ServerT' (path :> sublayout) m = ServerT' sublayout m
915+ type ServerT (path :> sublayout) m = ServerT sublayout m
925
916
926 route Proxy subserver request respond = case processedPathInfo request of
917 route Proxy subserver request respond = case processedPathInfo request of
927 (first : rest)
918 (first : rest)
servant-server/src/Servant/Server/Internal/Enter.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Servant.Server.Internal.Enter where
12+
13+#if !MIN_VERSION_base(4,8,0)
14+import Control.Applicative
15+#endif
16+import qualified Control.Category as C
17+#if MIN_VERSION_mtl(2,2,1)
18+import Control.Monad.Except
19+#endif
20+import Control.Monad.Identity
21+import Control.Monad.Morph
22+import Control.Monad.Reader
23+import qualified Control.Monad.State.Lazy as LState
24+import qualified Control.Monad.State.Strict as SState
25+#if MIN_VERSION_mtl(2,2,1)
26+import Control.Monad.Trans.Either
27+#endif
28+import qualified Control.Monad.Writer.Lazy as LWriter
29+import qualified Control.Monad.Writer.Strict as SWriter
30+import Data.Typeable
31+import Servant.API
32+
33+class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
34+ enter :: arg -> typ -> ret
35+
36+-- ** Servant combinators
37+instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
38+ , arg1 ~ arg2
39+ ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
40+ enter e (a :<|> b) = enter e a :<|> enter e b
41+
42+instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
43+ enter arg f a = enter arg (f a)
44+
45+-- ** Useful instances
46+
47+-- | A natural transformation from @m@ to @n@. Used to `enter` particular
48+-- datatypes.
49+newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable
50+
51+instance C.Category (:~>) where
52+ id = Nat id
53+ Nat f . Nat g = Nat (f . g)
54+
55+instance Enter (m a) (m :~> n) (n a) where
56+ enter (Nat f) = f
57+
58+-- | Like `lift`.
59+liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
60+liftNat = Nat Control.Monad.Morph.lift
61+
62+runReaderTNat :: r -> (ReaderT r m :~> m)
63+runReaderTNat a = Nat (`runReaderT` a)
64+
65+evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
66+evalStateTLNat a = Nat (`LState.evalStateT` a)
67+
68+evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
69+evalStateTSNat a = Nat (`SState.evalStateT` a)
70+
71+-- | Log the contents of `SWriter.WriterT` with the function provided as the
72+-- first argument, and return the value of the @WriterT@ computation
73+logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
74+logWriterTSNat logger = Nat $ \x -> do
75+ (a, w) <- SWriter.runWriterT x
76+ liftIO $ logger w
77+ return a
78+
79+-- | Like `logWriterTSNat`, but for strict @WriterT@.
80+logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
81+logWriterTLNat logger = Nat $ \x -> do
82+ (a, w) <- LWriter.runWriterT x
83+ liftIO $ logger w
84+ return a
85+
86+#if MIN_VERSION_mtl(2,2,1)
87+fromExceptT :: ExceptT e m :~> EitherT e m
88+fromExceptT = Nat $ \x -> EitherT $ runExceptT x
89+#endif
90+
91+-- | Like @mmorph@'s `hoist`.
92+hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
93+hoistNat (Nat n) = Nat $ hoist n
94+
95+-- | Like @mmorph@'s `embed`.
96+embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
97+embedNat (Nat n) = Nat $ embed n
98+
99+-- | Like @mmorph@'s `squash`.
100+squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
101+squashNat = Nat squash
102+
103+-- | Like @mmorph@'s `generalize`.
104+generalizeNat :: Applicative m => Identity :~> m
105+generalizeNat = Nat (pure . runIdentity)
servant-server/src/Servant/Server/Internal/ServantErr.hsnew file+229
@@ -0,0 +1,229 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+module Servant.Server.Internal.ServantErr where
4+
5+import qualified Data.ByteString.Char8 as BS
6+import qualified Data.ByteString.Lazy as LBS
7+import qualified Network.HTTP.Types as HTTP
8+import Network.Wai (responseLBS, Response)
9+
10+data ServantErr = ServantErr { errHTTPCode :: Int
11+ , errReasonPhrase :: String
12+ , errBody :: LBS.ByteString
13+ , errHeaders :: [HTTP.Header]
14+ } deriving (Show, Eq)
15+
16+responseServantErr :: ServantErr -> Response
17+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
18+ where
19+ status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)
20+
21+err300 :: ServantErr
22+err300 = ServantErr { errHTTPCode = 300
23+ , errReasonPhrase = "Multiple Choices"
24+ , errBody = ""
25+ , errHeaders = []
26+ }
27+
28+err301 :: ServantErr
29+err301 = ServantErr { errHTTPCode = 301
30+ , errReasonPhrase = "Moved Permanently"
31+ , errBody = ""
32+ , errHeaders = []
33+ }
34+
35+err302 :: ServantErr
36+err302 = ServantErr { errHTTPCode = 302
37+ , errReasonPhrase = "Found"
38+ , errBody = ""
39+ , errHeaders = []
40+ }
41+
42+err303 :: ServantErr
43+err303 = ServantErr { errHTTPCode = 303
44+ , errReasonPhrase = "See Other"
45+ , errBody = ""
46+ , errHeaders = []
47+ }
48+
49+err304 :: ServantErr
50+err304 = ServantErr { errHTTPCode = 304
51+ , errReasonPhrase = "Not Modified"
52+ , errBody = ""
53+ , errHeaders = []
54+ }
55+
56+err305 :: ServantErr
57+err305 = ServantErr { errHTTPCode = 305
58+ , errReasonPhrase = "Use Proxy"
59+ , errBody = ""
60+ , errHeaders = []
61+ }
62+
63+err307 :: ServantErr
64+err307 = ServantErr { errHTTPCode = 307
65+ , errReasonPhrase = "Temporary Redirect"
66+ , errBody = ""
67+ , errHeaders = []
68+ }
69+
70+err400 :: ServantErr
71+err400 = ServantErr { errHTTPCode = 400
72+ , errReasonPhrase = "Bad Request"
73+ , errBody = ""
74+ , errHeaders = []
75+ }
76+
77+err401 :: ServantErr
78+err401 = ServantErr { errHTTPCode = 401
79+ , errReasonPhrase = "Unauthorized"
80+ , errBody = ""
81+ , errHeaders = []
82+ }
83+
84+err402 :: ServantErr
85+err402 = ServantErr { errHTTPCode = 402
86+ , errReasonPhrase = "Payment Required"
87+ , errBody = ""
88+ , errHeaders = []
89+ }
90+
91+err403 :: ServantErr
92+err403 = ServantErr { errHTTPCode = 403
93+ , errReasonPhrase = "Forbidden"
94+ , errBody = ""
95+ , errHeaders = []
96+ }
97+
98+err404 :: ServantErr
99+err404 = ServantErr { errHTTPCode = 404
100+ , errReasonPhrase = "Not Found"
101+ , errBody = ""
102+ , errHeaders = []
103+ }
104+
105+err405 :: ServantErr
106+err405 = ServantErr { errHTTPCode = 405
107+ , errReasonPhrase = "Method Not Allowed"
108+ , errBody = ""
109+ , errHeaders = []
110+ }
111+
112+err406 :: ServantErr
113+err406 = ServantErr { errHTTPCode = 406
114+ , errReasonPhrase = "Not Acceptable"
115+ , errBody = ""
116+ , errHeaders = []
117+ }
118+
119+err407 :: ServantErr
120+err407 = ServantErr { errHTTPCode = 407
121+ , errReasonPhrase = "Proxy Authentication Required"
122+ , errBody = ""
123+ , errHeaders = []
124+ }
125+
126+err409 :: ServantErr
127+err409 = ServantErr { errHTTPCode = 409
128+ , errReasonPhrase = "Conflict"
129+ , errBody = ""
130+ , errHeaders = []
131+ }
132+
133+err410 :: ServantErr
134+err410 = ServantErr { errHTTPCode = 410
135+ , errReasonPhrase = "Gone"
136+ , errBody = ""
137+ , errHeaders = []
138+ }
139+
140+err411 :: ServantErr
141+err411 = ServantErr { errHTTPCode = 411
142+ , errReasonPhrase = "Length Required"
143+ , errBody = ""
144+ , errHeaders = []
145+ }
146+
147+err412 :: ServantErr
148+err412 = ServantErr { errHTTPCode = 412
149+ , errReasonPhrase = "Precondition Failed"
150+ , errBody = ""
151+ , errHeaders = []
152+ }
153+
154+err413 :: ServantErr
155+err413 = ServantErr { errHTTPCode = 413
156+ , errReasonPhrase = "Request Entity Too Large"
157+ , errBody = ""
158+ , errHeaders = []
159+ }
160+
161+err414 :: ServantErr
162+err414 = ServantErr { errHTTPCode = 414
163+ , errReasonPhrase = "Request-URI Too Large"
164+ , errBody = ""
165+ , errHeaders = []
166+ }
167+
168+err415 :: ServantErr
169+err415 = ServantErr { errHTTPCode = 415
170+ , errReasonPhrase = "Unsupported Media Type"
171+ , errBody = ""
172+ , errHeaders = []
173+ }
174+
175+err416 :: ServantErr
176+err416 = ServantErr { errHTTPCode = 416
177+ , errReasonPhrase = "Request range not satisfiable"
178+ , errBody = ""
179+ , errHeaders = []
180+ }
181+
182+err417 :: ServantErr
183+err417 = ServantErr { errHTTPCode = 417
184+ , errReasonPhrase = "Expectation Failed"
185+ , errBody = ""
186+ , errHeaders = []
187+ }
188+
189+err500 :: ServantErr
190+err500 = ServantErr { errHTTPCode = 500
191+ , errReasonPhrase = "Internal Server Error"
192+ , errBody = ""
193+ , errHeaders = []
194+ }
195+
196+err501 :: ServantErr
197+err501 = ServantErr { errHTTPCode = 501
198+ , errReasonPhrase = "Not Implemented"
199+ , errBody = ""
200+ , errHeaders = []
201+ }
202+
203+err502 :: ServantErr
204+err502 = ServantErr { errHTTPCode = 502
205+ , errReasonPhrase = "Bad Gateway"
206+ , errBody = ""
207+ , errHeaders = []
208+ }
209+
210+err503 :: ServantErr
211+err503 = ServantErr { errHTTPCode = 503
212+ , errReasonPhrase = "Service Unavailable"
213+ , errBody = ""
214+ , errHeaders = []
215+ }
216+
217+err504 :: ServantErr
218+err504 = ServantErr { errHTTPCode = 504
219+ , errReasonPhrase = "Gateway Time-out"
220+ , errBody = ""
221+ , errHeaders = []
222+ }
223+
224+err505 :: ServantErr
225+err505 = ServantErr { errHTTPCode = 505
226+ , errReasonPhrase = "HTTP Version not supported"
227+ , errBody = ""
228+ , errHeaders = []
229+ }
servant-server/test/Doctests.hsnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import System.FilePath.Find
4+import Test.DocTest
5+
6+main :: IO ()
7+main = do
8+ files <- find always (extension ==? ".hs") "src"
9+ doctest $ [ "-isrc"
10+ , "-optP-include"
11+ , "-optPdist/build/autogen/cabal_macros.h"
12+ , "-XOverloadedStrings"
13+ , "-XFlexibleInstances"
14+ , "-XMultiParamTypeClasses"
15+ , "-XDataKinds"
16+ , "-XTypeOperators"
17+ ] ++ files
18+
servant-server/test/Servant/Server/Internal/EnterSpec.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TypeOperators #-}
4+module Servant.Server.Internal.EnterSpec where
5+
6+import qualified Control.Category as C
7+import Control.Monad.Reader
8+import Control.Monad.Trans.Either
9+import Data.Proxy
10+import Servant.API
11+import Servant.Server
12+
13+import Test.Hspec (Spec, describe, it)
14+import Test.Hspec.Wai (get, matchStatus, post,
15+ shouldRespondWith, with)
16+
17+spec :: Spec
18+spec = describe "module Servant.Server.Enter" $ do
19+ enterSpec
20+
21+type ReaderAPI = "int" :> Get '[JSON] Int
22+ :<|> "string" :> Post '[JSON] String
23+
24+type IdentityAPI = "bool" :> Get '[JSON] Bool
25+
26+type CombinedAPI = ReaderAPI :<|> IdentityAPI
27+
28+readerAPI :: Proxy ReaderAPI
29+readerAPI = Proxy
30+
31+combinedAPI :: Proxy CombinedAPI
32+combinedAPI = Proxy
33+
34+readerServer' :: ServerT ReaderAPI (Reader String)
35+readerServer' = return 1797 :<|> ask
36+
37+fReader :: Reader String :~> EitherT ServantErr IO
38+fReader = generalizeNat C.. (runReaderTNat "hi")
39+
40+readerServer :: Server ReaderAPI
41+readerServer = enter fReader readerServer'
42+
43+combinedReaderServer' :: ServerT CombinedAPI (Reader String)
44+combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
45+
46+combinedReaderServer :: Server CombinedAPI
47+combinedReaderServer = enter fReader combinedReaderServer'
48+
49+enterSpec :: Spec
50+enterSpec = describe "Enter" $ do
51+ with (return (serve readerAPI readerServer)) $ do
52+
53+ it "allows running arbitrary monads" $ do
54+ get "int" `shouldRespondWith` "1797"
55+ post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
56+
57+ with (return (serve combinedAPI combinedReaderServer)) $ do
58+ it "allows combnation of enters" $ do
59+ get "bool" `shouldRespondWith` "true"
servant-server/test/Servant/ServerSpec.hs+6−6
@@ -35,13 +35,13 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
35 shouldRespondWith, with, (<:>))
35 shouldRespondWith, with, (<:>))
36
36
37import Servant.API ((:<|>) (..), (:>),
37import Servant.API ((:<|>) (..), (:>),
38− AddHeader (addHeader), Capture,
38+ addHeader, Capture,
39 Delete, Get, Header (..), Headers,
39 Delete, Get, Header (..), Headers,
40 JSON, MatrixFlag, MatrixParam,
40 JSON, MatrixFlag, MatrixParam,
41 MatrixParams, Patch, PlainText,
41 MatrixParams, Patch, PlainText,
42 Post, Put, QueryFlag, QueryParam,
42 Post, Put, QueryFlag, QueryParam,
43 QueryParams, Raw, ReqBody)
43 QueryParams, Raw, ReqBody)
44−import Servant.Server (Server, serve)
44+import Servant.Server (Server, serve, ServantErr(..), err404)
45import Servant.Server.Internal (RouteMismatch (..))
45import Servant.Server.Internal (RouteMismatch (..))
46
46
47
47
@@ -96,11 +96,11 @@ spec = do
96type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
96type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
97captureApi :: Proxy CaptureApi
97captureApi :: Proxy CaptureApi
98captureApi = Proxy
98captureApi = Proxy
99−captureServer :: Integer -> EitherT (Int, String) IO Animal
99+captureServer :: Integer -> EitherT ServantErr IO Animal
100captureServer legs = case legs of
100captureServer legs = case legs of
101 4 -> return jerry
101 4 -> return jerry
102 2 -> return tweety
102 2 -> return tweety
103− _ -> left (404, "not found")
103+ _ -> left err404
104
104
105captureSpec :: Spec
105captureSpec :: Spec
106captureSpec = do
106captureSpec = do
@@ -450,11 +450,11 @@ headerApi = Proxy
450headerSpec :: Spec
450headerSpec :: Spec
451headerSpec = describe "Servant.API.Header" $ do
451headerSpec = describe "Servant.API.Header" $ do
452
452
453− let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
453+ let expectsInt :: Maybe Int -> EitherT ServantErr IO ()
454 expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
454 expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
455 expectsInt Nothing = error "Expected an int"
455 expectsInt Nothing = error "Expected an int"
456
456
457− let expectsString :: Maybe String -> EitherT (Int,String) IO ()
457+ let expectsString :: Maybe String -> EitherT ServantErr IO ()
458 expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
458 expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
459 expectsString Nothing = error "Expected a string"
459 expectsString Nothing = error "Expected a string"
460
460
servant/CHANGELOG.md−1
@@ -1,6 +1,5 @@
10.3
10.3
2---
2---
3−* Add a `Canonicalize` type family that distributes all `:>`s inside `:<|>`s to get to the canonical type of an API -- which is then used in all other packages to avoid weird handler types in *servant-server*.
4* Multiple content-type/accept support for all the relevant combinators
3* Multiple content-type/accept support for all the relevant combinators
5* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
4* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
6* Type-safe link generation to API endpoints
5* Type-safe link generation to API endpoints
servant/shell.nixnew file+2
@@ -0,0 +1,2 @@
1+with (import <nixpkgs> {}).pkgs;
2+(haskellngPackages.callPackage ./. {}).env
servant/src/Servant/API.hs+9−41
@@ -1,5 +1,5 @@
1−{-# LANGUAGE TypeFamilies #-}
1+{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE TypeOperators #-}
2+{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
4module Servant.API (
4module Servant.API (
5
5
@@ -49,26 +49,21 @@ module Servant.API (
49 module Servant.Common.Text,
49 module Servant.Common.Text,
50 -- | Classes and instances for types that can be converted to and from @Text@
50 -- | Classes and instances for types that can be converted to and from @Text@
51
51
52− -- * Canonicalizing (flattening) API types
53− Canonicalize,
54− canonicalize,
55−
56 -- * Utilities
52 -- * Utilities
57 module Servant.Utils.Links,
53 module Servant.Utils.Links,
58 -- | Type-safe internal URIs
54 -- | Type-safe internal URIs
59 ) where
55 ) where
60
56
61−import Data.Proxy (Proxy (..))
62import Servant.API.Alternative ((:<|>) (..))
57import Servant.API.Alternative ((:<|>) (..))
63import Servant.API.Capture (Capture)
58import Servant.API.Capture (Capture)
64−import Servant.API.ContentTypes (FormUrlEncoded,
59+import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
65 FromFormUrlEncoded (..), JSON,
60 FromFormUrlEncoded (..), JSON,
66 MimeRender (..),
61 MimeRender (..),
67 MimeUnrender (..), OctetStream,
62 MimeUnrender (..), OctetStream,
68 PlainText, ToFormUrlEncoded (..))
63 PlainText, ToFormUrlEncoded (..))
69import Servant.API.Delete (Delete)
64import Servant.API.Delete (Delete)
70import Servant.API.Get (Get)
65import Servant.API.Get (Get)
71−import Servant.API.Header (Header(..))
66+import Servant.API.Header (Header (..))
72import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
67import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
73 MatrixParams)
68 MatrixParams)
74import Servant.API.Patch (Patch)
69import Servant.API.Patch (Patch)
@@ -78,40 +73,13 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
78 QueryParams)
73 QueryParams)
79import Servant.API.Raw (Raw)
74import Servant.API.Raw (Raw)
80import Servant.API.ReqBody (ReqBody)
75import Servant.API.ReqBody (ReqBody)
81−import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
76+import Servant.API.ResponseHeaders (AddHeader (addHeader),
82− , AddHeader(addHeader) )
77+ BuildHeadersTo (buildHeadersTo),
78+ GetHeaders (getHeaders),
79+ HList (..), Headers (..),
80+ getHeadersHList, getResponse)
83import Servant.API.Sub ((:>))
81import Servant.API.Sub ((:>))
84import Servant.Common.Text (FromText (..), ToText (..))
82import Servant.Common.Text (FromText (..), ToText (..))
85import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
83import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
86 URI (..), safeLink)
84 URI (..), safeLink)
87
85
88−-- | Turn an API type into its canonical form.
89−--
90−-- The canonical form of an API type is basically the all-flattened form
91−-- of the original type. More formally, it takes a type as input and hands you
92−-- back an /equivalent/ type formed of toplevel `:<|>`-separated chains of `:>`s,
93−-- i.e with all `:>`s distributed inside the `:<|>`s.
94−--
95−-- It basically turns:
96−--
97−-- > "hello" :> (Get Hello :<|> ReqBody Hello :> Put Hello)
98−--
99−-- into
100−--
101−-- > ("hello" :> Get Hello) :<|> ("hello" :> ReqBody Hello :> Put Hello)
102−--
103−-- i.e distributing all ':>'-separated bits into the subsequent ':<|>'s.
104−type family Canonicalize api :: * where
105− -- requires UndecidableInstances
106− Canonicalize (a :> (b :<|> c)) = a :> Canonicalize b :<|> a :> Canonicalize c
107− Canonicalize ((a :<|> b) :> c) = a :> Canonicalize c :<|> b :> Canonicalize c
108− Canonicalize (a :> b) = Redex b (Canonicalize b) a
109− Canonicalize (a :<|> b) = Canonicalize a :<|> Canonicalize b
110− Canonicalize a = a
111−
112−type family Redex a b c :: * where
113− Redex a a first = Canonicalize first :> a
114− Redex a b first = Canonicalize (first :> b)
115−
116−canonicalize :: Proxy layout -> Proxy (Canonicalize layout)
117−canonicalize Proxy = Proxy
servant/src/Servant/API/Alternative.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeOperators #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Alternative ((:<|>)(..)) where
5module Servant.API.Alternative ((:<|>)(..)) where
5
6
6#if !MIN_VERSION_base(4,8,0)
7#if !MIN_VERSION_base(4,8,0)
servant/src/Servant/API/Capture.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Capture (Capture) where
5module Servant.API.Capture (Capture) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/ContentTypes.hs+1
@@ -10,6 +10,7 @@
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13+{-# OPTIONS_HADDOCK not-home #-}
13
14
14-- | A collection of basic Content-Types (also known as Internet Media
15-- | A collection of basic Content-Types (also known as Internet Media
15-- Types, or MIME types). Additionally, this module provides classes that
16-- Types, or MIME types). Additionally, this module provides classes that
servant/src/Servant/API/Delete.hs+1
@@ -1,4 +1,5 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2+{-# OPTIONS_HADDOCK not-home #-}
2module Servant.API.Delete (Delete) where
3module Servant.API.Delete (Delete) where
3
4
4import Data.Typeable ( Typeable )
5import Data.Typeable ( Typeable )
servant/src/Servant/API/Get.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Get (Get) where
5module Servant.API.Get (Get) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/Header.hs+8−3
@@ -1,10 +1,13 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
5+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Header where
6module Servant.API.Header where
5
7
6−import Data.Typeable (Typeable)
8+import Data.ByteString (ByteString)
9+import Data.Typeable (Typeable)
7−import GHC.TypeLits (Symbol)
10+import GHC.TypeLits (Symbol)
8-- | Extract the given header's value as a value of type @a@.
11-- | Extract the given header's value as a value of type @a@.
9--
12--
10-- Example:
13-- Example:
@@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol)
14-- >>> -- GET /view-my-referer
17-- >>> -- GET /view-my-referer
15-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
18-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
16data Header (sym :: Symbol) a = Header a
19data Header (sym :: Symbol) a = Header a
20+ | MissingHeader
21+ | UndecodableHeader ByteString
17− deriving Typeable
22+ deriving (Typeable, Eq, Show, Functor)
18
23
19-- $setup
24-- $setup
20-- >>> import Servant.API
25-- >>> import Servant.API
servant/src/Servant/API/MatrixParam.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
5module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/Patch.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Patch (Patch) where
5module Servant.API.Patch (Patch) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/Post.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Post (Post) where
5module Servant.API.Post (Post) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/Put.hs+3−2
@@ -1,6 +1,7 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Put (Put) where
5module Servant.API.Put (Put) where
5
6
6import Data.Typeable ( Typeable )
7import Data.Typeable ( Typeable )
servant/src/Servant/API/QueryParam.hs+1
@@ -2,6 +2,7 @@
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
5+{-# OPTIONS_HADDOCK not-home #-}
5module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
6module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
6
7
7import Data.Typeable (Typeable)
8import Data.Typeable (Typeable)
servant/src/Servant/API/Raw.hs+1
@@ -1,4 +1,5 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2+{-# OPTIONS_HADDOCK not-home #-}
2module Servant.API.Raw where
3module Servant.API.Raw where
3
4
4import Data.Typeable (Typeable)
5import Data.Typeable (Typeable)
servant/src/Servant/API/ReqBody.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.ReqBody where
5module Servant.API.ReqBody where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/API/ResponseHeaders.hs+105−20
@@ -9,11 +9,13 @@
9{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
14#if !MIN_VERSION_base(4,8,0)
15#if !MIN_VERSION_base(4,8,0)
15{-# LANGUAGE OverlappingInstances #-}
16{-# LANGUAGE OverlappingInstances #-}
16#endif
17#endif
18+{-# OPTIONS_HADDOCK not-home #-}
17
19
18-- | This module provides facilities for adding headers to a response.
20-- | This module provides facilities for adding headers to a response.
19--
21--
@@ -22,14 +24,20 @@
22-- The value is added to the header specified by the type (@Location@ in the
24-- The value is added to the header specified by the type (@Location@ in the
23-- example above).
25-- example above).
24module Servant.API.ResponseHeaders
26module Servant.API.ResponseHeaders
25− ( Headers
27+ ( Headers(..)
26− , getResponse
27− , getHeaders
28 , AddHeader(addHeader)
28 , AddHeader(addHeader)
29+ , BuildHeadersTo(buildHeadersTo)
30+ , GetHeaders(getHeaders)
31+ , HeaderValMap
32+ , HList(..)
29 ) where
33 ) where
30
34
35+#if !MIN_VERSION_base(4,8,0)
36+import Control.Applicative ((<$>))
37+#endif
31−import Data.ByteString.Char8 (pack)
38+import Data.ByteString.Char8 as BS (pack, unlines, init)
32−import Data.ByteString.Conversion (ToByteString, toByteString')
39+import Data.ByteString.Conversion (ToByteString, toByteString',
40+ FromByteString, fromByteString)
33import qualified Data.CaseInsensitive as CI
41import qualified Data.CaseInsensitive as CI
34import Data.Proxy
42import Data.Proxy
35import GHC.TypeLits (KnownSymbol, symbolVal)
43import GHC.TypeLits (KnownSymbol, symbolVal)
@@ -41,27 +49,102 @@ import Servant.API.Header (Header (..))
41-- Instead, use 'addHeader'.
49-- Instead, use 'addHeader'.
42data Headers ls a = Headers { getResponse :: a
50data Headers ls a = Headers { getResponse :: a
43 -- ^ The underlying value of a 'Headers'
51 -- ^ The underlying value of a 'Headers'
44− , getHeaders :: [HTTP.Header]
52+ , getHeadersHList :: HList ls
45− -- ^ The list of header values of a 'Headers'.
53+ -- ^ HList of headers.
46− -- These are guaranteed to correspond with the
47− -- first type of @Headers@ if constructed with
48− -- 'addHeader'.
49− } deriving (Eq, Show, Functor)
54+ } deriving (Functor)
55+
56+data HList a where
57+ HNil :: HList '[]
58+ HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
59+
60+type family HeaderValMap (f :: * -> *) (xs :: [*]) where
61+ HeaderValMap f '[] = '[]
62+ HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs)
63+
64+
65+class BuildHeadersTo hs where
66+ buildHeadersTo :: [HTTP.Header] -> HList hs
67+ -- ^ Note: if there are multiple occurences of a header in the argument,
68+ -- the values are interspersed with commas before deserialization (see
69+ -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
70+
71+instance
72+#if MIN_VERSION_base(4,8,0)
73+ {-# OVERLAPPING #-}
74+#endif
75+ BuildHeadersTo '[] where
76+ buildHeadersTo _ = HNil
77+
78+instance
79+#if MIN_VERSION_base(4,8,0)
80+ {-# OVERLAPPABLE #-}
81+#endif
82+ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False
83+ ) => BuildHeadersTo ((Header h v) ': xs) where
84+ buildHeadersTo headers =
85+ let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
86+ matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
87+ in case matching of
88+ [] -> MissingHeader `HCons` buildHeadersTo headers
89+ xs -> case fromByteString (BS.init $ BS.unlines xs) of
90+ Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)
91+ `HCons` buildHeadersTo headers
92+ Just h -> Header h `HCons` buildHeadersTo headers
93+
94+-- * Getting
95+
96+class GetHeaders ls where
97+ getHeaders :: ls -> [HTTP.Header]
98+
99+instance
100+#if MIN_VERSION_base(4,8,0)
101+ {-# OVERLAPPING #-}
102+#endif
103+ GetHeaders (HList '[]) where
104+ getHeaders _ = []
105+
106+instance
107+#if MIN_VERSION_base(4,8,0)
108+ {-# OVERLAPPABLE #-}
109+#endif
110+ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)
111+ ) => GetHeaders (HList (Header h x ': xs)) where
112+ getHeaders hdrs = case hdrs of
113+ Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
114+ UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest
115+ MissingHeader `HCons` rest -> getHeaders rest
116+ where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
117+
118+instance
119+#if MIN_VERSION_base(4,8,0)
120+ {-# OVERLAPPING #-}
121+#endif
122+ GetHeaders (Headers '[] a) where
123+ getHeaders _ = []
124+
125+instance
126+#if MIN_VERSION_base(4,8,0)
127+ {-# OVERLAPPABLE #-}
128+#endif
129+ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v
130+ ) => GetHeaders (Headers (Header h v ': rest) a) where
131+ getHeaders hs = getHeaders $ getHeadersHList hs
132+
133+-- * Adding
50
134
51-- We need all these fundeps to save type inference
135-- We need all these fundeps to save type inference
52class AddHeader h v orig new
136class AddHeader h v orig new
53 | h v orig -> new, new -> h, new -> v, new -> orig where
137 | h v orig -> new, new -> h, new -> v, new -> orig where
54− addHeader :: v -> orig -> new
138+ addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
139+
55
140
56instance
141instance
57#if MIN_VERSION_base(4,8,0)
142#if MIN_VERSION_base(4,8,0)
58 {-# OVERLAPPING #-}
143 {-# OVERLAPPING #-}
59#endif
144#endif
60− ( KnownSymbol h, ToByteString v
145+ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False
61− ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
146+ ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
62− addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
147+ addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
63− where
64− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
65
148
66instance
149instance
67#if MIN_VERSION_base(4,8,0)
150#if MIN_VERSION_base(4,8,0)
@@ -70,10 +153,12 @@ instance
70 ( KnownSymbol h, ToByteString v
153 ( KnownSymbol h, ToByteString v
71 , new ~ (Headers '[Header h v] a)
154 , new ~ (Headers '[Header h v] a)
72 ) => AddHeader h v a new where
155 ) => AddHeader h v a new where
73− addHeader a resp = Headers resp [(headerName, toByteString' a)]
156+ addHeader a resp = Headers resp (HCons (Header a) HNil)
74− where
75− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
76
157
158+type family Contains x xs where
159+ Contains x ((Header x a) ': xs) = 'True
160+ Contains x ((Header y a) ': xs) = Contains x xs
161+ Contains x '[] = 'False
77
162
78-- $setup
163-- $setup
79-- >>> import Servant.API
164-- >>> import Servant.API
servant/src/Servant/API/Sub.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeOperators #-}
4+{-# OPTIONS_HADDOCK not-home #-}
4module Servant.API.Sub ((:>)) where
5module Servant.API.Sub ((:>)) where
5
6
6import Data.Typeable (Typeable)
7import Data.Typeable (Typeable)
servant/src/Servant/Utils/Links.hs+1
@@ -8,6 +8,7 @@
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11+{-# OPTIONS_HADDOCK not-home #-}
11
12
12-- | Type safe generation of internal links.
13-- | Type safe generation of internal links.
13--
14--
sources.txt+2
@@ -4,3 +4,5 @@ servant-docs
4servant-jquery
4servant-jquery
5servant-server
5servant-server
6servant-examples
6servant-examples
7+servant-blaze
8+servant-lucid