From e604b930dcefacb99c41c938a44976858489d4a3 Mon Sep 17 00:00:00 2001
From: Dan Burton <danburton.email@gmail.com>
Date: Sun, 28 Oct 2018 01:33:39 -0400
Subject: [PATCH] Add lookupResponseHeader

---
 servant/src/Servant/API.hs                 |  2 +-
 servant/src/Servant/API/ResponseHeaders.hs | 29 ++++++++++++++++++++++
 2 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs
index eabad7fd..bf179b1f 100644
--- a/servant/src/Servant/API.hs
+++ b/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
                  (BoundaryStrategy (..), ByteStringParser (..),
                  FramingRender (..), FramingUnrender (..),
diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs
index 49ebd6c6..adcd5694 100644
--- a/servant/src/Servant/API/ResponseHeaders.hs
+++ b/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