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

Merge pull request #397 from jsermeno/master

Browse source 
Allow duplicate headers
This commit is contained in:
Julian Arni 2016-04-21 09:07:53 +02:00
commit 438912f6c5
1 changed files with 5 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -68,8 +68,7 @@ class BuildHeadersTo hs where
instance OVERLAPPING_ BuildHeadersTo '[] where instance OVERLAPPING_ BuildHeadersTo '[] where
buildHeadersTo _ = HNil buildHeadersTo _ = HNil
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )
, Contains h xs ~ 'False)
=> BuildHeadersTo ((Header h v) ': xs) where => BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers = buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
@ -89,7 +88,7 @@ class GetHeaders ls where
instance OVERLAPPING_ GetHeaders (HList '[]) where instance OVERLAPPING_ GetHeaders (HList '[]) where
getHeaders _ = [] getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) )
=> GetHeaders (HList (Header h x ': xs)) where => GetHeaders (HList (Header h x ': xs)) where
getHeaders hdrs = case hdrs of getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
@ -100,7 +99,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
instance OVERLAPPING_ GetHeaders (Headers '[] a) where instance OVERLAPPING_ GetHeaders (Headers '[] a) where
getHeaders _ = [] getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v )
=> GetHeaders (Headers (Header h v ': rest) a) where => GetHeaders (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs getHeaders hs = getHeaders $ getHeadersHList hs
@ -112,20 +111,15 @@ class AddHeader h v orig new
addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) instance OVERLAPPING_ ( KnownSymbol h, ToByteString 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 a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString 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 a resp = Headers resp (HCons (Header a) HNil)
type family Contains x xs where
Contains x ((Header x a) ': xs) = 'True
Contains x ((Header y a) ': xs) = Contains x xs
Contains x '[] = 'False
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API
-- >>> import Data.Aeson -- >>> import Data.Aeson