Add HasStatus instance for Headers (that defers StatusOf to underlying value) (#1649)

* Add HasStatus instance for Headers (that defers StatusOf to underlying value)

* changelog.d/1649

Author: intolerable

changelog.d/1649

@@ -0,0 +1,8 @@
+synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
+prs: #1649
+
+description: {
+
+Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
+
+}

servant/src/Servant/API/UVerb.hs

@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)
 import Network.HTTP.Types (Status, StdMethod)
 import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
 import Servant.API.Status (KnownStatus, statusVal)
+import Servant.API.ResponseHeaders (Headers)
 import Servant.API.UVerb.Union
 
 class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@@ -52,6 +53,9 @@ statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
 instance HasStatus NoContent where
   type StatusOf NoContent = 204
 
+instance HasStatus a => HasStatus (Headers hs a) where
+  type StatusOf (Headers hs a) = StatusOf a
+
 class HasStatuses (as :: [*]) where
   type Statuses (as :: [*]) :: [Nat]
   statuses :: Proxy as -> [Status]

servant/test/Servant/API/ResponseHeadersSpec.hs

@@ -2,10 +2,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Servant.API.ResponseHeadersSpec where
 
+import           Data.Proxy
+import           GHC.TypeLits
 import           Test.Hspec
 
+import           Servant.API.ContentTypes
 import           Servant.API.Header
 import           Servant.API.ResponseHeaders
+import           Servant.API.UVerb
 
 spec :: Spec
 spec = describe "Servant.API.ResponseHeaders" $ do
@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
     it "does not add a header" $ do
       let val = noHeader 5 :: Headers '[Header "test" Int] Int
       getHeaders val `shouldBe` []
+
+  describe "HasStatus Headers" $ do
+
+    it "gets the status from the underlying value" $ do
+      natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204
+      natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503
+