eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

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

* changelog.d/1649
This commit is contained in:
Intolerable 2023-02-14 22:28:57 +00:00 committed by GitHub
parent b3214eac38
commit a2e003367d
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 23 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
changelog.d/1649 Normal file
View file

@ -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)
}

4
servant/src/Servant/API/UVerb.hs
View file

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

11
servant/test/Servant/API/ResponseHeadersSpec.hs
View file

@ -2,10 +2,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Servant.API.ResponseHeadersSpec where module Servant.API.ResponseHeadersSpec where
import Data.Proxy
import GHC.TypeLits
import Test.Hspec import Test.Hspec
import Servant.API.ContentTypes
import Servant.API.Header import Servant.API.Header
import Servant.API.ResponseHeaders import Servant.API.ResponseHeaders
import Servant.API.UVerb
spec :: Spec spec :: Spec
spec = describe "Servant.API.ResponseHeaders" $ do spec = describe "Servant.API.ResponseHeaders" $ do
@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
it "does not add a header" $ do it "does not add a header" $ do
let val = noHeader 5 :: Headers '[Header "test" Int] Int let val = noHeader 5 :: Headers '[Header "test" Int] Int
getHeaders val `shouldBe` [] 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