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

Add response headers.

.travis.yml

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

CHANGELOG.md

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

servant.cabal

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

src/Servant/API.hs

@@ -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,28 +58,32 @@ module Servant.API (
   -- | Type-safe internal URIs
   ) where
 
-import           Data.Proxy               (Proxy(..))
+import           Data.Proxy                  (Proxy (..))
-import           Servant.Common.Text      (FromText(..), ToText(..))
+import           Servant.API.Alternative     ((:<|>) (..))
-import           Servant.API.Alternative  ((:<|>) (..))
+import           Servant.API.Capture         (Capture)
-import           Servant.API.Capture      (Capture)
+import           Servant.API.ContentTypes    (FormUrlEncoded,
-import           Servant.API.ContentTypes (JSON, MimeRender (..),
+                                              FromFormUrlEncoded (..), JSON,
-                                           MimeUnrender (..), OctetStream,
+                                              MimeRender (..),
-                                           PlainText, FormUrlEncoded,
+                                              MimeUnrender (..), OctetStream,
-                                           FromFormUrlEncoded(..), ToFormUrlEncoded(..))
+                                              PlainText, ToFormUrlEncoded (..))
-import           Servant.API.Delete       (Delete)
+import           Servant.API.Delete          (Delete)
-import           Servant.API.Get          (Get)
+import           Servant.API.Get             (Get)
-import           Servant.API.Header       (Header)
+import           Servant.API.Header          (Header(..))
-import           Servant.API.MatrixParam  (MatrixFlag, MatrixParam,
+import           Servant.API.MatrixParam     (MatrixFlag, MatrixParam,
-                                           MatrixParams)
+                                              MatrixParams)
-import           Servant.API.Patch        (Patch)
+import           Servant.API.Patch           (Patch)
-import           Servant.API.Post         (Post)
+import           Servant.API.Post            (Post)
-import           Servant.API.Put          (Put)
+import           Servant.API.Put             (Put)
-import           Servant.API.QueryParam   (QueryFlag, QueryParam, QueryParams)
+import           Servant.API.QueryParam      (QueryFlag, QueryParam,
-import           Servant.API.Raw          (Raw)
+                                              QueryParams)
-import           Servant.API.ReqBody      (ReqBody)
+import           Servant.API.Raw             (Raw)
-import           Servant.API.Sub          ((:>))
+import           Servant.API.ReqBody         (ReqBody)
-import           Servant.Utils.Links      (HasLink (..), IsElem, IsElem',
+import           Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
-                                           URI (..), safeLink)
+                                             , AddHeader(addHeader) )
+import           Servant.API.Sub             ((:>))
+import           Servant.Common.Text         (FromText (..), ToText (..))
+import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',
+                                              URI (..), safeLink)
 
 -- | Turn an API type into its canonical form.
 --

src/Servant/API/ContentTypes.hs

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

src/Servant/API/Header.hs

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

src/Servant/API/ResponseHeaders.hs

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

test/Servant/API/ContentTypesSpec.hs

@@ -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)
+            property $ \x -> mimeRender p x == (x :: BSL.ByteString)
-                && fromByteString p x == Right x
+                && 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)
+            property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)
-                && fromByteString p (BSL.fromStrict x) == Right x
+                && 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 ]

test/Servant/API/ResponseHeadersSpec.hs

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