eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
Add response headers.
This commit is contained in:
Julian Arni 2015-04-14 15:53:32 +02:00
commit 68a129dcd3
9 changed files with 181 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
.travis.yml
View file

@ -3,6 +3,13 @@ language: haskell
ghc:
- 7.8
before_install:
- cabal update
- cabal sandbox init
install:
- cabal install --only-dependencies --enable-tests
script:
- cabal configure --enable-tests --enable-library-coverage && cabal build && cabal test
- cabal check

1
CHANGELOG.md
View file

@ -8,3 +8,4 @@
* 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
* Make most if not all of the haddock code examples run through doctest
* Some general code cleanup
* Add response headers

3
servant.cabal
View file

@ -39,6 +39,7 @@ library
Servant.API.MatrixParam
Servant.API.Raw
Servant.API.ReqBody
Servant.API.ResponseHeaders
Servant.API.Sub
Servant.Common.Text
Servant.Utils.Links
@ -47,6 +48,8 @@ library
, aeson >= 0.7
, attoparsec >= 0.12
, bytestring == 0.10.*
, bytestring-conversion == 0.3.*
, case-insensitive >= 1.2
, http-media >= 0.4 && < 0.7
, http-types == 0.8.*
, text >= 1 && < 2

21
src/Servant/API.hs
View file

@ -38,6 +38,9 @@ module Servant.API (
-- | Serializing and deserializing types based on @Accept@ and
-- @Content-Type@ headers.
-- * Response Headers
module Servant.API.ResponseHeaders,
-- * Untyped endpoints
module Servant.API.Raw,
-- | Plugging in a wai 'Network.Wai.Application', serving directories
@ -55,26 +58,30 @@ module Servant.API (
-- | Type-safe internal URIs
) where
import Data.Proxy (Proxy(..))
import Servant.Common.Text (FromText(..), ToText(..))
import Data.Proxy (Proxy (..))
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (JSON, MimeRender (..),
import Servant.API.ContentTypes (FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
MimeRender (..),
MimeUnrender (..), OctetStream,
PlainText, FormUrlEncoded,
FromFormUrlEncoded(..), ToFormUrlEncoded(..))
PlainText, ToFormUrlEncoded (..))
import Servant.API.Delete (Delete)
import Servant.API.Get (Get)
import Servant.API.Header (Header)
import Servant.API.Header (Header(..))
import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
MatrixParams)
import Servant.API.Patch (Patch)
import Servant.API.Post (Post)
import Servant.API.Put (Put)
import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)
import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
, AddHeader(addHeader) )
import Servant.API.Sub ((:>))
import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)

42
src/Servant/API/ContentTypes.hs
View file

