diff --git a/changelog.d/1649 b/changelog.d/1649 new file mode 100644 index 00000000..d02cb88c --- /dev/null +++ b/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) + +} diff --git a/servant/src/Servant/API/UVerb.hs b/servant/src/Servant/API/UVerb.hs index ed59eded..340e1ad7 100644 --- a/servant/src/Servant/API/UVerb.hs +++ b/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] diff --git a/servant/test/Servant/API/ResponseHeadersSpec.hs b/servant/test/Servant/API/ResponseHeadersSpec.hs index 4f2f4181..94d66078 100644 --- a/servant/test/Servant/API/ResponseHeadersSpec.hs +++ b/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 +