1a2a0d0 · servant · git.iko.soy

git.iko.soy/servant

Add response headers.

commit1a2a0d027a34a42fd1d19c0a5233c541c5db1417 authorJulian K. Arni <jkarni@gmail.com> dateMon 13 Apr 2015, 15:12 (12 years ago) parent2931d2e

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

6+before_install:

7+ - cabal update

8+ - cabal sandbox init

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

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

5+import Test.Hspec

7+import Servant.API.Header

8+import Servant.API.ResponseHeaders

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")]