@ -142,12 +142,12 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
-- >
-- > instance Show a => MimeRender MyContentType where
-- > toByteString _ val = pack ("This is MINE! " ++ show val)
-- > mimeRender _ val = pack ("This is MINE! " ++ show val)
-- >
-- > type MyAPI = "path" :> Get '[MyContentType] Int
--
class Accept ctype => MimeRender ctype a where
toByteString :: Proxy ctype -> a -> ByteString
mimeRender :: Proxy ctype -> a -> ByteString
class AllCTRender (list :: [*]) a where
-- If the Accept header can be matched, returns (Just) a tuple of the
@ -180,7 +180,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
--
-- >>> :{
--instance Read a => MimeUnrender MyContentType a where
-- fromByteString _ bs = case BSC.take 12 bs of
-- mimeUnrender _ bs = case BSC.take 12 bs of
-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs
-- _ -> Left "didn't start with the magic incantation"
-- :}
@ -188,7 +188,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int
--
class Accept ctype => MimeUnrender ctype a where
fromByteString :: Proxy ctype -> ByteString -> Either String a
mimeUnrender :: Proxy ctype -> ByteString -> Either String a
class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
handleCTypeH :: Proxy list
@ -214,13 +214,13 @@ class AllMimeRender (list :: [*]) a where
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
where pctyp = Proxy :: Proxy ctyp
instance ( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
:(allMimeRender pctyps a)
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
@ -243,7 +243,7 @@ instance AllMimeUnrender '[] a where
instance ( MimeUnrender ctyp a
, AllMimeUnrender ctyps a
) => AllMimeUnrender (ctyp ': ctyps) a where
allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
:(allMimeUnrender pctyps val)
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps
@ -257,29 +257,29 @@ type family IsNonEmpty (list :: [*]) :: Constraint where
-- | `encode`
instance ToJSON a => MimeRender JSON a where
toByteString _ = encode
mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@
-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
-- | `TextL.encodeUtf8`
instance MimeRender PlainText TextL.Text where
toByteString _ = TextL.encodeUtf8
mimeRender _ = TextL.encodeUtf8
-- | @fromStrict . TextS.encodeUtf8@
instance MimeRender PlainText TextS.Text where
toByteString _ = fromStrict . TextS.encodeUtf8
mimeRender _ = fromStrict . TextS.encodeUtf8
-- | @id@
instance MimeRender OctetStream ByteString where
toByteString _ = id
mimeRender _ = id
-- | `fromStrict`
instance MimeRender OctetStream BS.ByteString where
toByteString _ = fromStrict
mimeRender _ = fromStrict
--------------------------------------------------------------------------
@ -294,29 +294,29 @@ eitherDecodeLenient input = do
-- | `eitherDecode`
instance FromJSON a => MimeUnrender JSON a where
fromByteString _ = eitherDecodeLenient
mimeUnrender _ = eitherDecodeLenient
-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@
-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
-- | @left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TextL.Text where
fromByteString _ = left show . TextL.decodeUtf8'
mimeUnrender _ = left show . TextL.decodeUtf8'
-- | @left show . TextS.decodeUtf8' . toStrict@
instance MimeUnrender PlainText TextS.Text where
fromByteString _ = left show . TextS.decodeUtf8' . toStrict
mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
-- | @Right . id@
instance MimeUnrender OctetStream ByteString where
fromByteString _ = Right . id
mimeUnrender _ = Right . id
-- | @Right . toStrict@
instance MimeUnrender OctetStream BS.ByteString where
fromByteString _ = Right . toStrict
mimeUnrender _ = Right . toStrict
--------------------------------------------------------------------------

4
src/Servant/API/Header.hs
View file

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.Header (Header) where
module Servant.API.Header where
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
@ -13,7 +13,7 @@ import GHC.TypeLits (Symbol)
-- >>>
-- >>> -- GET /view-my-referer
-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
data Header (sym :: Symbol) a
data Header (sym :: Symbol) a = Header a
deriving Typeable
-- $setup

72
src/Servant/API/ResponseHeaders.hs Normal file
View file

@ -0,0 +1,72 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module provides facilities for adding headers to a response.
--
-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
--
-- The value is added to the header specified by the type (@Location@ in the
-- example above).
module Servant.API.ResponseHeaders
( Headers
, getResponse
, getHeaders
, AddHeader(addHeader)
) where
import Data.ByteString.Char8 (pack)
import Data.ByteString.Conversion (ToByteString, toByteString')
import qualified Data.CaseInsensitive as CI
import Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API.Header (Header (..))
-- | Response Header objects. You should never need to construct one directly.
-- Instead, use 'addHeader'.
data Headers ls a = Headers { getResponse :: a
-- ^ The underlying value of a 'Headers'
, getHeaders :: [HTTP.Header]
-- ^ The list of header values of a 'Headers'.
-- These are guaranteed to correspond with the
-- first type of @Headers@ if constructed with
-- 'addHeader'.
} deriving (Eq, Show, Functor)
-- We need all these fundeps to save type inference
class AddHeader h v orig new
| h v orig -> new, new -> h, new -> v, new -> orig where
addHeader :: v -> orig -> new
instance ( KnownSymbol h, ToByteString v
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
instance ( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where
addHeader a resp = Headers resp [(headerName, toByteString' a)]
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

42
test/Servant/API/ContentTypesSpec.hs
View file

@ -34,55 +34,55 @@ spec = describe "Servant.API.ContentTypes" $ do
describe "The JSON Content-Type type" $ do
it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do
it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do
let p = Proxy :: Proxy JSON
property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int])
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int])
it "has fromByteString reverse toByteString for valid top-level json " $ do
it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
let p = Proxy :: Proxy JSON
property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData)
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
describe "The FormUrlEncoded Content-Type type" $ do
let isNonNull ("", "") = False
isNonNull _ = True
it "has fromByteString reverse toByteString" $ do
it "has mimeUnrender reverse mimeRender" $ do
let p = Proxy :: Proxy FormUrlEncoded
property $ \x -> all isNonNull x
==> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])
it "has fromByteString reverse exportParams (Network.URL)" $ do
it "has mimeUnrender reverse exportParams (Network.URL)" $ do
let p = Proxy :: Proxy FormUrlEncoded
property $ \x -> all isNonNull x
==> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
it "has importParams (Network.URL) reverse toByteString" $ do
it "has importParams (Network.URL) reverse mimeRender" $ do
let p = Proxy :: Proxy FormUrlEncoded
property $ \x -> all isNonNull x
==> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])
describe "The PlainText Content-Type type" $ do
it "has fromByteString reverse toByteString (lazy Text)" $ do
it "has mimeUnrender reverse mimeRender (lazy Text)" $ do
let p = Proxy :: Proxy PlainText
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text)
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text)
it "has fromByteString reverse toByteString (strict Text)" $ do
it "has mimeUnrender reverse mimeRender (strict Text)" $ do
let p = Proxy :: Proxy PlainText
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text)
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text)
describe "The OctetStream Content-Type type" $ do
it "is id (Lazy ByteString)" $ do
let p = Proxy :: Proxy OctetStream
property $ \x -> toByteString p x == (x :: BSL.ByteString)
&& fromByteString p x == Right x
property $ \x -> mimeRender p x == (x :: BSL.ByteString)
&& mimeUnrender p x == Right x
it "is fromStrict/toStrict (Strict ByteString)" $ do
let p = Proxy :: Proxy OctetStream
property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString)
&& fromByteString p (BSL.fromStrict x) == Right x
property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)
&& mimeUnrender p (BSL.fromStrict x) == Right x
describe "handleAcceptH" $ do
@ -182,13 +182,13 @@ instance Arbitrary ZeroToOne where
arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
instance MimeRender OctetStream Int where
toByteString _ = cs . show
mimeRender _ = cs . show
instance MimeRender PlainText Int where
toByteString _ = cs . show
mimeRender _ = cs . show
instance MimeRender PlainText ByteString where
toByteString _ = cs
mimeRender _ = cs
instance ToJSON ByteString where
toJSON x = object [ "val" .= x ]

24
test/Servant/API/ResponseHeadersSpec.hs Normal file
View file

@ -0,0 +1,24 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.API.ResponseHeadersSpec where
import Test.Hspec
import Servant.API.Header
import Servant.API.ResponseHeaders
spec :: Spec
spec = describe "Servant.API.ResponseHeaders" $ do
describe "addHeader" $ do
it "adds a header to a value" $ do
let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int
getHeaders val `shouldBe` [("test", "hi")]
it "maintains the value" $ do
let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int
getResponse val `shouldBe` 5
it "adds headers to the front of the list" $ do
let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int
getHeaders val `shouldBe` [("first", "10"), ("second", "b")]