Add Response Headers

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

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