2015-04-20 19:52:29 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2015-04-13 15:12:33 +02:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE KindSignatures #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2015-05-02 03:21:03 +02:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2015-04-13 15:12:33 +02:00
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
2015-05-02 03:21:03 +02:00
|
|
|
{-# OPTIONS_HADDOCK not-home #-}
|
2015-04-13 15:12:33 +02:00
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
#include "overlapping-compat.h"
|
2015-04-13 15:12:33 +02:00
|
|
|
-- | This module provides facilities for adding headers to a response.
|
|
|
|
--
|
|
|
|
-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
|
|
|
|
--
|
|
|
|
-- The value is added to the header specified by the type (@Location@ in the
|
|
|
|
-- example above).
|
|
|
|
module Servant.API.ResponseHeaders
|
2015-05-02 03:21:03 +02:00
|
|
|
( Headers(..)
|
2016-10-21 14:36:14 +02:00
|
|
|
, AddHeader
|
|
|
|
, addHeader
|
|
|
|
, noHeader
|
2015-05-02 03:21:03 +02:00
|
|
|
, BuildHeadersTo(buildHeadersTo)
|
|
|
|
, GetHeaders(getHeaders)
|
|
|
|
, HeaderValMap
|
|
|
|
, HList(..)
|
2015-04-13 15:12:33 +02:00
|
|
|
) where
|
|
|
|
|
2015-05-02 03:21:03 +02:00
|
|
|
import Data.ByteString.Char8 as BS (pack, unlines, init)
|
2016-09-02 15:59:36 +02:00
|
|
|
import Web.HttpApiData (ToHttpApiData, toHeader,
|
|
|
|
FromHttpApiData, parseHeader)
|
2015-04-13 15:12:33 +02:00
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Proxy
|
|
|
|
import GHC.TypeLits (KnownSymbol, symbolVal)
|
|
|
|
import qualified Network.HTTP.Types.Header as HTTP
|
|
|
|
|
|
|
|
import Servant.API.Header (Header (..))
|
2016-03-01 19:25:04 +01:00
|
|
|
import Prelude ()
|
2016-03-01 12:21:21 +01:00
|
|
|
import Prelude.Compat
|
2015-04-13 15:12:33 +02:00
|
|
|
|
|
|
|
-- | Response Header objects. You should never need to construct one directly.
|
2017-03-19 21:49:52 +01:00
|
|
|
-- Instead, use 'addOptionalHeader'.
|
2015-04-13 15:12:33 +02:00
|
|
|
data Headers ls a = Headers { getResponse :: a
|
|
|
|
-- ^ The underlying value of a 'Headers'
|
2015-05-02 03:21:03 +02:00
|
|
|
, getHeadersHList :: HList ls
|
|
|
|
-- ^ HList of headers.
|
|
|
|
} deriving (Functor)
|
|
|
|
|
|
|
|
data HList a where
|
|
|
|
HNil :: HList '[]
|
|
|
|
HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
|
|
|
|
|
|
|
|
type family HeaderValMap (f :: * -> *) (xs :: [*]) where
|
|
|
|
HeaderValMap f '[] = '[]
|
|
|
|
HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs)
|
|
|
|
|
|
|
|
|
|
|
|
class BuildHeadersTo hs where
|
|
|
|
buildHeadersTo :: [HTTP.Header] -> HList hs
|
|
|
|
-- ^ Note: if there are multiple occurences of a header in the argument,
|
|
|
|
-- the values are interspersed with commas before deserialization (see
|
|
|
|
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
|
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
instance OVERLAPPING_ BuildHeadersTo '[] where
|
2015-05-02 03:21:03 +02:00
|
|
|
buildHeadersTo _ = HNil
|
|
|
|
|
2016-09-02 15:14:45 +02:00
|
|
|
instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
|
2015-12-27 17:54:29 +01:00
|
|
|
=> BuildHeadersTo ((Header h v) ': xs) where
|
2015-05-02 03:21:03 +02:00
|
|
|
buildHeadersTo headers =
|
|
|
|
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
|
|
|
|
matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
|
|
|
|
in case matching of
|
|
|
|
[] -> MissingHeader `HCons` buildHeadersTo headers
|
2016-09-02 15:14:45 +02:00
|
|
|
xs -> case parseHeader (BS.init $ BS.unlines xs) of
|
|
|
|
Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)
|
2015-05-02 03:21:03 +02:00
|
|
|
`HCons` buildHeadersTo headers
|
2016-09-02 15:14:45 +02:00
|
|
|
Right h -> Header h `HCons` buildHeadersTo headers
|
2015-05-02 03:21:03 +02:00
|
|
|
|
|
|
|
-- * Getting
|
|
|
|
|
|
|
|
class GetHeaders ls where
|
|
|
|
getHeaders :: ls -> [HTTP.Header]
|
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
instance OVERLAPPING_ GetHeaders (HList '[]) where
|
2015-05-02 03:21:03 +02:00
|
|
|
getHeaders _ = []
|
|
|
|
|
2016-09-02 11:46:49 +02:00
|
|
|
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )
|
2015-12-27 17:54:29 +01:00
|
|
|
=> GetHeaders (HList (Header h x ': xs)) where
|
2015-05-02 12:39:02 +02:00
|
|
|
getHeaders hdrs = case hdrs of
|
2016-09-02 11:46:49 +02:00
|
|
|
Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest
|
|
|
|
UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest
|
2015-05-02 12:39:02 +02:00
|
|
|
MissingHeader `HCons` rest -> getHeaders rest
|
2015-05-02 03:21:03 +02:00
|
|
|
where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
|
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
|
2015-05-02 03:21:03 +02:00
|
|
|
getHeaders _ = []
|
|
|
|
|
2016-09-02 11:46:49 +02:00
|
|
|
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )
|
2015-12-27 17:54:29 +01:00
|
|
|
=> GetHeaders (Headers (Header h v ': rest) a) where
|
2015-05-02 03:21:03 +02:00
|
|
|
getHeaders hs = getHeaders $ getHeadersHList hs
|
|
|
|
|
|
|
|
-- * Adding
|
2015-04-13 15:12:33 +02:00
|
|
|
|
|
|
|
-- 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
|
2016-10-24 17:15:29 +02:00
|
|
|
addOptionalHeader :: Header h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
|
2015-05-02 03:21:03 +02:00
|
|
|
|
2015-04-13 15:12:33 +02:00
|
|
|
|
2016-09-02 11:46:49 +02:00
|
|
|
instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )
|
2015-12-27 17:54:29 +01:00
|
|
|
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
|
2016-10-24 17:15:29 +02:00
|
|
|
addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
|
2015-04-13 15:12:33 +02:00
|
|
|
|
2016-09-02 11:46:49 +02:00
|
|
|
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v
|
2016-03-21 22:46:04 +01:00
|
|
|
, new ~ (Headers '[Header h v] a) )
|
2015-12-27 17:54:29 +01:00
|
|
|
=> AddHeader h v a new where
|
2016-10-24 17:15:29 +02:00
|
|
|
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
|
2016-10-21 14:36:14 +02:00
|
|
|
|
|
|
|
-- | @addHeader@ adds a header to a response. Note that it changes the type of
|
|
|
|
-- the value in the following ways:
|
|
|
|
--
|
2017-03-19 21:49:52 +01:00
|
|
|
-- 1. A simple value is wrapped in "Headers '[hdr]":
|
2016-10-21 14:36:14 +02:00
|
|
|
--
|
|
|
|
-- >>> 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
|
2016-10-24 17:15:29 +02:00
|
|
|
addHeader = addOptionalHeader . Header
|
2016-10-21 14:36:14 +02:00
|
|
|
|
|
|
|
-- | 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
|
2016-10-24 17:15:29 +02:00
|
|
|
noHeader = addOptionalHeader MissingHeader
|
2015-04-13 15:12:33 +02:00
|
|
|
|
|
|
|
-- $setup
|
|
|
|
-- >>> import Servant.API
|
|
|
|
-- >>> import Data.Aeson
|
|
|
|
-- >>> import Data.Text
|
|
|
|
-- >>> data Book
|
|
|
|
-- >>> instance ToJSON Book where { toJSON = undefined }
|