68a129d · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #28 from haskell-servant/jkarni/response-headers

68a129dJulian Arni12 years ago

.travis.yml+7

compare with master

unifiedsplit

@@ -3,6 +3,13 @@ language: haskell

3ghc:

4 - 7.8

6+before_install:

7+ - cabal update

8+ - cabal sandbox init

10+install:

11+ - cabal install --only-dependencies --enable-tests

12+

6script:

13script:

7 - cabal configure --enable-tests --enable-library-coverage && cabal build && cabal test

14 - cabal configure --enable-tests --enable-library-coverage && cabal build && cabal test

8 - cabal check

15 - cabal check

CHANGELOG.md+2−1

@@ -7,4 +7,5 @@

7* Support for the PATCH HTTP method

8* 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

9* 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

39 Servant.API.MatrixParam

40 Servant.API.Raw

41 Servant.API.ReqBody

42+ Servant.API.ResponseHeaders

42 Servant.API.Sub

43 Servant.API.Sub

43 Servant.Common.Text

44 Servant.Common.Text

44 Servant.Utils.Links

45 Servant.Utils.Links

@@ -47,6 +48,8 @@ library

47 , aeson >= 0.7

48 , aeson >= 0.7

48 , attoparsec >= 0.12

49 , attoparsec >= 0.12

49 , bytestring == 0.10.*

50 , bytestring == 0.10.*

51+ , bytestring-conversion == 0.3.*

52+ , case-insensitive >= 1.2

50 , http-media >= 0.4 && < 0.7

53 , http-media >= 0.4 && < 0.7

51 , http-types == 0.8.*

54 , http-types == 0.8.*

52 , text >= 1 && < 2

55 , text >= 1 && < 2

src/Servant/API.hs+29−22

@@ -38,6 +38,9 @@ module Servant.API (

38 -- | Serializing and deserializing types based on @Accept@ and

39 -- @Content-Type@ headers.

41+ -- * Response Headers

42+ module Servant.API.ResponseHeaders,

43+

41 -- * Untyped endpoints

44 -- * Untyped endpoints

42 module Servant.API.Raw,

45 module Servant.API.Raw,

43 -- | Plugging in a wai 'Network.Wai.Application', serving directories

46 -- | Plugging in a wai 'Network.Wai.Application', serving directories

@@ -55,28 +58,32 @@ module Servant.API (

55 -- | Type-safe internal URIs

58 -- | Type-safe internal URIs

56 ) where

59 ) where

58−import Data.Proxy (Proxy(..))

61+import Data.Proxy (Proxy (..))

59−import Servant.Common.Text (FromText(..), ToText(..))

60−import Servant.API.Alternative ((:<|>) (..))

62+import Servant.API.Alternative ((:<|>) (..))

61−import Servant.API.Capture (Capture)

63+import Servant.API.Capture (Capture)

62−import Servant.API.ContentTypes (JSON, MimeRender (..),

64+import Servant.API.ContentTypes (FormUrlEncoded,

65+ FromFormUrlEncoded (..), JSON,

66+ MimeRender (..),

63− MimeUnrender (..), OctetStream,

67+ MimeUnrender (..), OctetStream,

64− PlainText, FormUrlEncoded,

65− FromFormUrlEncoded(..), ToFormUrlEncoded(..))

68+ PlainText, ToFormUrlEncoded (..))

66−import Servant.API.Delete (Delete)

69+import Servant.API.Delete (Delete)

67−import Servant.API.Get (Get)

70+import Servant.API.Get (Get)

68−import Servant.API.Header (Header)

71+import Servant.API.Header (Header(..))

69−import Servant.API.MatrixParam (MatrixFlag, MatrixParam,

72+import Servant.API.MatrixParam (MatrixFlag, MatrixParam,

70− MatrixParams)

73+ MatrixParams)

71−import Servant.API.Patch (Patch)

74+import Servant.API.Patch (Patch)

72−import Servant.API.Post (Post)

75+import Servant.API.Post (Post)

73−import Servant.API.Put (Put)

76+import Servant.API.Put (Put)

74−import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)

77+import Servant.API.QueryParam (QueryFlag, QueryParam,

78+ QueryParams)

75−import Servant.API.Raw (Raw)

