Merge pull request #1064 from DanBurton/lookup-response-header

Add lookupResponseHeader

servant/src/Servant/API.hs

@@ -112,7 +112,7 @@ import           Servant.API.ResponseHeaders
                  (AddHeader, BuildHeadersTo (buildHeadersTo),
                  GetHeaders (getHeaders), HList (..), Headers (..),
                  ResponseHeader (..), addHeader, getHeadersHList, getResponse,
-                 noHeader)
+                 noHeader, HasResponseHeader, lookupResponseHeader)
 import           Servant.API.Stream
                  (FramingRender (..), FramingUnrender (..),
                  FromSourceIO (..), NetstringFraming, NewlineFraming,

servant/src/Servant/API/ResponseHeaders.hs

@@ -26,6 +26,8 @@ module Servant.API.ResponseHeaders
     , AddHeader
     , addHeader
     , noHeader
+    , HasResponseHeader
+    , lookupResponseHeader
     , BuildHeadersTo(buildHeadersTo)
     , GetHeaders(getHeaders)
     , GetHeaders'
@@ -183,6 +185,33 @@ addHeader = addOptionalHeader . Header
 noHeader :: AddHeader h v orig new => orig -> new
 noHeader = addOptionalHeader MissingHeader
 
+class HasResponseHeader h a headers where
+  hlistLookupHeader :: HList headers -> ResponseHeader h a
+
+instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where
+  hlistLookupHeader (HCons ha _) = ha
+
+instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where
+  hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs
+
+-- | Look up a specific ResponseHeader,
+-- without having to know what position it is in the HList.
+--
+-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String
+-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String
+-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int
+-- Header 5
+-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool
+-- Header True
+--
+-- Usage of this function relies on an explicit type annotation of the header to be looked up.
+-- This can be done with type annotations on the result, or with an explicit type application.
+-- e.g.
+-- @lookupResponseHeader \@"someheader" example2@
+lookupResponseHeader :: (HasResponseHeader h a headers)
+  => Headers headers r -> ResponseHeader h a
+lookupResponseHeader = hlistLookupHeader . getHeadersHList
+
 -- $setup
 -- >>> import Servant.API
 -- >>> import Data.Aeson