From e9797732b1d41ae59bc8eb817e31d8c0c1bebd90 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Wed, 18 Mar 2015 15:23:09 +1100 Subject: [PATCH] Add Response Headers --- servant.cabal | 1 + src/Servant/API/ContentTypes.hs | 36 +++++++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/servant.cabal b/servant.cabal index 7b144eff..3657f524 100644 --- a/servant.cabal +++ b/servant.cabal @@ -47,6 +47,7 @@ library , aeson >= 0.7 , attoparsec >= 0.12 , bytestring == 0.10.* + , case-insensitive , http-media >= 0.4 && < 0.7 , http-types == 0.8.* , text >= 1 && < 2 diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index 734ec17c..6808761f 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -46,6 +46,7 @@ module Servant.API.ContentTypes , PlainText , FormUrlEncoded , OctetStream + , ResponseHeaders -- * Building your own Content-Type , Accept(..) @@ -75,6 +76,7 @@ import Data.Attoparsec.ByteString (endOfInput, parseOnly) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) import qualified Data.ByteString.Lazy as B +import qualified Data.CaseInsensitive as CI import Data.Monoid import Data.String.Conversions (cs) import qualified Data.Text as TextS @@ -83,8 +85,9 @@ import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable import GHC.Exts (Constraint) +import GHC.TypeLits import qualified Network.HTTP.Media as M -import Network.HTTP.Types.Header +import qualified Network.HTTP.Types.Header as H import Network.URI (escapeURIString, isUnreserved, unEscapeString) @@ -94,6 +97,8 @@ data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable +data ResponseHeaders (hs :: [Symbol]) (ct :: *) + -- * Accept class -- | Instances of 'Accept' represent mimetypes. They are used for matching @@ -128,6 +133,9 @@ instance Accept PlainText where instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" +instance Accept ct => Accept (ResponseHeaders hs ct) where + contentType _ = contentType (Proxy :: Proxy ct) + newtype AcceptHeader = AcceptHeader BS.ByteString deriving (Eq, Show) @@ -149,13 +157,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString -- > type MyAPI = "path" :> Get '[MyContentType] Int -- class Accept ctype => MimeRender ctype a where - toByteString :: Proxy ctype -> a -> (ResponseHeaders, ByteString) + toByteString :: Proxy ctype -> a -> ([H.Header], ByteString) class AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). - handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, (ResponseHeaders, ByteString)) + handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ([H.Header], ByteString)) instance ( AllMimeRender ctyps a, IsNonEmpty ctyps ) => AllCTRender ctyps a where @@ -190,11 +198,11 @@ 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 -> ResponseHeaders -> ByteString -> Either String a + fromByteString :: Proxy ctype -> [H.Header] -> ByteString -> Either String a class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list - -> ResponseHeaders -- Headers + -> [H.Header] -- Headers -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) @@ -214,7 +222,7 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps class AllMimeRender (list :: [*]) a where allMimeRender :: Proxy list -> a -- value to serialize - -> [(M.MediaType, (ResponseHeaders, ByteString))] -- content-types/response pairs + -> [(M.MediaType, ([H.Header], ByteString))] -- content-types/response pairs instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)] @@ -237,7 +245,7 @@ instance AllMimeRender '[] a where -------------------------------------------------------------------------- class AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list - -> ResponseHeaders + -> [H.Header] -> ByteString -> [(M.MediaType, Either String a)] @@ -285,7 +293,6 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where toByteString _ = ([],) . fromStrict - -------------------------------------------------------------------------- -- * MimeUnrender Instances @@ -322,6 +329,19 @@ instance MimeUnrender OctetStream ByteString where instance MimeUnrender OctetStream BS.ByteString where fromByteString _ _ = Right . toStrict +class KnownSymbols a where + symbolVals :: Proxy a -> [String] + +instance (KnownSymbols hs, MimeUnrender ct a) + => MimeUnrender (ResponseHeaders hs ct) ([H.Header], a) where + fromByteString _ hs body = do + let required = map (CI.mk . cs) . symbolVals $ (Proxy :: Proxy hs) :: [H.HeaderName] + res <- fromByteString (Proxy :: Proxy ct) hs body + hs' <- forM required $ \r -> case lookup r hs of + Nothing -> Left $ "Required header not present: " <> show r + Just x -> return (r,x) + return (hs', res) + -------------------------------------------------------------------------- -- * FormUrlEncoded