79+import Servant.API.Raw (Raw)

76−import Servant.API.ReqBody (ReqBody)

80+import Servant.API.ReqBody (ReqBody)

77−import Servant.API.Sub ((:>))

81+import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse

82+ , AddHeader(addHeader) )

83+import Servant.API.Sub ((:>))

84+import Servant.Common.Text (FromText (..), ToText (..))

78−import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

85+import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

79− URI (..), safeLink)

86+ URI (..), safeLink)

81-- | Turn an API type into its canonical form.

88-- | Turn an API type into its canonical form.

82--

89--

src/Servant/API/ContentTypes.hs+21−21

@@ -142,12 +142,12 @@ newtype AcceptHeader = AcceptHeader BS.ByteString

142-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")

143-- >

144-- > instance Show a => MimeRender MyContentType where

145−-- > toByteString _ val = pack ("This is MINE! " ++ show val)

145+-- > mimeRender _ val = pack ("This is MINE! " ++ show val)

146-- >

147-- > type MyAPI = "path" :> Get '[MyContentType] Int

148--

149class Accept ctype => MimeRender ctype a where

150− toByteString :: Proxy ctype -> a -> ByteString

150+ mimeRender :: Proxy ctype -> a -> ByteString

151

152class AllCTRender (list :: [*]) a where

153 -- If the Accept header can be matched, returns (Just) a tuple of the

@@ -180,7 +180,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

180--

181-- >>> :{

182--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

184-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs

185-- _ -> Left "didn't start with the magic incantation"

186-- :}

@@ -188,7 +188,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

188-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int

189--

190class Accept ctype => MimeUnrender ctype a where

191− fromByteString :: Proxy ctype -> ByteString -> Either String a

191+ mimeUnrender :: Proxy ctype -> ByteString -> Either String a

192

193class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where

194 handleCTypeH :: Proxy list

@@ -214,13 +214,13 @@ class AllMimeRender (list :: [*]) a where

214 -> [(M.MediaType, ByteString)] -- content-types/response pairs

215

216instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where

217− allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]

217+ allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]

218 where pctyp = Proxy :: Proxy ctyp

219

220instance ( MimeRender ctyp a

221 , AllMimeRender (ctyp' ': ctyps) a

222 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where

223− allMimeRender _ a = (contentType pctyp, toByteString pctyp a)

223+ allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)

224 :(allMimeRender pctyps a)

225 where pctyp = Proxy :: Proxy ctyp

226 pctyps = Proxy :: Proxy (ctyp' ': ctyps)

@@ -243,7 +243,7 @@ instance AllMimeUnrender '[] a where

243instance ( MimeUnrender ctyp a

244 , AllMimeUnrender ctyps a

245 ) => AllMimeUnrender (ctyp ': ctyps) a where

246− allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)

246+ allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)

247 :(allMimeUnrender pctyps val)

248 where pctyp = Proxy :: Proxy ctyp

249 pctyps = Proxy :: Proxy ctyps

@@ -257,29 +257,29 @@ type family IsNonEmpty (list :: [*]) :: Constraint where

257

258-- | `encode`

259instance ToJSON a => MimeRender JSON a where

260− toByteString _ = encode

260+ mimeRender _ = encode

261

262-- | @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

264-- holds if every element of x is non-null (i.e., not @("", "")@)

265instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where

266− toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded

266+ mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded

267

268-- | `TextL.encodeUtf8`

269instance MimeRender PlainText TextL.Text where

270− toByteString _ = TextL.encodeUtf8

270+ mimeRender _ = TextL.encodeUtf8

271

272-- | @fromStrict . TextS.encodeUtf8@

273instance MimeRender PlainText TextS.Text where

274− toByteString _ = fromStrict . TextS.encodeUtf8

274+ mimeRender _ = fromStrict . TextS.encodeUtf8

275

276-- | @id@

277instance MimeRender OctetStream ByteString where

278− toByteString _ = id

278+ mimeRender _ = id

279

280-- | `fromStrict`

281instance MimeRender OctetStream BS.ByteString where

282− toByteString _ = fromStrict

282+ mimeRender _ = fromStrict

283

284

285--------------------------------------------------------------------------

@@ -294,29 +294,29 @@ eitherDecodeLenient input = do

