Add noHeader function.

Which allows not adding a header where a signature declares one, making
    response headers optional.
This commit is contained in:
Julian K. Arni 2016-10-21 14:36:14 +02:00
parent 3ddf225cec
commit ed82056052
3 changed files with 44 additions and 5 deletions

View file

@ -75,7 +75,7 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.RemoteHost (RemoteHost) import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody) import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders (AddHeader (addHeader), import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,
BuildHeadersTo (buildHeadersTo), BuildHeadersTo (buildHeadersTo),
GetHeaders (getHeaders), GetHeaders (getHeaders),
HList (..), Headers (..), HList (..), Headers (..),

View file

@ -23,7 +23,9 @@
-- example above). -- example above).
module Servant.API.ResponseHeaders module Servant.API.ResponseHeaders
( Headers(..) ( Headers(..)
, AddHeader(addHeader) , AddHeader
, addHeader
, noHeader
, BuildHeadersTo(buildHeadersTo) , BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders) , GetHeaders(getHeaders)
, HeaderValMap , HeaderValMap
@ -108,17 +110,48 @@ instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v
-- We need all these fundeps to save type inference -- We need all these fundeps to save type inference
class AddHeader h v orig new class AddHeader h v orig new
| h v orig -> new, new -> h, new -> v, new -> orig where | 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 ) instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where => 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 instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v
, new ~ (Headers '[Header h v] a) ) , new ~ (Headers '[Header h v] a) )
=> AddHeader h v a new where => 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 [<hdr>]":
--
-- >>> 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 -- $setup
-- >>> import Servant.API -- >>> import Servant.API

View file

@ -22,3 +22,9 @@ spec = describe "Servant.API.ResponseHeaders" $ do
it "adds headers to the front of the list" $ 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 let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int
getHeaders val `shouldBe` [("first", "10"), ("second", "b")] 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` []