diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2eb0d8dc..0711c790 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -75,7 +75,7 @@ import Servant.API.QueryParam (QueryFlag, QueryParam, import Servant.API.Raw (Raw) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) -import Servant.API.ResponseHeaders (AddHeader (addHeader), +import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader, BuildHeadersTo (buildHeadersTo), GetHeaders (getHeaders), HList (..), Headers (..), diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index deacb90b..9d81b97a 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -23,7 +23,9 @@ -- example above). module Servant.API.ResponseHeaders ( Headers(..) - , AddHeader(addHeader) + , AddHeader + , addHeader + , noHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) , HeaderValMap @@ -108,17 +110,48 @@ instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v -- We need all these fundeps to save type inference class AddHeader h v orig new | h v orig -> new, new -> h, new -> v, new -> orig where - addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times + addHeader' :: Header h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where - addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) + addHeader' hdr (Headers resp heads) = Headers resp (HCons hdr heads) instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v , new ~ (Headers '[Header h v] a) ) => AddHeader h v a new where - addHeader a resp = Headers resp (HCons (Header a) HNil) + addHeader' hdr resp = Headers resp (HCons hdr HNil) + +-- | @addHeader@ adds a header to a response. Note that it changes the type of +-- the value in the following ways: +-- +-- 1. A simple value is wrapped in "Headers []": +-- +-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> getHeaders example1 +-- [("someheader","5")] +-- +-- 2. A value that already has a header has its new header *prepended* to the +-- existing list: +-- +-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String +-- >>> getHeaders example2 +-- [("1st","true"),("someheader","5")] +-- +-- Note that while in your handlers type annotations are not required, since +-- the type can be inferred from the API type, in other cases you may find +-- yourself needing to add annotations. +addHeader :: AddHeader h v orig new => v -> orig -> new +addHeader = addHeader' . Header + +-- | Deliberately do not add a header to a value. +-- +-- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String +-- >>> getHeaders example1 +-- [] +noHeader :: AddHeader h v orig new => orig -> new +noHeader = addHeader' MissingHeader -- $setup -- >>> import Servant.API diff --git a/servant/test/Servant/API/ResponseHeadersSpec.hs b/servant/test/Servant/API/ResponseHeadersSpec.hs index 688f87b8..02e54ddf 100644 --- a/servant/test/Servant/API/ResponseHeadersSpec.hs +++ b/servant/test/Servant/API/ResponseHeadersSpec.hs @@ -22,3 +22,9 @@ spec = describe "Servant.API.ResponseHeaders" $ do it "adds headers to the front of the list" $ do let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] + + describe "noHeader" $ do + + it "does not add a header" $ do + let val = noHeader 5 :: Headers '[Header "test" Int] Int + getHeaders val `shouldBe` []