294

295-- | `eitherDecode`

296instance FromJSON a => MimeUnrender JSON a where

297− fromByteString _ = eitherDecodeLenient

297+ mimeUnrender _ = eitherDecodeLenient

298

299-- | @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

301-- holds if every element of x is non-null (i.e., not @("", "")@)

302instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where

303− fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded

303+ mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded

304

305-- | @left show . TextL.decodeUtf8'@

306instance MimeUnrender PlainText TextL.Text where

307− fromByteString _ = left show . TextL.decodeUtf8'

307+ mimeUnrender _ = left show . TextL.decodeUtf8'

308

309-- | @left show . TextS.decodeUtf8' . toStrict@

310instance MimeUnrender PlainText TextS.Text where

311− fromByteString _ = left show . TextS.decodeUtf8' . toStrict

311+ mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict

312

313-- | @Right . id@

314instance MimeUnrender OctetStream ByteString where

315− fromByteString _ = Right . id

315+ mimeUnrender _ = Right . id

316

317-- | @Right . toStrict@

318instance MimeUnrender OctetStream BS.ByteString where

319− fromByteString _ = Right . toStrict

319+ mimeUnrender _ = Right . toStrict

320

321

322--------------------------------------------------------------------------

src/Servant/API/Header.hs+2−2

@@ -1,7 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

4−module Servant.API.Header (Header) where

4+module Servant.API.Header where

6import Data.Typeable (Typeable)

7import GHC.TypeLits (Symbol)

@@ -13,7 +13,7 @@ import GHC.TypeLits (Symbol)

13-- >>>

14-- >>> -- GET /view-my-referer

15-- >>> 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

17 deriving Typeable

19-- $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

35 describe "The JSON Content-Type type" $ do

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

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

41− it "has fromByteString reverse toByteString for valid top-level json " $ do

41+ it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

42 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)

45 describe "The FormUrlEncoded Content-Type type" $ do

47 let isNonNull ("", "") = False

48 isNonNull _ = True

50− it "has fromByteString reverse toByteString" $ do

50+ it "has mimeUnrender reverse mimeRender" $ do

51 let p = Proxy :: Proxy FormUrlEncoded

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

55− it "has fromByteString reverse exportParams (Network.URL)" $ do

55+ it "has mimeUnrender reverse exportParams (Network.URL)" $ do

56 let p = Proxy :: Proxy FormUrlEncoded

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

60− it "has importParams (Network.URL) reverse toByteString" $ do

60+ it "has importParams (Network.URL) reverse mimeRender" $ do

61 let p = Proxy :: Proxy FormUrlEncoded

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

65 describe "The PlainText Content-Type type" $ do

67− it "has fromByteString reverse toByteString (lazy Text)" $ do

67+ it "has mimeUnrender reverse mimeRender (lazy Text)" $ do

68 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)

71− it "has fromByteString reverse toByteString (strict Text)" $ do

71+ it "has mimeUnrender reverse mimeRender (strict Text)" $ do

72 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)

75 describe "The OctetStream Content-Type type" $ do

77 it "is id (Lazy ByteString)" $ do

78 let p = Proxy :: Proxy OctetStream

79− property $ \x -> toByteString p x == (x :: BSL.ByteString)

79+ property $ \x -> mimeRender p x == (x :: BSL.ByteString)

80− && fromByteString p x == Right x

80+ && mimeUnrender p x == Right x

82 it "is fromStrict/toStrict (Strict ByteString)" $ do

83 let p = Proxy :: Proxy OctetStream

84− property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString)

84+ property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)

85− && fromByteString p (BSL.fromStrict x) == Right x

85+ && mimeUnrender p (BSL.fromStrict x) == Right x

87 describe "handleAcceptH" $ do

@@ -182,13 +182,13 @@ instance Arbitrary ZeroToOne where

182 arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]

183

184instance MimeRender OctetStream Int where

185− toByteString _ = cs . show

185+ mimeRender _ = cs . show

186

187instance MimeRender PlainText Int where

188− toByteString _ = cs . show

188+ mimeRender _ = cs . show

189

190instance MimeRender PlainText ByteString where

191− toByteString _ = cs

191+ mimeRender _ = cs

192

193instance ToJSON ByteString where

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