git.iko.soy/typeable/servant
on master help sign in
Merge pull request #28 from haskell-servant/jkarni/response-headers

Add response headers.

commit68a129dcd30bfe53137ad6d9c53bf6c3523e80c2 authorJulian Arni <jkarni@gmail.com> dateTue 14 Apr 2015, 15:53 (12 years ago) parent2931d2e1a2a0d0
9 files changed+181−67
compare with master
unifiedsplit
.travis.yml+7 CHANGELOG.md+2−1 servant.cabal+3 src/Servant/API.hs+29−22 src/Servant/API/ContentTypes.hs+21−21 src/Servant/API/Header.hs+2−2 src/Servant/API/ResponseHeaders.hs+72 test/Servant/API/ContentTypesSpec.hs+21−21 test/Servant/API/ResponseHeadersSpec.hs+24
.travis.yml+7
@@ -3,6 +3,13 @@ language: haskell
33ghc:
44 - 7.8
55
6+before_install:
7+ - cabal update
8+ - cabal sandbox init
9+
10+install:
11+ - cabal install --only-dependencies --enable-tests
12+
613script:
714 - cabal configure --enable-tests --enable-library-coverage && cabal build && cabal test
815 - cabal check
CHANGELOG.md+2−1
@@ -7,4 +7,5 @@
77* Support for the PATCH HTTP method
88* Removed the home-made QuasiQuote for writing API types in a more human-friendly format until we come up with a better design for it
99* Make most if not all of the haddock code examples run through doctest
10−* Some general code cleanup
10+* Some general code cleanup
11+* Add response headers
servant.cabal+3
@@ -39,6 +39,7 @@ library
3939 Servant.API.MatrixParam
4040 Servant.API.Raw
4141 Servant.API.ReqBody
42+ Servant.API.ResponseHeaders
4243 Servant.API.Sub
4344 Servant.Common.Text
4445 Servant.Utils.Links
@@ -47,6 +48,8 @@ library
4748 , aeson >= 0.7
4849 , attoparsec >= 0.12
4950 , bytestring == 0.10.*
51+ , bytestring-conversion == 0.3.*
52+ , case-insensitive >= 1.2
5053 , http-media >= 0.4 && < 0.7
5154 , http-types == 0.8.*
5255 , text >= 1 && < 2
src/Servant/API.hs+29−22
@@ -38,6 +38,9 @@ module Servant.API (
3838 -- | Serializing and deserializing types based on @Accept@ and
3939 -- @Content-Type@ headers.
4040
41+ -- * Response Headers
42+ module Servant.API.ResponseHeaders,
43+
4144 -- * Untyped endpoints
4245 module Servant.API.Raw,
4346 -- | Plugging in a wai 'Network.Wai.Application', serving directories
@@ -55,28 +58,32 @@ module Servant.API (
5558 -- | Type-safe internal URIs
5659 ) where
5760
58−import Data.Proxy (Proxy(..))
59−import Servant.Common.Text (FromText(..), ToText(..))
60−import Servant.API.Alternative ((:<|>) (..))
61−import Servant.API.Capture (Capture)
62−import Servant.API.ContentTypes (JSON, MimeRender (..),
63− MimeUnrender (..), OctetStream,
64− PlainText, FormUrlEncoded,
65− FromFormUrlEncoded(..), ToFormUrlEncoded(..))
66−import Servant.API.Delete (Delete)
67−import Servant.API.Get (Get)
68−import Servant.API.Header (Header)
69−import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
70− MatrixParams)
71−import Servant.API.Patch (Patch)
72−import Servant.API.Post (Post)
73−import Servant.API.Put (Put)
74−import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)
75−import Servant.API.Raw (Raw)
76−import Servant.API.ReqBody (ReqBody)
77−import Servant.API.Sub ((:>))
78−import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
79− URI (..), safeLink)
61+import Data.Proxy (Proxy (..))
62+import Servant.API.Alternative ((:<|>) (..))
63+import Servant.API.Capture (Capture)
64+import Servant.API.ContentTypes (FormUrlEncoded,
65+ FromFormUrlEncoded (..), JSON,
66+ MimeRender (..),
67+ MimeUnrender (..), OctetStream,
68+ PlainText, ToFormUrlEncoded (..))
69+import Servant.API.Delete (Delete)
70+import Servant.API.Get (Get)
71+import Servant.API.Header (Header(..))
72+import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
73+ MatrixParams)
74+import Servant.API.Patch (Patch)
75+import Servant.API.Post (Post)
76+import Servant.API.Put (Put)
77+import Servant.API.QueryParam (QueryFlag, QueryParam,
78+ QueryParams)
79+import Servant.API.Raw (Raw)
80+import Servant.API.ReqBody (ReqBody)
81+import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
82+ , AddHeader(addHeader) )
83+import Servant.API.Sub ((:>))
84+import Servant.Common.Text (FromText (..), ToText (..))
85+import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
86+ URI (..), safeLink)
8087
8188-- | Turn an API type into its canonical form.
8289--
src/Servant/API/ContentTypes.hs+21−21
@@ -142,12 +142,12 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
142142-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
143143-- >
144144-- > instance Show a => MimeRender MyContentType where
145−-- > toByteString _ val = pack ("This is MINE! " ++ show val)
145+-- > mimeRender _ val = pack ("This is MINE! " ++ show val)
146146-- >
147147-- > type MyAPI = "path" :> Get '[MyContentType] Int
148148--
149149class Accept ctype => MimeRender ctype a where
150− toByteString :: Proxy ctype -> a -> ByteString
150+ mimeRender :: Proxy ctype -> a -> ByteString
151151
152152class AllCTRender (list :: [*]) a where
153153 -- If the Accept header can be matched, returns (Just) a tuple of the
@@ -180,7 +180,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
180180--
181181-- >>> :{
182182--instance Read a => MimeUnrender MyContentType a where
183−-- fromByteString _ bs = case BSC.take 12 bs of
183+-- mimeUnrender _ bs = case BSC.take 12 bs of
184184-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs
185185-- _ -> Left "didn't start with the magic incantation"
186186-- :}
@@ -188,7 +188,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
188188-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int
189189--
190190class Accept ctype => MimeUnrender ctype a where
191− fromByteString :: Proxy ctype -> ByteString -> Either String a
191+ mimeUnrender :: Proxy ctype -> ByteString -> Either String a
192192
193193class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
194194 handleCTypeH :: Proxy list
@@ -214,13 +214,13 @@ class AllMimeRender (list :: [*]) a where
214214 -> [(M.MediaType, ByteString)] -- content-types/response pairs
215215
216216instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
217− allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
217+ allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
218218 where pctyp = Proxy :: Proxy ctyp
219219
220220instance ( MimeRender ctyp a
221221 , AllMimeRender (ctyp' ': ctyps) a
222222 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
223− allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
223+ allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
224224 :(allMimeRender pctyps a)
225225 where pctyp = Proxy :: Proxy ctyp
226226 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
@@ -243,7 +243,7 @@ instance AllMimeUnrender '[] a where
243243instance ( MimeUnrender ctyp a
244244 , AllMimeUnrender ctyps a
245245 ) => AllMimeUnrender (ctyp ': ctyps) a where
246− allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
246+ allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
247247 :(allMimeUnrender pctyps val)
248248 where pctyp = Proxy :: Proxy ctyp
249249 pctyps = Proxy :: Proxy ctyps
@@ -257,29 +257,29 @@ type family IsNonEmpty (list :: [*]) :: Constraint where
257257
258258-- | `encode`
259259instance ToJSON a => MimeRender JSON a where
260− toByteString _ = encode
260+ mimeRender _ = encode
261261
262262-- | @encodeFormUrlEncoded . toFormUrlEncoded@
263−-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
263+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
264264-- holds if every element of x is non-null (i.e., not @("", "")@)
265265instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
266− toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
266+ mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
267267
268268-- | `TextL.encodeUtf8`
269269instance MimeRender PlainText TextL.Text where
270− toByteString _ = TextL.encodeUtf8
270+ mimeRender _ = TextL.encodeUtf8
271271
272272-- | @fromStrict . TextS.encodeUtf8@
273273instance MimeRender PlainText TextS.Text where
274− toByteString _ = fromStrict . TextS.encodeUtf8
274+ mimeRender _ = fromStrict . TextS.encodeUtf8
275275
276276-- | @id@
277277instance MimeRender OctetStream ByteString where
278− toByteString _ = id
278+ mimeRender _ = id
279279
280280-- | `fromStrict`
281281instance MimeRender OctetStream BS.ByteString where
282− toByteString _ = fromStrict
282+ mimeRender _ = fromStrict
283283
284284
285285--------------------------------------------------------------------------
@@ -294,29 +294,29 @@ eitherDecodeLenient input = do
294294
295295-- | `eitherDecode`
296296instance FromJSON a => MimeUnrender JSON a where
297− fromByteString _ = eitherDecodeLenient
297+ mimeUnrender _ = eitherDecodeLenient
298298
299299-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@
300−-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
300+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
301301-- holds if every element of x is non-null (i.e., not @("", "")@)
302302instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
303− fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
303+ mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
304304
305305-- | @left show . TextL.decodeUtf8'@
306306instance MimeUnrender PlainText TextL.Text where
307− fromByteString _ = left show . TextL.decodeUtf8'
307+ mimeUnrender _ = left show . TextL.decodeUtf8'
308308
309309-- | @left show . TextS.decodeUtf8' . toStrict@
310310instance MimeUnrender PlainText TextS.Text where
311− fromByteString _ = left show . TextS.decodeUtf8' . toStrict
311+ mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
312312
313313-- | @Right . id@
314314instance MimeUnrender OctetStream ByteString where
315− fromByteString _ = Right . id
315+ mimeUnrender _ = Right . id
316316
317317-- | @Right . toStrict@
318318instance MimeUnrender OctetStream BS.ByteString where
319− fromByteString _ = Right . toStrict
319+ mimeUnrender _ = Right . toStrict
320320
321321
322322--------------------------------------------------------------------------
src/Servant/API/Header.hs+2−2
@@ -1,7 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE PolyKinds #-}
4−module Servant.API.Header (Header) where
4+module Servant.API.Header where
55
66import Data.Typeable (Typeable)
77import GHC.TypeLits (Symbol)
@@ -13,7 +13,7 @@ import GHC.TypeLits (Symbol)
1313-- >>>
1414-- >>> -- GET /view-my-referer
1515-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
16−data Header (sym :: Symbol) a
16+data Header (sym :: Symbol) a = Header a
1717 deriving Typeable
1818
1919-- $setup
src/Servant/API/ResponseHeaders.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE KindSignatures #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverlappingInstances #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+-- | This module provides facilities for adding headers to a response.
16+--
17+-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
18+--
19+-- The value is added to the header specified by the type (@Location@ in the
20+-- example above).
21+module Servant.API.ResponseHeaders
22+ ( Headers
23+ , getResponse
24+ , getHeaders
25+ , AddHeader(addHeader)
26+ ) where
27+
28+import Data.ByteString.Char8 (pack)
29+import Data.ByteString.Conversion (ToByteString, toByteString')
30+import qualified Data.CaseInsensitive as CI
31+import Data.Proxy
32+import GHC.TypeLits (KnownSymbol, symbolVal)
33+import qualified Network.HTTP.Types.Header as HTTP
34+
35+import Servant.API.Header (Header (..))
36+
37+-- | Response Header objects. You should never need to construct one directly.
38+-- Instead, use 'addHeader'.
39+data Headers ls a = Headers { getResponse :: a
40+ -- ^ The underlying value of a 'Headers'
41+ , getHeaders :: [HTTP.Header]
42+ -- ^ The list of header values of a 'Headers'.
43+ -- These are guaranteed to correspond with the
44+ -- first type of @Headers@ if constructed with
45+ -- 'addHeader'.
46+ } deriving (Eq, Show, Functor)
47+
48+-- We need all these fundeps to save type inference
49+class AddHeader h v orig new
50+ | h v orig -> new, new -> h, new -> v, new -> orig where
51+ addHeader :: v -> orig -> new
52+
53+instance ( KnownSymbol h, ToByteString v
54+ ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
55+ addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
56+ where
57+ headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
58+
59+instance ( KnownSymbol h, ToByteString v
60+ , new ~ (Headers '[Header h v] a)
61+ ) => AddHeader h v a new where
62+ addHeader a resp = Headers resp [(headerName, toByteString' a)]
63+ where
64+ headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
65+
66+
67+-- $setup
68+-- >>> import Servant.API
69+-- >>> import Data.Aeson
70+-- >>> import Data.Text
71+-- >>> data Book
72+-- >>> instance ToJSON Book where { toJSON = undefined }
test/Servant/API/ContentTypesSpec.hs+21−21
@@ -34,55 +34,55 @@ spec = describe "Servant.API.ContentTypes" $ do
3434
3535 describe "The JSON Content-Type type" $ do
3636
37− it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do
37+ it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do
3838 let p = Proxy :: Proxy JSON
39− property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int])
39+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int])
4040
41− it "has fromByteString reverse toByteString for valid top-level json " $ do
41+ it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
4242 let p = Proxy :: Proxy JSON
43− property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData)
43+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
4444
4545 describe "The FormUrlEncoded Content-Type type" $ do
4646
4747 let isNonNull ("", "") = False
4848 isNonNull _ = True
4949
50− it "has fromByteString reverse toByteString" $ do
50+ it "has mimeUnrender reverse mimeRender" $ do
5151 let p = Proxy :: Proxy FormUrlEncoded
5252 property $ \x -> all isNonNull x
53− ==> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
53+ ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])
5454
55− it "has fromByteString reverse exportParams (Network.URL)" $ do
55+ it "has mimeUnrender reverse exportParams (Network.URL)" $ do
5656 let p = Proxy :: Proxy FormUrlEncoded
5757 property $ \x -> all isNonNull x
58− ==> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
58+ ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
5959
60− it "has importParams (Network.URL) reverse toByteString" $ do
60+ it "has importParams (Network.URL) reverse mimeRender" $ do
6161 let p = Proxy :: Proxy FormUrlEncoded
6262 property $ \x -> all isNonNull x
63− ==> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
63+ ==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])
6464
6565 describe "The PlainText Content-Type type" $ do
6666
67− it "has fromByteString reverse toByteString (lazy Text)" $ do
67+ it "has mimeUnrender reverse mimeRender (lazy Text)" $ do
6868 let p = Proxy :: Proxy PlainText
69− property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text)
69+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text)
7070
71− it "has fromByteString reverse toByteString (strict Text)" $ do
71+ it "has mimeUnrender reverse mimeRender (strict Text)" $ do
7272 let p = Proxy :: Proxy PlainText
73− property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text)
73+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text)
7474
7575 describe "The OctetStream Content-Type type" $ do
7676
7777 it "is id (Lazy ByteString)" $ do
7878 let p = Proxy :: Proxy OctetStream
79− property $ \x -> toByteString p x == (x :: BSL.ByteString)
80− && fromByteString p x == Right x
79+ property $ \x -> mimeRender p x == (x :: BSL.ByteString)
80+ && mimeUnrender p x == Right x
8181
8282 it "is fromStrict/toStrict (Strict ByteString)" $ do
8383 let p = Proxy :: Proxy OctetStream
84− property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString)
85− && fromByteString p (BSL.fromStrict x) == Right x
84+ property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)
85+ && mimeUnrender p (BSL.fromStrict x) == Right x
8686
8787 describe "handleAcceptH" $ do
8888
@@ -182,13 +182,13 @@ instance Arbitrary ZeroToOne where
182182 arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
183183
184184instance MimeRender OctetStream Int where
185− toByteString _ = cs . show
185+ mimeRender _ = cs . show
186186
187187instance MimeRender PlainText Int where
188− toByteString _ = cs . show
188+ mimeRender _ = cs . show
189189
190190instance MimeRender PlainText ByteString where
191− toByteString _ = cs
191+ mimeRender _ = cs
192192
193193instance ToJSON ByteString where
194194 toJSON x = object [ "val" .= x ]
test/Servant/API/ResponseHeadersSpec.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Servant.API.ResponseHeadersSpec where
4+
5+import Test.Hspec
6+
7+import Servant.API.Header
8+import Servant.API.ResponseHeaders
9+
10+spec :: Spec
11+spec = describe "Servant.API.ResponseHeaders" $ do
12+ describe "addHeader" $ do
13+
14+ it "adds a header to a value" $ do
15+ let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int
16+ getHeaders val `shouldBe` [("test", "hi")]
17+
18+ it "maintains the value" $ do
19+ let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int
20+ getResponse val `shouldBe` 5
21+
22+ it "adds headers to the front of the list" $ do
23+ let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int
24+ getHeaders val `shouldBe` [("first", "10"), ("second", "b")]