git.iko.soy/servant
on master help sign in
Merge pull request #57 from haskell-servant/jkarni/pre-0.3

Last tasks for 0.3

commita058cd4bf47c49a5e0bf0dcbd2f6613e85b44b21 authorJulian Arni <jkarni@gmail.com> dateMon 4 May 2015, 17:53 (11 years ago) parent6253b8a59cc797
54 files changed+1316−314
compare with master
unifiedsplit
.gitignore+1 scripts/shell.nix+1−3 scripts/start-sandbox.sh+30 servant-blaze/LICENSE+30 servant-blaze/Setup.hs+2 servant-blaze/servant-blaze.cabal+28 servant-blaze/src/Servant/HTML/Blaze.hs+45 servant-client/CHANGELOG.md+1−1 servant-client/src/Servant/Client.hs+104−43 servant-client/src/Servant/Common/Req.hs+13−10 servant-client/test/Servant/ClientSpec.hs+30−15 servant-docs/CHANGELOG.md+3−1 servant-docs/example/greet.hs+7−4 servant-docs/servant-docs.cabal+4 servant-docs/src/Servant/Docs.hs+3−3 servant-docs/src/Servant/Docs/Internal.hs+142−43 servant-docs/test/Servant/DocsSpec.hs+6−6 servant-examples/auth-combinator/auth-combinator.hs+2−2 servant-jquery/src/Servant/JQuery.hs+3−4 servant-jquery/src/Servant/JQuery/Internal.hs+18−20 servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs+3−3 servant-lucid/LICENSE+30 servant-lucid/Setup.hs+2 servant-lucid/servant-lucid.cabal+28 servant-lucid/src/Servant/HTML/Lucid.hs+43 servant-server/CHANGELOG.md+3−1 servant-server/servant-server.cabal+16 servant-server/src/Servant/Server.hs+95−9 servant-server/src/Servant/Server/Internal.hs+64−73 servant-server/src/Servant/Server/Internal/Enter.hs+105 servant-server/src/Servant/Server/Internal/ServantErr.hs+229 servant-server/test/Doctests.hs+18 servant-server/test/Servant/Server/Internal/EnterSpec.hs+59 servant-server/test/Servant/ServerSpec.hs+6−6 servant/CHANGELOG.md−1 servant/shell.nix+2 servant/src/Servant/API.hs+9−41 servant/src/Servant/API/Alternative.hs+1 servant/src/Servant/API/Capture.hs+1 servant/src/Servant/API/ContentTypes.hs+1 servant/src/Servant/API/Delete.hs+1 servant/src/Servant/API/Get.hs+1 servant/src/Servant/API/Header.hs+8−3 servant/src/Servant/API/MatrixParam.hs+1 servant/src/Servant/API/Patch.hs+1 servant/src/Servant/API/Post.hs+1 servant/src/Servant/API/Put.hs+3−2 servant/src/Servant/API/QueryParam.hs+1 servant/src/Servant/API/Raw.hs+1 servant/src/Servant/API/ReqBody.hs+1 servant/src/Servant/API/ResponseHeaders.hs+105−20 servant/src/Servant/API/Sub.hs+1 servant/src/Servant/Utils/Links.hs+1 sources.txt+2
.gitignore+1
@@ -21,3 +21,4 @@ cabal.config
2121*.prof
2222*.aux
2323*.hp
24+Setup
scripts/shell.nix+1−3
@@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
1313 ../servant-jquery {}) "--ghc-options=-Werror";
1414 servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
1515 {}) "--ghc-options=-Werror";
16− servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
17− {}) "--ghc-options=-Werror";
1816 };
1917 };
2018in 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
2220])
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 @@
77* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
88* Support for PATCH
99* 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
1111
12120.2.2
1313-----
servant-client/src/Servant/Client.hs+104−43
@@ -16,11 +16,13 @@
1616module Servant.Client
1717 ( client
1818 , HasClient(..)
19− , Client
2019 , ServantError(..)
2120 , module Servant.Common.BaseUrl
2221 ) where
2322
23+#if !MIN_VERSION_base(4,8,0)
24+import Control.Applicative ((<$>))
25+#endif
2426import Control.Monad
2527import Control.Monad.Trans.Either
2628import Data.ByteString.Lazy (ByteString)
@@ -32,8 +34,8 @@ import GHC.TypeLits
3234import Network.HTTP.Client (Response)
3335import Network.HTTP.Media
3436import qualified Network.HTTP.Types as H
37+import qualified Network.HTTP.Types.Header as HTTP
3538import Servant.API
36−import Servant.API.ContentTypes
3739import Servant.Common.BaseUrl
3840import Servant.Common.Req
3941
@@ -50,17 +52,16 @@ import Servant.Common.Req
5052-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
5153-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
5254-- > (getAllBooks :<|> postNewBook) = client myApi
53−client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
54−client p = clientWithRoute (canonicalize p) defReq
55+client :: HasClient layout => Proxy layout -> Client layout
56+client p = clientWithRoute p defReq
5557
5658-- | This class lets us define how each API combinator
5759-- influences the creation of an HTTP request. It's mostly
5860-- an internal class, you can just use 'client'.
5961class HasClient layout where
60− type Client' layout :: *
61− clientWithRoute :: Proxy layout -> Req -> Client' layout
62+ type Client layout :: *
63+ clientWithRoute :: Proxy layout -> Req -> Client layout
6264
63−type Client layout = Client' (Canonicalize layout)
6465
6566-- | A client querying function for @a ':<|>' b@ will actually hand you
6667-- one function for querying @a@ and another one for querying @b@,
@@ -76,7 +77,7 @@ type Client layout = Client' (Canonicalize layout)
7677-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
7778-- > (getAllBooks :<|> postNewBook) = client myApi
7879instance (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
8081 clientWithRoute Proxy req =
8182 clientWithRoute (Proxy :: Proxy a) req :<|>
8283 clientWithRoute (Proxy :: Proxy b) req
@@ -103,8 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
103104instance (KnownSymbol capture, ToText a, HasClient sublayout)
104105 => HasClient (Capture capture a :> sublayout) where
105106
106− type Client' (Capture capture a :> sublayout) =
107− a -> Client' sublayout
107+ type Client (Capture capture a :> sublayout) =
108+ a -> Client sublayout
108109
109110 clientWithRoute Proxy req val =
110111 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -117,7 +118,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
117118-- will just require an argument that specifies the scheme, host
118119-- and port to send the request to.
119120instance HasClient Delete where
120− type Client' Delete = BaseUrl -> EitherT ServantError IO ()
121+ type Client Delete = BaseUrl -> EitherT ServantError IO ()
121122
122123 clientWithRoute Proxy req host =
123124 void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@@ -131,21 +132,36 @@ instance
131132 {-# OVERLAPPABLE #-}
132133#endif
133134 (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
135136 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
137138
138139-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
139−-- HTTP header.
140+-- HTTP status.
140141instance
141142#if MIN_VERSION_base(4,8,0)
142143 {-# OVERLAPPING #-}
143144#endif
144145 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 ()
146147 clientWithRoute Proxy req host =
147148 performRequestNoBody H.methodGet req [204] host
148149
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+
149165-- | If you use a 'Header' in one of your endpoints in your API,
150166-- the corresponding querying function will automatically take
151167-- an additional argument of the type specified by your 'Header',
@@ -174,8 +190,8 @@ instance
174190instance (KnownSymbol sym, ToText a, HasClient sublayout)
175191 => HasClient (Header sym a :> sublayout) where
176192
177− type Client' (Header sym a :> sublayout) =
178− Maybe a -> Client' sublayout
193+ type Client (Header sym a :> sublayout) =
194+ Maybe a -> Client sublayout
179195
180196 clientWithRoute Proxy req mval =
181197 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -192,10 +208,10 @@ instance
192208 {-# OVERLAPPABLE #-}
193209#endif
194210 (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
196212
197213 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
199215
200216-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
201217-- HTTP header.
@@ -204,10 +220,25 @@ instance
204220 {-# OVERLAPPING #-}
205221#endif
206222 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 ()
208224 clientWithRoute Proxy req host =
209225 void $ performRequestNoBody H.methodPost req [204] host
210226
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+
211242-- | If you have a 'Put' endpoint in your API, the client
212243-- side querying function that is created when calling 'client'
213244-- will just require an argument that specifies the scheme, host
@@ -217,10 +248,10 @@ instance
217248 {-# OVERLAPPABLE #-}
218249#endif
219250 (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
221252
222253 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
224255
225256-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
226257-- HTTP header.
@@ -229,10 +260,25 @@ instance
229260 {-# OVERLAPPING #-}
230261#endif
231262 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 ()
233264 clientWithRoute Proxy req host =
234265 void $ performRequestNoBody H.methodPut req [204] host
235266
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+
236282-- | If you have a 'Patch' endpoint in your API, the client
237283-- side querying function that is created when calling 'client'
238284-- will just require an argument that specifies the scheme, host
@@ -242,10 +288,10 @@ instance
242288 {-# OVERLAPPABLE #-}
243289#endif
244290 (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
246292
247293 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
249295
250296-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
251297-- HTTP header.
@@ -254,10 +300,25 @@ instance
254300 {-# OVERLAPPING #-}
255301#endif
256302 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 ()
258304 clientWithRoute Proxy req host =
259305 void $ performRequestNoBody H.methodPatch req [204] host
260306
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+
261322-- | If you use a 'QueryParam' in one of your endpoints in your API,
262323-- the corresponding querying function will automatically take
263324-- an additional argument of the type specified by your 'QueryParam',
@@ -286,8 +347,8 @@ instance
286347instance (KnownSymbol sym, ToText a, HasClient sublayout)
287348 => HasClient (QueryParam sym a :> sublayout) where
288349
289− type Client' (QueryParam sym a :> sublayout) =
290− Maybe a -> Client' sublayout
350+ type Client (QueryParam sym a :> sublayout) =
351+ Maybe a -> Client sublayout
291352
292353 -- if mparam = Nothing, we don't add it to the query string
293354 clientWithRoute Proxy req mparam =
@@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
328389instance (KnownSymbol sym, ToText a, HasClient sublayout)
329390 => HasClient (QueryParams sym a :> sublayout) where
330391
331− type Client' (QueryParams sym a :> sublayout) =
332− [a] -> Client' sublayout
392+ type Client (QueryParams sym a :> sublayout) =
393+ [a] -> Client sublayout
333394
334395 clientWithRoute Proxy req paramlist =
335396 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
363424instance (KnownSymbol sym, HasClient sublayout)
364425 => HasClient (QueryFlag sym :> sublayout) where
365426
366− type Client' (QueryFlag sym :> sublayout) =
367− Bool -> Client' sublayout
427+ type Client (QueryFlag sym :> sublayout) =
428+ Bool -> Client sublayout
368429
369430 clientWithRoute Proxy req flag =
370431 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout)
402463instance (KnownSymbol sym, ToText a, HasClient sublayout)
403464 => HasClient (MatrixParam sym a :> sublayout) where
404465
405− type Client' (MatrixParam sym a :> sublayout) =
406− Maybe a -> Client' sublayout
466+ type Client (MatrixParam sym a :> sublayout) =
467+ Maybe a -> Client sublayout
407468
408469 -- if mparam = Nothing, we don't add it to the query string
409470 clientWithRoute Proxy req mparam =
@@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
443504instance (KnownSymbol sym, ToText a, HasClient sublayout)
444505 => HasClient (MatrixParams sym a :> sublayout) where
445506
446− type Client' (MatrixParams sym a :> sublayout) =
447− [a] -> Client' sublayout
507+ type Client (MatrixParams sym a :> sublayout) =
508+ [a] -> Client sublayout
448509
449510 clientWithRoute Proxy req paramlist =
450511 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
478539instance (KnownSymbol sym, HasClient sublayout)
479540 => HasClient (MatrixFlag sym :> sublayout) where
480541
481− type Client' (MatrixFlag sym :> sublayout) =
482− Bool -> Client' sublayout
542+ type Client (MatrixFlag sym :> sublayout) =
543+ Bool -> Client sublayout
483544
484545 clientWithRoute Proxy req flag =
485546 clientWithRoute (Proxy :: Proxy sublayout) $
@@ -492,9 +553,9 @@ instance (KnownSymbol sym, HasClient sublayout)
492553-- | Pick a 'Method' and specify where the server you want to query is. You get
493554-- back the full `Response`.
494555instance 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)
496557
497− clientWithRoute :: Proxy Raw -> Req -> Client' Raw
558+ clientWithRoute :: Proxy Raw -> Req -> Client Raw
498559 clientWithRoute Proxy req httpMethod host = do
499560 performRequest httpMethod req (const True) host
500561
@@ -519,8 +580,8 @@ instance HasClient Raw where
519580instance (MimeRender ct a, HasClient sublayout)
520581 => HasClient (ReqBody (ct ': cts) a :> sublayout) where
521582
522− type Client' (ReqBody (ct ': cts) a :> sublayout) =
523− a -> Client' sublayout
583+ type Client (ReqBody (ct ': cts) a :> sublayout) =
584+ a -> Client sublayout
524585
525586 clientWithRoute Proxy req body =
526587 clientWithRoute (Proxy :: Proxy sublayout) $ do
@@ -529,7 +590,7 @@ instance (MimeRender ct a, HasClient sublayout)
529590
530591-- | Make the querying function append @path@ to the request path.
531592instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
532− type Client' (path :> sublayout) = Client' sublayout
593+ type Client (path :> sublayout) = Client sublayout
533594
534595 clientWithRoute Proxy req =
535596 clientWithRoute (Proxy :: Proxy sublayout) $
servant-client/src/Servant/Common/Req.hs+13−10
@@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)
2222import Network.HTTP.Client.TLS
2323import Network.HTTP.Media
2424import Network.HTTP.Types
25+import qualified Network.HTTP.Types.Header as HTTP
2526import Network.URI
2627import Servant.API.ContentTypes
2728import Servant.Common.BaseUrl
@@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
136137displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
137138
138139
139−performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
140+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl
141+ -> EitherT ServantError IO ( Int, ByteString, MediaType
142+ , [HTTP.Header], Response ByteString)
140143performRequest reqMethod req isWantedStatus reqHost = do
141144 partialRequest <- liftIO $ reqToRequest req reqHost
142145
@@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
154157 Right response -> do
155158 let status = Client.responseStatus response
156159 body = Client.responseBody response
160+ hrds = Client.responseHeaders response
157161 status_code = statusCode status
158162 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
159163 Nothing -> pure $ "application"//"octet-stream"
@@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
162166 Just t' -> pure t'
163167 unless (isWantedStatus status_code) $
164168 left $ FailureResponse status ct body
165− return (status_code, body, ct, response)
169+ return (status_code, body, ct, hrds, response)
170+
166171
167172performRequestCT :: 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)
169174performRequestCT ct reqMethod req wantedStatus reqHost = do
170175 let acceptCT = contentType ct
171− (_status, respBody, respCT, _response) <-
176+ (_status, respBody, respCT, hrds, _response) <-
172177 performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
173− unless (matches respCT (acceptCT)) $
174− left $ UnsupportedContentType respCT respBody
175− either
176− (left . (\s -> DecodeFailure s respCT respBody))
177− return
178− (mimeUnrender ct respBody)
178+ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
179+ case mimeUnrender ct respBody of
180+ Left err -> left $ DecodeFailure err respCT respBody
181+ Right val -> return (hrds, val)
179182
180183performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
181184performRequestNoBody reqMethod req wantedStatus reqHost = do
servant-client/test/Servant/ClientSpec.hs+30−15
@@ -7,7 +7,7 @@
77{-# LANGUAGE RecordWildCards #-}
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeOperators #-}
10−{-# OPTIONS_GHC -fcontext-stack=25 #-}
10+{-# OPTIONS_GHC -fcontext-stack=100 #-}
1111{-# OPTIONS_GHC -fno-warn-orphans #-}
1212module Servant.ClientSpec where
1313
@@ -28,7 +28,8 @@ import qualified Data.Text as T
2828import GHC.Generics
2929import qualified Network.HTTP.Client as C
3030import Network.HTTP.Media
31−import Network.HTTP.Types
31+import Network.HTTP.Types hiding (Header)
32+import qualified Network.HTTP.Types as HTTP
3233import Network.Socket
3334import Network.Wai hiding (Response)
3435import Network.Wai.Handler.Warp
@@ -74,6 +75,8 @@ instance Eq C.HttpException where
7475alice :: Person
7576alice = Person "Alice" 42
7677
78+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
79+
7780type Api =
7881 "get" :> Get '[JSON] Person
7982 :<|> "delete" :> Delete
@@ -93,6 +96,7 @@ type Api =
9396 QueryFlag "third" :>
9497 ReqBody '[JSON] [(String, [Rational])] :>
9598 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
99+ :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
96100api :: Proxy Api
97101api = Proxy
98102
@@ -104,19 +108,20 @@ server = serve api (
104108 :<|> return
105109 :<|> (\ name -> case name of
106110 Just "alice" -> return alice
107− Just name -> left (400, name ++ " not found")
108− Nothing -> left (400, "missing parameter"))
111+ Just name -> left $ ServantErr 400 (name ++ " not found") "" []
112+ Nothing -> left $ ServantErr 400 "missing parameter" "" [])
109113 :<|> (\ names -> return (zipWith Person names [0..]))
110114 :<|> return
111115 :<|> (\ name -> case name of
112116 Just "alice" -> return alice
113− Just name -> left (400, name ++ " not found")
114− Nothing -> left (400, "missing parameter"))
117+ Just name -> left $ ServantErr 400 (name ++ " not found") "" []
118+ Nothing -> left $ ServantErr 400 "missing parameter" "" [])
115119 :<|> (\ names -> return (zipWith Person names [0..]))
116120 :<|> return
117121 :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
118122 :<|> (\ _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)
120125 )
121126
122127withServer :: (BaseUrl -> IO a) -> IO a
@@ -132,11 +137,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
132137getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
133138getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
134139getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
135−getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
136−getRawFailure :: 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)
142+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
143+ MediaType, [HTTP.Header], C.Response ByteString)
137144getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
138145 -> BaseUrl
139146 -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
147+getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
140148( getGet
141149 :<|> getDelete
142150 :<|> getCapture
@@ -149,7 +157,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
149157 :<|> getMatrixFlag
150158 :<|> getRawSuccess
151159 :<|> getRawFailure
152− :<|> getMultiple)
160+ :<|> getMultiple
161+ :<|> getRespHeaders)
153162 = client api
154163
155164type FailApi =
@@ -218,7 +227,7 @@ spec = do
218227 res <- runEitherT (getRawSuccess methodGet host)
219228 case res of
220229 Left e -> assertFailure $ show e
221− Right (code, body, ct, response) -> do
230+ Right (code, body, ct, _, response) -> do
222231 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
223232 C.responseBody response `shouldBe` body
224233 C.responseStatus response `shouldBe` ok200
@@ -227,11 +236,17 @@ spec = do
227236 res <- runEitherT (getRawFailure methodGet host)
228237 case res of
229238 Left e -> assertFailure $ show e
230− Right (code, body, ct, response) -> do
239+ Right (code, body, ct, _, response) -> do
231240 (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
232241 C.responseBody response `shouldBe` body
233242 C.responseStatus response `shouldBe` badRequest400
234243
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+
235250 modifyMaxSuccess (const 20) $ do
236251 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
237252 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@@ -246,7 +261,7 @@ spec = do
246261 let test :: (WrappedApi, String) -> Spec
247262 test (WrappedApi api, desc) =
248263 it desc $
249− withWaiDaemon (return (serve api (left (500, "error message")))) $
264+ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
250265 \ host -> do
251266 let getResponse :: BaseUrl -> EitherT ServantError IO ()
252267 getResponse = client api
@@ -292,8 +307,8 @@ spec = do
292307 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
293308
294309data WrappedApi where
295− WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
296− HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
310+ WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
311+ HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
297312 Proxy api -> WrappedApi
298313
299314
servant-docs/CHANGELOG.md+3−1
@@ -5,7 +5,9 @@
55* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
66* Remove ToJSON superclass from ToSample
77* 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`
911
10120.3
1113---
servant-docs/example/greet.hs+7−4
@@ -53,14 +53,17 @@ instance ToParam (MatrixParam "lang" String) where
5353 "Get the greeting message selected language. Default is en."
5454 Normal
5555
56−instance ToSample Greet where
57− toSample = Just $ Greet "Hello, haskeller!"
56+instance ToSample Greet Greet where
57+ toSample _ = Just $ Greet "Hello, haskeller!"
5858
59− toSamples =
59+ toSamples _ =
6060 [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
6161 , ("If you use ?capital=false", Greet "Hello, haskeller")
6262 ]
6363
64+instance ToSample Int Int where
65+ toSample _ = Just 1729
66+
6467-- We define some introductory sections, these will appear at the top of the
6568-- documentation.
6669--
@@ -84,7 +87,7 @@ type TestApi =
8487
8588 -- POST /greet with a Greet as JSON in the request body,
8689 -- 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)
8891
8992 -- DELETE /greet/:greetid
9093 :<|> "greet" :> Capture "greetid" Text :> Delete
servant-docs/servant-docs.cabal+4
@@ -32,8 +32,11 @@ library
3232 build-depends:
3333 base >=4.7 && <5
3434 , bytestring
35+ , bytestring-conversion
36+ , case-insensitive
3537 , hashable
3638 , http-media >= 0.6
39+ , http-types >= 0.7
3740 , lens
3841 , servant >= 0.2.1
3942 , string-conversions
@@ -50,6 +53,7 @@ executable greet-docs
5053 build-depends:
5154 base
5255 , aeson
56+ , bytestring-conversion
5357 , lens
5458 , servant
5559 , servant-docs
servant-docs/src/Servant/Docs.hs+3−3
@@ -77,10 +77,10 @@
7777-- > "Get the greeting message selected language. Default is en."
7878-- > Normal
7979-- >
80−-- > instance ToSample Greet where
81−-- > toSample = Just $ Greet "Hello, haskeller!"
80+-- > instance ToSample Greet Greet where
81+-- > toSample _ = Just $ Greet "Hello, haskeller!"
8282-- >
83−-- > toSamples =
83+-- > toSamples _ =
8484-- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
8585-- > , ("If you use ?capital=false", Greet "Hello, haskeller")
8686-- > ]
servant-docs/src/Servant/Docs/Internal.hs+142−43
@@ -1,17 +1,22 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#if !MIN_VERSION_base(4,8,0)
18+{-# LANGUAGE OverlappingInstances #-}
19+#endif
1520module Servant.Docs.Internal where
1621
1722#if !MIN_VERSION_base(4,8,0)
@@ -19,6 +24,7 @@ import Control.Applicative
1924#endif
2025import Control.Lens
2126import Data.ByteString.Lazy.Char8 (ByteString)
27+import qualified Data.CaseInsensitive as CI
2228import Data.Hashable
2329import Data.HashMap.Strict (HashMap)
2430import Data.List
@@ -26,6 +32,7 @@ import Data.Maybe
2632import Data.Monoid
2733import Data.Ord (comparing)
2834import Data.Proxy
35+import Data.ByteString.Conversion (ToByteString, toByteString)
2936import Data.String.Conversions
3037import Data.Text (Text, pack, unpack)
3138import GHC.Exts (Constraint)
@@ -38,6 +45,7 @@ import Servant.Utils.Links
3845import qualified Data.HashMap.Strict as HM
3946import qualified Data.Text as T
4047import qualified Network.HTTP.Media as M
48+import qualified Network.HTTP.Types as HTTP
4149
4250-- | Supported HTTP request methods
4351data Method = DocDELETE -- ^ the DELETE method
@@ -191,9 +199,10 @@ data ParamKind = Normal | List | Flag
191199-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
192200-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
193201data Response = Response
194− { _respStatus :: Int
195− , _respTypes :: [M.MediaType]
196− , _respBody :: [(Text, M.MediaType, ByteString)]
202+ { _respStatus :: Int
203+ , _respTypes :: [M.MediaType]
204+ , _respBody :: [(Text, M.MediaType, ByteString)]
205+ , _respHeaders :: [HTTP.Header]
197206 } deriving (Eq, Ord, Show)
198207
199208-- | Default response: status code 200, no response body.
@@ -205,7 +214,12 @@ data Response = Response
205214-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
206215-- > Response {_respStatus = 204, _respBody = Just "[]"}
207216defResponse :: Response
208−defResponse = Response 200 [] []
217+defResponse = Response
218+ { _respStatus = 200
219+ , _respTypes = []
220+ , _respBody = []
221+ , _respHeaders = []
222+ }
209223
210224-- | A datatype that represents everything that can happen
211225-- at an endpoint, with its lenses:
@@ -276,8 +290,8 @@ makeLenses ''Action
276290
277291-- | Generate the docs for a given API that implements 'HasDocs'. This is the
278292-- default way to create documentation.
279−docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
280−docs p = docsFor (canonicalize p) (defEndpoint, defAction)
293+docs :: HasDocs layout => Proxy layout -> API
294+docs p = docsFor p (defEndpoint, defAction)
281295
282296-- | Closed type family, check if endpoint is exactly within API.
283297
@@ -321,11 +335,7 @@ extraInfo p action =
321335-- 'extraInfo'.
322336--
323337-- If you only want to add an introduction, use 'docsWithIntros'.
324−docsWith :: HasDocs (Canonicalize layout)
325− => [DocIntro]
326− -> ExtraInfo layout
327− -> Proxy layout
328− -> API
338+docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
329339docsWith intros (ExtraInfo endpoints) p =
330340 docs p & apiIntros <>~ intros
331341 & apiEndpoints %~ HM.unionWith combineAction endpoints
@@ -333,7 +343,7 @@ docsWith intros (ExtraInfo endpoints) p =
333343
334344-- | Generate the docs for a given API that implements 'HasDocs' with with any
335345-- number of introduction(s)
336−docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
346+docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
337347docsWithIntros intros = docsWith intros mempty
338348
339349-- | The class that abstracts away the impact of API combinators
@@ -362,8 +372,8 @@ class HasDocs layout where
362372-- > instance FromJSON Greet
363373-- > instance ToJSON Greet
364374-- >
365−-- > instance ToSample Greet where
366−-- > toSample = Just g
375+-- > instance ToSample Greet Greet where
376+-- > toSample _ = Just g
367377-- >
368378-- > where g = Greet "Hello, haskeller!"
369379--
@@ -371,34 +381,53 @@ class HasDocs layout where
371381-- 'toSample': it lets you specify different responses along with
372382-- some context (as 'Text') that explains when you're supposed to
373383-- get the corresponding response.
374−class ToSample a where
384+class ToSample a b | a -> b where
375385 {-# MINIMAL (toSample | toSamples) #-}
376− toSample :: Maybe a
377− toSample = snd <$> listToMaybe samples
378− where samples = toSamples :: [(Text, a)]
386+ toSample :: Proxy a -> Maybe b
387+ toSample _ = snd <$> listToMaybe samples
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+
379398
380− toSamples :: [(Text, a)]
381− toSamples = maybe [] (return . ("",)) s
382− where s = toSample :: Maybe a
399+class AllHeaderSamples ls where
400+ allHeaderToSample :: Proxy ls -> [HTTP.Header]
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>")
383412
384413-- | Synthesise a sample value of a type, encoded in the specified media types.
385414sampleByteString
386− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
415+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
387416 => Proxy ctypes
388417 -> Proxy a
389418 -> [(M.MediaType, ByteString)]
390419sampleByteString ctypes@Proxy Proxy =
391− maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
420+ maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
392421
393422-- | Synthesise a list of sample values of a particular type, encoded in the
394423-- specified media types.
395424sampleByteStrings
396− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
425+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
397426 => Proxy ctypes
398427 -> Proxy a
399428 -> [(Text, M.MediaType, ByteString)]
400429sampleByteStrings ctypes@Proxy Proxy =
401− let samples = toSamples :: [(Text, a)]
430+ let samples = toSamples (Proxy :: Proxy a)
402431 enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
403432 in concatMap enc samples
404433
@@ -580,6 +609,7 @@ markdown api = unlines $
580609 "#### Response:" :
581610 "" :
582611 ("- Status code " ++ show (resp ^. respStatus)) :
612+ ("- Headers: " ++ show (resp ^. respHeaders)) :
583613 "" :
584614 formatTypes (resp ^. respTypes) ++
585615 bodies
@@ -630,7 +660,11 @@ instance HasDocs Delete where
630660 action' = action & response.respBody .~ []
631661 & response.respStatus .~ 204
632662
633−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
663+instance
664+#if MIN_VERSION_base(4,8,0)
665+ {-# OVERLAPPABLe #-}
666+#endif
667+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
634668 => HasDocs (Get cts a) where
635669 docsFor Proxy (endpoint, action) =
636670 single endpoint' action'
@@ -641,6 +675,24 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
641675 t = Proxy :: Proxy cts
642676 p = Proxy :: Proxy a
643677
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+
644696instance (KnownSymbol sym, HasDocs sublayout)
645697 => HasDocs (Header sym a :> sublayout) where
646698 docsFor Proxy (endpoint, action) =
@@ -650,7 +702,11 @@ instance (KnownSymbol sym, HasDocs sublayout)
650702 action' = over headers (|> headername) action
651703 headername = pack $ symbolVal (Proxy :: Proxy sym)
652704
653−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
705+instance
706+#if MIN_VERSION_base(4,8,0)
707+ {-# OVERLAPPABLE #-}
708+#endif
709+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
654710 => HasDocs (Post cts a) where
655711 docsFor Proxy (endpoint, action) =
656712 single endpoint' action'
@@ -662,7 +718,30 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
662718 t = Proxy :: Proxy cts
663719 p = Proxy :: Proxy a
664720
665−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
721+instance
722+#if MIN_VERSION_base(4,8,0)
723+ {-# OVERLAPPING #-}
724+#endif
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)
666745 => HasDocs (Put cts a) where
667746 docsFor Proxy (endpoint, action) =
668747 single endpoint' action'
@@ -674,6 +753,25 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
674753 t = Proxy :: Proxy cts
675754 p = Proxy :: Proxy a
676755
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+
677775instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
678776 => HasDocs (QueryParam sym a :> sublayout) where
679777
@@ -756,7 +854,8 @@ instance HasDocs Raw where
756854-- example data. However, there's no reason to believe that the instances of
757855-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
758856-- 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)
760859 => HasDocs (ReqBody cts a :> sublayout) where
761860
762861 docsFor Proxy (endpoint, action) =
servant-docs/test/Servant/DocsSpec.hs+6−6
@@ -46,14 +46,14 @@ data Datatype1 = Datatype1 { dt1field1 :: String
4646
4747instance ToJSON Datatype1
4848
49−instance ToSample Datatype1 where
50− toSample = Just $ Datatype1 "field 1" 13
49+instance ToSample Datatype1 Datatype1 where
50+ toSample _ = Just $ Datatype1 "field 1" 13
5151
52−instance ToSample String where
53− toSample = Just "a string"
52+instance ToSample String String where
53+ toSample _ = Just "a string"
5454
55−instance ToSample Int where
56− toSample = Just 17
55+instance ToSample Int Int where
56+ toSample _ = Just 17
5757
5858instance MimeRender PlainText Int where
5959 mimeRender _ = cs . show
servant-examples/auth-combinator/auth-combinator.hs+2−2
@@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password")
2626data AuthProtected
2727
2828instance HasServer rest => HasServer (AuthProtected :> rest) where
29− type ServerT' (AuthProtected :> rest) m = ServerT' rest m
29+ type ServerT (AuthProtected :> rest) m = ServerT rest m
3030
3131 route Proxy a request respond =
3232 case lookup "Cookie" (requestHeaders request) of
@@ -75,4 +75,4 @@ $ curl -H "Cookie: good password" http://localhost:8080/private
7575[{"ssshhh":"this is a secret"}]
7676$ curl -H "Cookie: bad password" http://localhost:8080/private
7777Invalid cookie.
78−-}
78+-}
servant-jquery/src/Servant/JQuery.hs+3−4
@@ -26,8 +26,8 @@ import Data.Proxy
2626import Servant.API
2727import Servant.JQuery.Internal
2828
29−jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
30−jquery p = jqueryFor (canonicalize p) defReq
29+jquery :: HasJQ layout => Proxy layout -> JQ layout
30+jquery p = jqueryFor p defReq
3131
3232-- js codegen
3333generateJS :: AjaxReq -> String
@@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
112112-- | Directly generate all the javascript functions for your API
113113-- from a 'Proxy' for your API type. You can then write it to
114114-- a file or integrate it in a page, for example.
115−jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
116− => Proxy api -> String
115+jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
117116jsForAPI p = jsFor (jquery p)
servant-jquery/src/Servant/JQuery/Internal.hs+18−20
@@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
194194 Elem a (b ': list) = Elem a list
195195
196196class HasJQ (layout :: *) where
197− type JQ' layout :: *
198− jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
199−
200−type JQ layout = JQ' (Canonicalize layout)
197+ type JQ layout :: *
198+ jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
201199
202200instance (HasJQ a, HasJQ b)
203201 => HasJQ (a :<|> b) where
204− type JQ' (a :<|> b) = JQ' a :<|> JQ' b
202+ type JQ (a :<|> b) = JQ a :<|> JQ b
205203
206204 jqueryFor Proxy req =
207205 jqueryFor (Proxy :: Proxy a) req
@@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
209207
210208instance (KnownSymbol sym, HasJQ sublayout)
211209 => HasJQ (Capture sym a :> sublayout) where
212− type JQ' (Capture sym a :> sublayout) = JQ' sublayout
210+ type JQ (Capture sym a :> sublayout) = JQ sublayout
213211
214212 jqueryFor Proxy req =
215213 jqueryFor (Proxy :: Proxy sublayout) $
@@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
218216 where str = symbolVal (Proxy :: Proxy sym)
219217
220218instance HasJQ Delete where
221− type JQ' Delete = AjaxReq
219+ type JQ Delete = AjaxReq
222220
223221 jqueryFor Proxy req =
224222 req & funcName %~ ("delete" <>)
225223 & reqMethod .~ "DELETE"
226224
227225instance Elem JSON list => HasJQ (Get list a) where
228− type JQ' (Get list a) = AjaxReq
226+ type JQ (Get list a) = AjaxReq
229227
230228 jqueryFor Proxy req =
231229 req & funcName %~ ("get" <>)
@@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
233231
234232instance (KnownSymbol sym, HasJQ sublayout)
235233 => HasJQ (Header sym a :> sublayout) where
236− type JQ' (Header sym a :> sublayout) = JQ' sublayout
234+ type JQ (Header sym a :> sublayout) = JQ sublayout
237235
238236 jqueryFor Proxy req =
239237 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
@@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
242240 subP = Proxy :: Proxy sublayout
243241
244242instance Elem JSON list => HasJQ (Post list a) where
245− type JQ' (Post list a) = AjaxReq
243+ type JQ (Post list a) = AjaxReq
246244
247245 jqueryFor Proxy req =
248246 req & funcName %~ ("post" <>)
249247 & reqMethod .~ "POST"
250248
251249instance Elem JSON list => HasJQ (Put list a) where
252− type JQ' (Put list a) = AjaxReq
250+ type JQ (Put list a) = AjaxReq
253251
254252 jqueryFor Proxy req =
255253 req & funcName %~ ("put" <>)
@@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
257255
258256instance (KnownSymbol sym, HasJQ sublayout)
259257 => HasJQ (QueryParam sym a :> sublayout) where
260− type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
258+ type JQ (QueryParam sym a :> sublayout) = JQ sublayout
261259
262260 jqueryFor Proxy req =
263261 jqueryFor (Proxy :: Proxy sublayout) $
@@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
267265
268266instance (KnownSymbol sym, HasJQ sublayout)
269267 => HasJQ (QueryParams sym a :> sublayout) where
270− type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
268+ type JQ (QueryParams sym a :> sublayout) = JQ sublayout
271269
272270 jqueryFor Proxy req =
273271 jqueryFor (Proxy :: Proxy sublayout) $
@@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
277275
278276instance (KnownSymbol sym, HasJQ sublayout)
279277 => HasJQ (QueryFlag sym :> sublayout) where
280− type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
278+ type JQ (QueryFlag sym :> sublayout) = JQ sublayout
281279
282280 jqueryFor Proxy req =
283281 jqueryFor (Proxy :: Proxy sublayout) $
@@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
287285
288286instance (KnownSymbol sym, HasJQ sublayout)
289287 => HasJQ (MatrixParam sym a :> sublayout) where
290− type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
288+ type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
291289
292290 jqueryFor Proxy req =
293291 jqueryFor (Proxy :: Proxy sublayout) $
@@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
298296
299297instance (KnownSymbol sym, HasJQ sublayout)
300298 => HasJQ (MatrixParams sym a :> sublayout) where
301− type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
299+ type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
302300
303301 jqueryFor Proxy req =
304302 jqueryFor (Proxy :: Proxy sublayout) $
@@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
308306
309307instance (KnownSymbol sym, HasJQ sublayout)
310308 => HasJQ (MatrixFlag sym :> sublayout) where
311− type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
309+ type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
312310
313311 jqueryFor Proxy req =
314312 jqueryFor (Proxy :: Proxy sublayout) $
@@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
317315 where str = symbolVal (Proxy :: Proxy sym)
318316
319317instance HasJQ Raw where
320− type JQ' Raw = Method -> AjaxReq
318+ type JQ Raw = Method -> AjaxReq
321319
322320 jqueryFor Proxy req method =
323321 req & funcName %~ ((toLower <$> method) <>)
324322 & reqMethod .~ method
325323
326324instance (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
328326
329327 jqueryFor Proxy req =
330328 jqueryFor (Proxy :: Proxy sublayout) $
@@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
332330
333331instance (KnownSymbol path, HasJQ sublayout)
334332 => HasJQ (path :> sublayout) where
335− type JQ' (path :> sublayout) = JQ' sublayout
333+ type JQ (path :> sublayout) = JQ sublayout
336334
337335 jqueryFor Proxy req =
338336 jqueryFor (Proxy :: Proxy sublayout) $
servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs+3−3
@@ -22,7 +22,7 @@ data Authorization (sym :: Symbol) a
2222
2323instance (KnownSymbol sym, HasJQ sublayout)
2424 => HasJQ (Authorization sym a :> sublayout) where
25− type JQ' (Authorization sym a :> sublayout) = JQ' sublayout
25+ type JQ (Authorization sym a :> sublayout) = JQ sublayout
2626
2727 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
2828 req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
@@ -35,7 +35,7 @@ data MyLovelyHorse a
3535
3636instance (HasJQ sublayout)
3737 => HasJQ (MyLovelyHorse a :> sublayout) where
38− type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout
38+ type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout
3939
4040 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
4141 req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
@@ -47,7 +47,7 @@ data WhatsForDinner a
4747
4848instance (HasJQ sublayout)
4949 => HasJQ (WhatsForDinner a :> sublayout) where
50− type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout
50+ type JQ (WhatsForDinner a :> sublayout) = JQ sublayout
5151
5252 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
5353 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 @@
55* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
66* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
77* 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`
98* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
109* 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
1113
12140.2.4
1315-----
servant-server/servant-server.cabal+16
@@ -36,6 +36,8 @@ library
3636 Servant
3737 Servant.Server
3838 Servant.Server.Internal
39+ Servant.Server.Internal.ServantErr
40+ Servant.Server.Internal.Enter
3941 Servant.Utils.StaticFiles
4042 build-depends:
4143 base >= 4.7 && < 5
@@ -45,6 +47,8 @@ library
4547 , either >= 4.3 && < 4.4
4648 , http-types >= 0.8 && < 0.9
4749 , network-uri >= 2.6 && < 2.7
50+ , mtl >= 2 && < 3
51+ , mmorph >= 1
4852 , safe >= 0.3 && < 0.4
4953 , servant >= 0.2 && < 0.4
5054 , split >= 0.2 && < 0.3
@@ -100,6 +104,18 @@ test-suite spec
100104 , temporary
101105 , text
102106 , transformers
107+ , mtl
103108 , wai
104109 , wai-extra
105110 , 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 #-}
2−{-# LANGUAGE FlexibleContexts #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeFamilies #-}
45
56-- | This module lets you implement 'Server's for defined APIs. You'll
67-- most likely just need 'serve'.
@@ -14,13 +15,73 @@ module Servant.Server
1415 , -- * Handlers for all standard combinators
1516 HasServer(..)
1617 , 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+
1878 ) where
1979
20−import Data.Proxy (Proxy)
21−import Network.Wai (Application)
22−import Servant.API (Canonicalize, canonicalize)
23−import Servant.Server.Internal
80+import Data.Proxy (Proxy)
81+import Network.Wai (Application)
82+import Servant.Server.Internal
83+import Servant.Server.Internal.Enter
84+import Servant.Server.Internal.ServantErr
2485
2586
2687-- * Implementing Servers
@@ -45,5 +106,30 @@ import Servant.Server.Internal
45106-- >
46107-- > main :: IO ()
47108-- > main = Network.Wai.Handler.Warp.run 8080 app
48−serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
49−serve p server = toApplication (route (canonicalize p) server)
109+--
110+serve :: HasServer layout => Proxy layout -> Server layout -> Application
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,
3838 requestMethod, responseLBS,
3939 strictRequestBody)
4040import Servant.API ((:<|>) (..), (:>), Capture,
41− Canonicalize, Delete, Get, Header,
41+ Delete, Get, Header,
4242 MatrixFlag, MatrixParam, MatrixParams,
4343 Patch, Post, Put, QueryFlag,
4444 QueryParam, QueryParams, Raw,
@@ -46,9 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Capture,
4646import Servant.API.ContentTypes (AcceptHeader (..),
4747 AllCTRender (..),
4848 AllCTUnrender (..))
49−import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
49+import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
50+ getHeaders)
5051import Servant.Common.Text (FromText, fromText)
5152
53+import Servant.Server.Internal.ServantErr
54+
5255data ReqBodyState = Uncalled
5356 | Called !B.ByteString
5457 | Done !B.ByteString
@@ -174,13 +177,11 @@ processedPathInfo r =
174177 where pinfo = parsePathInfo r
175178
176179class HasServer layout where
177− type ServerT' layout (m :: * -> *) :: *
180+ type ServerT layout (m :: * -> *) :: *
178181
179− route :: Proxy layout -> Server' layout -> RoutingApplication
182+ route :: Proxy layout -> Server layout -> RoutingApplication
180183
181−type Server layout = Server' (Canonicalize layout)
182−type Server' layout = ServerT' layout (EitherT (Int, String) IO)
183−type ServerT layout m = ServerT' (Canonicalize layout) m
184+type Server layout = ServerT layout (EitherT ServantErr IO)
184185
185186-- * Instances
186187
@@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
197198-- > postBook book = ...
198199instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
199200
200− type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
201+ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
201202
202203 route Proxy (a :<|> b) request respond =
203204 route pa a request $ \mResponse ->
@@ -231,8 +232,8 @@ captured _ = fromText
231232instance (KnownSymbol capture, FromText a, HasServer sublayout)
232233 => HasServer (Capture capture a :> sublayout) where
233234
234− type ServerT' (Capture capture a :> sublayout) m =
235− a -> ServerT' sublayout m
235+ type ServerT (Capture capture a :> sublayout) m =
236+ a -> ServerT sublayout m
236237
237238 route Proxy subserver request respond = case processedPathInfo request of
238239 (first : rest)
@@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
259260-- are not met.
260261instance HasServer Delete where
261262
262− type ServerT' Delete m = m ()
263+ type ServerT Delete m = m ()
263264
264265 route Proxy action request respond
265266 | pathIsEmpty request && requestMethod request == methodDelete = do
266267 e <- runEitherT action
267268 respond $ succeedWith $ case e of
268− Right () ->
269− responseLBS status204 [] ""
270− Left (status, message) ->
271− responseLBS (mkStatus status (cs message)) [] (cs message)
269+ Right () -> responseLBS status204 [] ""
270+ Left err -> responseServantErr err
272271 | pathIsEmpty request && requestMethod request /= methodDelete =
273272 respond $ failWith WrongMethod
274273 | otherwise = respond $ failWith NotFound
@@ -292,7 +291,7 @@ instance
292291#endif
293292 ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
294293
295− type ServerT' (Get ctypes a) m = m a
294+ type ServerT (Get ctypes a) m = m a
296295
297296 route Proxy action request respond
298297 | pathIsEmpty request && requestMethod request == methodGet = do
@@ -304,8 +303,7 @@ instance
304303 Nothing -> failWith UnsupportedMediaType
305304 Just (contentT, body) -> succeedWith $
306305 responseLBS ok200 [ ("Content-Type" , cs contentT)] body
307− Left (status, message) -> succeedWith $
308− responseLBS (mkStatus status (cs message)) [] (cs message)
306+ Left err -> succeedWith $ responseServantErr err
309307 | pathIsEmpty request && requestMethod request /= methodGet =
310308 respond $ failWith WrongMethod
311309 | otherwise = respond $ failWith NotFound
@@ -317,15 +315,14 @@ instance
317315#endif
318316 HasServer (Get ctypes ()) where
319317
320− type ServerT' (Get ctypes ()) m = m ()
318+ type ServerT (Get ctypes ()) m = m ()
321319
322320 route Proxy action request respond
323321 | pathIsEmpty request && requestMethod request == methodGet = do
324322 e <- runEitherT action
325323 respond . succeedWith $ case e of
326324 Right () -> responseLBS noContent204 [] ""
327− Left (status, message) ->
328− responseLBS (mkStatus status (cs message)) [] (cs message)
325+ Left err -> responseServantErr err
329326 | pathIsEmpty request && requestMethod request /= methodGet =
330327 respond $ failWith WrongMethod
331328 | otherwise = respond $ failWith NotFound
@@ -335,9 +332,10 @@ instance
335332#if MIN_VERSION_base(4,8,0)
336333 {-# OVERLAPPING #-}
337334#endif
338− ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
335+ ( GetHeaders (Headers h v), AllCTRender ctypes v
336+ ) => HasServer (Get ctypes (Headers h v)) where
339337
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)
341339
342340 route Proxy action request respond
343341 | pathIsEmpty request && requestMethod request == methodGet = do
@@ -350,8 +348,7 @@ instance
350348 Nothing -> failWith UnsupportedMediaType
351349 Just (contentT, body) -> succeedWith $
352350 responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
353− Left (status, message) -> succeedWith $
354− responseLBS (mkStatus status (cs message)) [] (cs message)
351+ Left err -> succeedWith $ responseServantErr err
355352 | pathIsEmpty request && requestMethod request /= methodGet =
356353 respond $ failWith WrongMethod
357354 | otherwise = respond $ failWith NotFound
@@ -379,8 +376,8 @@ instance
379376instance (KnownSymbol sym, FromText a, HasServer sublayout)
380377 => HasServer (Header sym a :> sublayout) where
381378
382− type ServerT' (Header sym a :> sublayout) m =
383− Maybe a -> ServerT' sublayout m
379+ type ServerT (Header sym a :> sublayout) m =
380+ Maybe a -> ServerT sublayout m
384381
385382 route Proxy subserver request respond = do
386383 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@@ -408,7 +405,7 @@ instance
408405 ( AllCTRender ctypes a
409406 ) => HasServer (Post ctypes a) where
410407
411− type ServerT' (Post ctypes a) m = m a
408+ type ServerT (Post ctypes a) m = m a
412409
413410 route Proxy action request respond
414411 | pathIsEmpty request && requestMethod request == methodPost = do
@@ -420,8 +417,7 @@ instance
420417 Nothing -> failWith UnsupportedMediaType
421418 Just (contentT, body) -> succeedWith $
422419 responseLBS status201 [ ("Content-Type" , cs contentT)] body
423− Left (status, message) -> succeedWith $
424− responseLBS (mkStatus status (cs message)) [] (cs message)
420+ Left err -> succeedWith $ responseServantErr err
425421 | pathIsEmpty request && requestMethod request /= methodPost =
426422 respond $ failWith WrongMethod
427423 | otherwise = respond $ failWith NotFound
@@ -432,15 +428,14 @@ instance
432428#endif
433429 HasServer (Post ctypes ()) where
434430
435− type ServerT' (Post ctypes ()) m = m ()
431+ type ServerT (Post ctypes ()) m = m ()
436432
437433 route Proxy action request respond
438434 | pathIsEmpty request && requestMethod request == methodPost = do
439435 e <- runEitherT action
440436 respond . succeedWith $ case e of
441437 Right () -> responseLBS noContent204 [] ""
442− Left (status, message) ->
443− responseLBS (mkStatus status (cs message)) [] (cs message)
438+ Left err -> responseServantErr err
444439 | pathIsEmpty request && requestMethod request /= methodPost =
445440 respond $ failWith WrongMethod
446441 | otherwise = respond $ failWith NotFound
@@ -450,9 +445,10 @@ instance
450445#if MIN_VERSION_base(4,8,0)
451446 {-# OVERLAPPING #-}
452447#endif
453− ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
448+ ( GetHeaders (Headers h v), AllCTRender ctypes v
449+ ) => HasServer (Post ctypes (Headers h v)) where
454450
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)
456452
457453 route Proxy action request respond
458454 | pathIsEmpty request && requestMethod request == methodPost = do
@@ -465,8 +461,7 @@ instance
465461 Nothing -> failWith UnsupportedMediaType
466462 Just (contentT, body) -> succeedWith $
467463 responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
468− Left (status, message) -> succeedWith $
469− responseLBS (mkStatus status (cs message)) [] (cs message)
464+ Left err -> succeedWith $ responseServantErr err
470465 | pathIsEmpty request && requestMethod request /= methodPost =
471466 respond $ failWith WrongMethod
472467 | otherwise = respond $ failWith NotFound
@@ -490,7 +485,7 @@ instance
490485#endif
491486 ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
492487
493− type ServerT' (Put ctypes a) m = m a
488+ type ServerT (Put ctypes a) m = m a
494489
495490 route Proxy action request respond
496491 | pathIsEmpty request && requestMethod request == methodPut = do
@@ -502,8 +497,7 @@ instance
502497 Nothing -> failWith UnsupportedMediaType
503498 Just (contentT, body) -> succeedWith $
504499 responseLBS status200 [ ("Content-Type" , cs contentT)] body
505− Left (status, message) -> succeedWith $
506− responseLBS (mkStatus status (cs message)) [] (cs message)
500+ Left err -> succeedWith $ responseServantErr err
507501 | pathIsEmpty request && requestMethod request /= methodPut =
508502 respond $ failWith WrongMethod
509503 | otherwise = respond $ failWith NotFound
@@ -514,15 +508,14 @@ instance
514508#endif
515509 HasServer (Put ctypes ()) where
516510
517− type ServerT' (Put ctypes ()) m = m ()
511+ type ServerT (Put ctypes ()) m = m ()
518512
519513 route Proxy action request respond
520514 | pathIsEmpty request && requestMethod request == methodPut = do
521515 e <- runEitherT action
522516 respond . succeedWith $ case e of
523517 Right () -> responseLBS noContent204 [] ""
524− Left (status, message) ->
525− responseLBS (mkStatus status (cs message)) [] (cs message)
518+ Left err -> responseServantErr err
526519 | pathIsEmpty request && requestMethod request /= methodPut =
527520 respond $ failWith WrongMethod
528521 | otherwise = respond $ failWith NotFound
@@ -532,9 +525,10 @@ instance
532525#if MIN_VERSION_base(4,8,0)
533526 {-# OVERLAPPING #-}
534527#endif
535− ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
528+ ( GetHeaders (Headers h v), AllCTRender ctypes v
529+ ) => HasServer (Put ctypes (Headers h v)) where
536530
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)
538532
539533 route Proxy action request respond
540534 | pathIsEmpty request && requestMethod request == methodPut = do
@@ -547,8 +541,7 @@ instance
547541 Nothing -> failWith UnsupportedMediaType
548542 Just (contentT, body) -> succeedWith $
549543 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
550− Left (status, message) -> succeedWith $
551− responseLBS (mkStatus status (cs message)) [] (cs message)
544+ Left err -> succeedWith $ responseServantErr err
552545 | pathIsEmpty request && requestMethod request /= methodPut =
553546 respond $ failWith WrongMethod
554547 | otherwise = respond $ failWith NotFound
@@ -570,7 +563,7 @@ instance
570563#endif
571564 ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
572565
573− type ServerT' (Patch ctypes a) m = m a
566+ type ServerT (Patch ctypes a) m = m a
574567
575568 route Proxy action request respond
576569 | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -582,8 +575,7 @@ instance
582575 Nothing -> failWith UnsupportedMediaType
583576 Just (contentT, body) -> succeedWith $
584577 responseLBS status200 [ ("Content-Type" , cs contentT)] body
585− Left (status, message) -> succeedWith $
586− responseLBS (mkStatus status (cs message)) [] (cs message)
578+ Left err -> succeedWith $ responseServantErr err
587579 | pathIsEmpty request && requestMethod request /= methodPatch =
588580 respond $ failWith WrongMethod
589581 | otherwise = respond $ failWith NotFound
@@ -594,15 +586,14 @@ instance
594586#endif
595587 HasServer (Patch ctypes ()) where
596588
597− type ServerT' (Patch ctypes ()) m = m ()
589+ type ServerT (Patch ctypes ()) m = m ()
598590
599591 route Proxy action request respond
600592 | pathIsEmpty request && requestMethod request == methodPatch = do
601593 e <- runEitherT action
602594 respond . succeedWith $ case e of
603595 Right () -> responseLBS noContent204 [] ""
604− Left (status, message) ->
605− responseLBS (mkStatus status (cs message)) [] (cs message)
596+ Left err -> responseServantErr err
606597 | pathIsEmpty request && requestMethod request /= methodPatch =
607598 respond $ failWith WrongMethod
608599 | otherwise = respond $ failWith NotFound
@@ -612,9 +603,10 @@ instance
612603#if MIN_VERSION_base(4,8,0)
613604 {-# OVERLAPPING #-}
614605#endif
615− ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
606+ ( GetHeaders (Headers h v), AllCTRender ctypes v
607+ ) => HasServer (Patch ctypes (Headers h v)) where
616608
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)
618610
619611 route Proxy action request respond
620612 | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -627,8 +619,7 @@ instance
627619 Nothing -> failWith UnsupportedMediaType
628620 Just (contentT, body) -> succeedWith $
629621 responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
630− Left (status, message) -> succeedWith $
631− responseLBS (mkStatus status (cs message)) [] (cs message)
622+ Left err -> succeedWith $ responseServantErr err
632623 | pathIsEmpty request && requestMethod request /= methodPatch =
633624 respond $ failWith WrongMethod
634625 | otherwise = respond $ failWith NotFound
@@ -657,8 +648,8 @@ instance
657648instance (KnownSymbol sym, FromText a, HasServer sublayout)
658649 => HasServer (QueryParam sym a :> sublayout) where
659650
660− type ServerT' (QueryParam sym a :> sublayout) m =
661− Maybe a -> ServerT' sublayout m
651+ type ServerT (QueryParam sym a :> sublayout) m =
652+ Maybe a -> ServerT sublayout m
662653
663654 route Proxy subserver request respond = do
664655 let querytext = parseQueryText $ rawQueryString request
@@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
695686instance (KnownSymbol sym, FromText a, HasServer sublayout)
696687 => HasServer (QueryParams sym a :> sublayout) where
697688
698− type ServerT' (QueryParams sym a :> sublayout) m =
699− [a] -> ServerT' sublayout m
689+ type ServerT (QueryParams sym a :> sublayout) m =
690+ [a] -> ServerT sublayout m
700691
701692 route Proxy subserver request respond = do
702693 let querytext = parseQueryText $ rawQueryString request
@@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
728719instance (KnownSymbol sym, HasServer sublayout)
729720 => HasServer (QueryFlag sym :> sublayout) where
730721
731− type ServerT' (QueryFlag sym :> sublayout) m =
732− Bool -> ServerT' sublayout m
722+ type ServerT (QueryFlag sym :> sublayout) m =
723+ Bool -> ServerT sublayout m
733724
734725 route Proxy subserver request respond = do
735726 let querytext = parseQueryText $ rawQueryString request
@@ -771,8 +762,8 @@ parseMatrixText = parseQueryText
771762instance (KnownSymbol sym, FromText a, HasServer sublayout)
772763 => HasServer (MatrixParam sym a :> sublayout) where
773764
774− type ServerT' (MatrixParam sym a :> sublayout) m =
775− Maybe a -> ServerT' sublayout m
765+ type ServerT (MatrixParam sym a :> sublayout) m =
766+ Maybe a -> ServerT sublayout m
776767
777768 route Proxy subserver request respond = case parsePathInfo request of
778769 (first : _)
@@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
809800instance (KnownSymbol sym, FromText a, HasServer sublayout)
810801 => HasServer (MatrixParams sym a :> sublayout) where
811802
812− type ServerT' (MatrixParams sym a :> sublayout) m =
813− [a] -> ServerT' sublayout m
803+ type ServerT (MatrixParams sym a :> sublayout) m =
804+ [a] -> ServerT sublayout m
814805
815806 route Proxy subserver request respond = case parsePathInfo request of
816807 (first : _)
@@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
843834instance (KnownSymbol sym, HasServer sublayout)
844835 => HasServer (MatrixFlag sym :> sublayout) where
845836
846− type ServerT' (MatrixFlag sym :> sublayout) m =
847− Bool -> ServerT' sublayout m
837+ type ServerT (MatrixFlag sym :> sublayout) m =
838+ Bool -> ServerT sublayout m
848839
849840 route Proxy subserver request respond = case parsePathInfo request of
850841 (first : _)
@@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
872863-- > server = serveDirectory "/var/www/images"
873864instance HasServer Raw where
874865
875− type ServerT' Raw m = Application
866+ type ServerT Raw m = Application
876867
877868 route Proxy rawApplication request respond =
878869 rawApplication request (respond . succeedWith)
@@ -900,8 +891,8 @@ instance HasServer Raw where
900891instance ( AllCTUnrender list a, HasServer sublayout
901892 ) => HasServer (ReqBody list a :> sublayout) where
902893
903− type ServerT' (ReqBody list a :> sublayout) m =
904− a -> ServerT' sublayout m
894+ type ServerT (ReqBody list a :> sublayout) m =
895+ a -> ServerT sublayout m
905896
906897 route Proxy subserver request respond = do
907898 -- See HTTP RFC 2616, section 7.2.1
@@ -921,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
921912-- pass the rest of the request path to @sublayout@.
922913instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
923914
924− type ServerT' (path :> sublayout) m = ServerT' sublayout m
915+ type ServerT (path :> sublayout) m = ServerT sublayout m
925916
926917 route Proxy subserver request respond = case processedPathInfo request of
927918 (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,
3535 shouldRespondWith, with, (<:>))
3636
3737import Servant.API ((:<|>) (..), (:>),
38− AddHeader (addHeader), Capture,
38+ addHeader, Capture,
3939 Delete, Get, Header (..), Headers,
4040 JSON, MatrixFlag, MatrixParam,
4141 MatrixParams, Patch, PlainText,
4242 Post, Put, QueryFlag, QueryParam,
4343 QueryParams, Raw, ReqBody)
44−import Servant.Server (Server, serve)
44+import Servant.Server (Server, serve, ServantErr(..), err404)
4545import Servant.Server.Internal (RouteMismatch (..))
4646
4747
@@ -96,11 +96,11 @@ spec = do
9696type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
9797captureApi :: Proxy CaptureApi
9898captureApi = Proxy
99−captureServer :: Integer -> EitherT (Int, String) IO Animal
99+captureServer :: Integer -> EitherT ServantErr IO Animal
100100captureServer legs = case legs of
101101 4 -> return jerry
102102 2 -> return tweety
103− _ -> left (404, "not found")
103+ _ -> left err404
104104
105105captureSpec :: Spec
106106captureSpec = do
@@ -450,11 +450,11 @@ headerApi = Proxy
450450headerSpec :: Spec
451451headerSpec = describe "Servant.API.Header" $ do
452452
453− let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
453+ let expectsInt :: Maybe Int -> EitherT ServantErr IO ()
454454 expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
455455 expectsInt Nothing = error "Expected an int"
456456
457− let expectsString :: Maybe String -> EitherT (Int,String) IO ()
457+ let expectsString :: Maybe String -> EitherT ServantErr IO ()
458458 expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
459459 expectsString Nothing = error "Expected a string"
460460
servant/CHANGELOG.md−1
@@ -1,6 +1,5 @@
110.3
22---
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*.
43* Multiple content-type/accept support for all the relevant combinators
54* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
65* 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 #-}
2−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE TypeOperators #-}
33{-# LANGUAGE UndecidableInstances #-}
44module Servant.API (
55
@@ -49,26 +49,21 @@ module Servant.API (
4949 module Servant.Common.Text,
5050 -- | Classes and instances for types that can be converted to and from @Text@
5151
52− -- * Canonicalizing (flattening) API types
53− Canonicalize,
54− canonicalize,
55−
5652 -- * Utilities
5753 module Servant.Utils.Links,
5854 -- | Type-safe internal URIs
5955 ) where
6056
61−import Data.Proxy (Proxy (..))
6257import Servant.API.Alternative ((:<|>) (..))
6358import Servant.API.Capture (Capture)
64−import Servant.API.ContentTypes (FormUrlEncoded,
59+import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
6560 FromFormUrlEncoded (..), JSON,
6661 MimeRender (..),
6762 MimeUnrender (..), OctetStream,
6863 PlainText, ToFormUrlEncoded (..))
6964import Servant.API.Delete (Delete)
7065import Servant.API.Get (Get)
71−import Servant.API.Header (Header(..))
66+import Servant.API.Header (Header (..))
7267import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
7368 MatrixParams)
7469import Servant.API.Patch (Patch)
@@ -78,40 +73,13 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
7873 QueryParams)
7974import Servant.API.Raw (Raw)
8075import Servant.API.ReqBody (ReqBody)
81−import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
82− , AddHeader(addHeader) )
76+import Servant.API.ResponseHeaders (AddHeader (addHeader),
77+ BuildHeadersTo (buildHeadersTo),
78+ GetHeaders (getHeaders),
79+ HList (..), Headers (..),
80+ getHeadersHList, getResponse)
8381import Servant.API.Sub ((:>))
8482import Servant.Common.Text (FromText (..), ToText (..))
8583import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
8684 URI (..), safeLink)
8785
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 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE TypeOperators #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Alternative ((:<|>)(..)) where
56
67#if !MIN_VERSION_base(4,8,0)
servant/src/Servant/API/Capture.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Capture (Capture) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/ContentTypes.hs+1
@@ -10,6 +10,7 @@
1010{-# LANGUAGE TypeFamilies #-}
1111{-# LANGUAGE TypeOperators #-}
1212{-# LANGUAGE UndecidableInstances #-}
13+{-# OPTIONS_HADDOCK not-home #-}
1314
1415-- | A collection of basic Content-Types (also known as Internet Media
1516-- Types, or MIME types). Additionally, this module provides classes that
servant/src/Servant/API/Delete.hs+1
@@ -1,4 +1,5 @@
11{-# LANGUAGE DeriveDataTypeable #-}
2+{-# OPTIONS_HADDOCK not-home #-}
23module Servant.API.Delete (Delete) where
34
45import Data.Typeable ( Typeable )
servant/src/Servant/API/Get.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Get (Get) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/Header.hs+8−3
@@ -1,10 +1,13 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE PolyKinds #-}
5+{-# OPTIONS_HADDOCK not-home #-}
46module Servant.API.Header where
57
6−import Data.Typeable (Typeable)
7−import GHC.TypeLits (Symbol)
8+import Data.ByteString (ByteString)
9+import Data.Typeable (Typeable)
10+import GHC.TypeLits (Symbol)
811-- | Extract the given header's value as a value of type @a@.
912--
1013-- Example:
@@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol)
1417-- >>> -- GET /view-my-referer
1518-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
1619data Header (sym :: Symbol) a = Header a
17− deriving Typeable
20+ | MissingHeader
21+ | UndecodableHeader ByteString
22+ deriving (Typeable, Eq, Show, Functor)
1823
1924-- $setup
2025-- >>> import Servant.API
servant/src/Servant/API/MatrixParam.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/Patch.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Patch (Patch) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/Post.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Post (Post) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/Put.hs+3−2
@@ -1,6 +1,7 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Put (Put) where
56
67import Data.Typeable ( Typeable )
servant/src/Servant/API/QueryParam.hs+1
@@ -2,6 +2,7 @@
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE TypeOperators #-}
44{-# LANGUAGE PolyKinds #-}
5+{-# OPTIONS_HADDOCK not-home #-}
56module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
67
78import Data.Typeable (Typeable)
servant/src/Servant/API/Raw.hs+1
@@ -1,4 +1,5 @@
11{-# LANGUAGE DeriveDataTypeable #-}
2+{-# OPTIONS_HADDOCK not-home #-}
23module Servant.API.Raw where
34
45import Data.Typeable (Typeable)
servant/src/Servant/API/ReqBody.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE PolyKinds #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.ReqBody where
56
67import Data.Typeable (Typeable)
servant/src/Servant/API/ResponseHeaders.hs+105−20
@@ -9,11 +9,13 @@
99{-# LANGUAGE MultiParamTypeClasses #-}
1010{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
1213{-# LANGUAGE TypeOperators #-}
1314{-# LANGUAGE UndecidableInstances #-}
1415#if !MIN_VERSION_base(4,8,0)
1516{-# LANGUAGE OverlappingInstances #-}
1617#endif
18+{-# OPTIONS_HADDOCK not-home #-}
1719
1820-- | This module provides facilities for adding headers to a response.
1921--
@@ -22,14 +24,20 @@
2224-- The value is added to the header specified by the type (@Location@ in the
2325-- example above).
2426module Servant.API.ResponseHeaders
25− ( Headers
26− , getResponse
27− , getHeaders
27+ ( Headers(..)
2828 , AddHeader(addHeader)
29+ , BuildHeadersTo(buildHeadersTo)
30+ , GetHeaders(getHeaders)
31+ , HeaderValMap
32+ , HList(..)
2933 ) where
3034
31−import Data.ByteString.Char8 (pack)
32−import Data.ByteString.Conversion (ToByteString, toByteString')
35+#if !MIN_VERSION_base(4,8,0)
36+import Control.Applicative ((<$>))
37+#endif
38+import Data.ByteString.Char8 as BS (pack, unlines, init)
39+import Data.ByteString.Conversion (ToByteString, toByteString',
40+ FromByteString, fromByteString)
3341import qualified Data.CaseInsensitive as CI
3442import Data.Proxy
3543import GHC.TypeLits (KnownSymbol, symbolVal)
@@ -41,27 +49,102 @@ import Servant.API.Header (Header (..))
4149-- Instead, use 'addHeader'.
4250data Headers ls a = Headers { getResponse :: a
4351 -- ^ The underlying value of a 'Headers'
44− , getHeaders :: [HTTP.Header]
45− -- ^ The list of header values of a 'Headers'.
46− -- These are guaranteed to correspond with the
47− -- first type of @Headers@ if constructed with
48− -- 'addHeader'.
49− } deriving (Eq, Show, Functor)
52+ , getHeadersHList :: HList ls
53+ -- ^ HList of headers.
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
50134
51135-- We need all these fundeps to save type inference
52136class AddHeader h v orig new
53137 | 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+
55140
56141instance
57142#if MIN_VERSION_base(4,8,0)
58143 {-# OVERLAPPING #-}
59144#endif
60− ( KnownSymbol h, ToByteString v
61− ) => 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)
63− where
64− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
145+ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False
146+ ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
147+ addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
65148
66149instance
67150#if MIN_VERSION_base(4,8,0)
@@ -70,10 +153,12 @@ instance
70153 ( KnownSymbol h, ToByteString v
71154 , new ~ (Headers '[Header h v] a)
72155 ) => AddHeader h v a new where
73− addHeader a resp = Headers resp [(headerName, toByteString' a)]
74− where
75− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
156+ addHeader a resp = Headers resp (HCons (Header a) HNil)
76157
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
77162
78163-- $setup
79164-- >>> import Servant.API
servant/src/Servant/API/Sub.hs+1
@@ -1,6 +1,7 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE PolyKinds #-}
33{-# LANGUAGE TypeOperators #-}
4+{-# OPTIONS_HADDOCK not-home #-}
45module Servant.API.Sub ((:>)) where
56
67import Data.Typeable (Typeable)
servant/src/Servant/Utils/Links.hs+1
@@ -8,6 +8,7 @@
88{-# LANGUAGE TypeFamilies #-}
99{-# LANGUAGE TypeOperators #-}
1010{-# LANGUAGE UndecidableInstances #-}
11+{-# OPTIONS_HADDOCK not-home #-}
1112
1213-- | Type safe generation of internal links.
1314--
sources.txt+2
@@ -4,3 +4,5 @@ servant-docs
44servant-jquery
55servant-server
66servant-examples
7+servant-blaze
8+servant-lucid