Skip to content

Commit

Permalink
Add noHeader function.
Browse files Browse the repository at this point in the history
    Which allows not adding a header where a signature declares one, making
    response headers optional.
  • Loading branch information
jkarni committed Oct 21, 2016
1 parent 3ddf225 commit ed82056
Show file tree
Hide file tree
Showing 3 changed files with 44 additions and 5 deletions.
2 changes: 1 addition & 1 deletion servant/src/Servant/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..),
Expand Down
41 changes: 37 additions & 4 deletions servant/src/Servant/API/ResponseHeaders.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,9 @@
-- example above).
module Servant.API.ResponseHeaders
( Headers(..)
, AddHeader(addHeader)
, AddHeader
, addHeader
, noHeader
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
, HeaderValMap
Expand Down Expand Up @@ -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 [<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
-- >>> import Servant.API
Expand Down
6 changes: 6 additions & 0 deletions servant/test/Servant/API/ResponseHeadersSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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` []

0 comments on commit ed82056

Please sign in to comment.