diff --git a/.travis.yml b/.travis.yml index b3b77290..6712498d 100644 --- a/.travis.yml +++ b/.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 diff --git a/CHANGELOG.md b/CHANGELOG.md index a3194b03..146daee5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,4 +7,5 @@ * Support for the PATCH HTTP method * 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 \ No newline at end of file +* Some general code cleanup +* Add response headers diff --git a/servant.cabal b/servant.cabal index 7b144eff..9a11fd7b 100644 --- a/servant.cabal +++ b/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 diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 9a91d0f4..da511752 100644 --- a/src/Servant/API.hs +++ b/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 Servant.Common.Text (FromText(..), ToText(..)) -import Servant.API.Alternative ((:<|>) (..)) -import Servant.API.Capture (Capture) -import Servant.API.ContentTypes (JSON, MimeRender (..), - MimeUnrender (..), OctetStream, - PlainText, FormUrlEncoded, - FromFormUrlEncoded(..), ToFormUrlEncoded(..)) -import Servant.API.Delete (Delete) -import Servant.API.Get (Get) -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.Raw (Raw) -import Servant.API.ReqBody (ReqBody) -import Servant.API.Sub ((:>)) -import Servant.Utils.Links (HasLink (..), IsElem, IsElem', - URI (..), safeLink) +import Data.Proxy (Proxy (..)) +import Servant.API.Alternative ((:<|>) (..)) +import Servant.API.Capture (Capture) +import Servant.API.ContentTypes (FormUrlEncoded, + FromFormUrlEncoded (..), JSON, + MimeRender (..), + MimeUnrender (..), OctetStream, + PlainText, ToFormUrlEncoded (..)) +import Servant.API.Delete (Delete) +import Servant.API.Get (Get) +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.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) -- | Turn an API type into its canonical form. -- diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index 3ae20b71..da40228c 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/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 -------------------------------------------------------------------------- diff --git a/src/Servant/API/Header.hs b/src/Servant/API/Header.hs index 5c4826d7..2b3ff112 100644 --- a/src/Servant/API/Header.hs +++ b/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 diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs new file mode 100644 index 00000000..807a7f25 --- /dev/null +++ b/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 } diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index 2a4a071d..8bfd92a2 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/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) - && 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 ] diff --git a/test/Servant/API/ResponseHeadersSpec.hs b/test/Servant/API/ResponseHeadersSpec.hs new file mode 100644 index 00000000..688f87b8 --- /dev/null +++ b/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")]