{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveDataTypeable     #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# OPTIONS_HADDOCK not-home        #-}

-- | 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
    ( Headers(..)
    , ResponseHeader (..)
    , AddHeader
    , addHeader
    , noHeader
    , HasResponseHeader
    , lookupResponseHeader
    , BuildHeadersTo(buildHeadersTo)
    , GetHeaders(getHeaders)
    , GetHeaders'
    , HeaderValMap
    , HList(..)
    ) where

import           Control.DeepSeq
                 (NFData (..))
import           Data.ByteString.Char8     as BS
                 (ByteString, init, pack, unlines)
import qualified Data.CaseInsensitive      as CI
import           Data.Proxy
import           Data.Typeable
                 (Typeable)
import           GHC.TypeLits
                 (KnownSymbol, Symbol, symbolVal)
import qualified Network.HTTP.Types.Header as HTTP
import           Web.HttpApiData
                 (FromHttpApiData, ToHttpApiData, parseHeader, toHeader)

import           Prelude ()
import           Prelude.Compat
import           Servant.API.Header
                 (Header)

-- | Response Header objects. You should never need to construct one directly.
-- Instead, use 'addOptionalHeader'.
data Headers ls a = Headers { Headers ls a -> a
getResponse :: a
                            -- ^ The underlying value of a 'Headers'
                            , Headers ls a -> HList ls
getHeadersHList :: HList ls
                            -- ^ HList of headers.
                            } deriving (a -> Headers ls b -> Headers ls a
(a -> b) -> Headers ls a -> Headers ls b
(forall a b. (a -> b) -> Headers ls a -> Headers ls b)
-> (forall a b. a -> Headers ls b -> Headers ls a)
-> Functor (Headers ls)
forall (ls :: [*]) a b. a -> Headers ls b -> Headers ls a
forall (ls :: [*]) a b. (a -> b) -> Headers ls a -> Headers ls b
forall a b. a -> Headers ls b -> Headers ls a
forall a b. (a -> b) -> Headers ls a -> Headers ls b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Headers ls b -> Headers ls a
$c<$ :: forall (ls :: [*]) a b. a -> Headers ls b -> Headers ls a
fmap :: (a -> b) -> Headers ls a -> Headers ls b
$cfmap :: forall (ls :: [*]) a b. (a -> b) -> Headers ls a -> Headers ls b
Functor)

instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where
    rnf :: Headers ls a -> ()
rnf (Headers a
x HList ls
hdrs) = a -> ()
forall a. NFData a => a -> ()
rnf a
x () -> () -> ()
`seq` HList ls -> ()
forall a. NFData a => a -> ()
rnf HList ls
hdrs

data ResponseHeader (sym :: Symbol) a
    = Header a
    | MissingHeader
    | UndecodableHeader ByteString
  deriving (Typeable, ResponseHeader sym a -> ResponseHeader sym a -> Bool
(ResponseHeader sym a -> ResponseHeader sym a -> Bool)
-> (ResponseHeader sym a -> ResponseHeader sym a -> Bool)
-> Eq (ResponseHeader sym a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (sym :: Symbol) a.
Eq a =>
ResponseHeader sym a -> ResponseHeader sym a -> Bool
/= :: ResponseHeader sym a -> ResponseHeader sym a -> Bool
$c/= :: forall (sym :: Symbol) a.
Eq a =>
ResponseHeader sym a -> ResponseHeader sym a -> Bool
== :: ResponseHeader sym a -> ResponseHeader sym a -> Bool
$c== :: forall (sym :: Symbol) a.
Eq a =>
ResponseHeader sym a -> ResponseHeader sym a -> Bool
Eq, Int -> ResponseHeader sym a -> ShowS
[ResponseHeader sym a] -> ShowS
ResponseHeader sym a -> String
(Int -> ResponseHeader sym a -> ShowS)
-> (ResponseHeader sym a -> String)
-> ([ResponseHeader sym a] -> ShowS)
-> Show (ResponseHeader sym a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (sym :: Symbol) a.
Show a =>
Int -> ResponseHeader sym a -> ShowS
forall (sym :: Symbol) a. Show a => [ResponseHeader sym a] -> ShowS
forall (sym :: Symbol) a. Show a => ResponseHeader sym a -> String
showList :: [ResponseHeader sym a] -> ShowS
$cshowList :: forall (sym :: Symbol) a. Show a => [ResponseHeader sym a] -> ShowS
show :: ResponseHeader sym a -> String
$cshow :: forall (sym :: Symbol) a. Show a => ResponseHeader sym a -> String
showsPrec :: Int -> ResponseHeader sym a -> ShowS
$cshowsPrec :: forall (sym :: Symbol) a.
Show a =>
Int -> ResponseHeader sym a -> ShowS
Show, a -> ResponseHeader sym b -> ResponseHeader sym a
(a -> b) -> ResponseHeader sym a -> ResponseHeader sym b
(forall a b.
 (a -> b) -> ResponseHeader sym a -> ResponseHeader sym b)
-> (forall a b. a -> ResponseHeader sym b -> ResponseHeader sym a)
-> Functor (ResponseHeader sym)
forall a b. a -> ResponseHeader sym b -> ResponseHeader sym a
forall a b.
(a -> b) -> ResponseHeader sym a -> ResponseHeader sym b
forall (sym :: Symbol) a b.
a -> ResponseHeader sym b -> ResponseHeader sym a
forall (sym :: Symbol) a b.
(a -> b) -> ResponseHeader sym a -> ResponseHeader sym b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ResponseHeader sym b -> ResponseHeader sym a
$c<$ :: forall (sym :: Symbol) a b.
a -> ResponseHeader sym b -> ResponseHeader sym a
fmap :: (a -> b) -> ResponseHeader sym a -> ResponseHeader sym b
$cfmap :: forall (sym :: Symbol) a b.
(a -> b) -> ResponseHeader sym a -> ResponseHeader sym b
Functor)

instance NFData a => NFData (ResponseHeader sym a) where
    rnf :: ResponseHeader sym a -> ()
rnf ResponseHeader sym a
MissingHeader          = ()
    rnf (UndecodableHeader ByteString
bs) = ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
bs
    rnf (Header a
x)             = a -> ()
forall a. NFData a => a -> ()
rnf a
x

data HList a where
    HNil  :: HList '[]
    HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)

class NFDataHList xs where rnfHList :: HList xs -> ()
instance NFDataHList '[] where rnfHList :: HList '[] -> ()
rnfHList HList '[]
HNil = ()
instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where
    rnfHList :: HList (y : xs) -> ()
rnfHList (HCons ResponseHeader h x
h HList xs
xs) = ResponseHeader h x -> ()
forall a. NFData a => a -> ()
rnf ResponseHeader h x
h () -> () -> ()
`seq` HList xs -> ()
forall (xs :: [*]). NFDataHList xs => HList xs -> ()
rnfHList HList xs
xs

instance NFDataHList xs => NFData (HList xs) where
    rnf :: HList xs -> ()
rnf = HList xs -> ()
forall (xs :: [*]). NFDataHList xs => HList xs -> ()
rnfHList

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 occurrences 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>)

instance {-# OVERLAPPING #-} BuildHeadersTo '[] where
    buildHeadersTo :: [Header] -> HList '[]
buildHeadersTo [Header]
_ = HList '[]
HNil

instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
         => BuildHeadersTo (Header h v ': xs) where
    buildHeadersTo :: [Header] -> HList (Header h v : xs)
buildHeadersTo [Header]
headers =
      let wantedHeader :: CI ByteString
wantedHeader = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (String -> ByteString) -> String -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack (String -> CI ByteString) -> String -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Proxy h -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy h
forall k (t :: k). Proxy t
Proxy :: Proxy h)
          matching :: [ByteString]
matching = Header -> ByteString
forall a b. (a, b) -> b
snd (Header -> ByteString) -> [Header] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(CI ByteString
h, ByteString
_) -> CI ByteString
h CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
wantedHeader) [Header]
headers
      in case [ByteString]
matching of
        [] -> ResponseHeader h v
forall (sym :: Symbol) a. ResponseHeader sym a
MissingHeader ResponseHeader h v -> HList xs -> HList (Header h v : xs)
forall (h :: Symbol) x (xs :: [*]).
ResponseHeader h x -> HList xs -> HList (Header h x : xs)
`HCons` [Header] -> HList xs
forall (hs :: [*]). BuildHeadersTo hs => [Header] -> HList hs
buildHeadersTo [Header]
headers
        [ByteString]
xs -> case ByteString -> Either Text v
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> ByteString
BS.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.unlines [ByteString]
xs) of
          Left Text
_err -> ByteString -> ResponseHeader h v
forall (sym :: Symbol) a. ByteString -> ResponseHeader sym a
UndecodableHeader (ByteString -> ByteString
BS.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.unlines [ByteString]
xs)
             ResponseHeader h v -> HList xs -> HList (Header h v : xs)
forall (h :: Symbol) x (xs :: [*]).
ResponseHeader h x -> HList xs -> HList (Header h x : xs)
`HCons` [Header] -> HList xs
forall (hs :: [*]). BuildHeadersTo hs => [Header] -> HList hs
buildHeadersTo [Header]
headers
          Right v
h   -> v -> ResponseHeader h v
forall (sym :: Symbol) a. a -> ResponseHeader sym a
Header v
h ResponseHeader h v -> HList xs -> HList (Header h v : xs)
forall (h :: Symbol) x (xs :: [*]).
ResponseHeader h x -> HList xs -> HList (Header h x : xs)
`HCons` [Header] -> HList xs
forall (hs :: [*]). BuildHeadersTo hs => [Header] -> HList hs
buildHeadersTo [Header]
headers

-- * Getting headers

class GetHeaders ls where
    getHeaders :: ls -> [HTTP.Header]

-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance
class GetHeadersFromHList hs where
    getHeadersFromHList :: HList hs  -> [HTTP.Header]

instance GetHeadersFromHList hs => GetHeaders (HList hs) where
    getHeaders :: HList hs -> [Header]
getHeaders = HList hs -> [Header]
forall (hs :: [*]). GetHeadersFromHList hs => HList hs -> [Header]
getHeadersFromHList

instance GetHeadersFromHList '[] where
    getHeadersFromHList :: HList '[] -> [Header]
getHeadersFromHList HList '[]
_ = []

instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
    => GetHeadersFromHList (Header h x ': xs)
  where
    getHeadersFromHList :: HList (Header h x : xs) -> [Header]
getHeadersFromHList HList (Header h x : xs)
hdrs = case HList (Header h x : xs)
hdrs of
        Header x
val `HCons` HList xs
rest          -> (CI ByteString
headerName , x -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader x
val) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: HList xs -> [Header]
forall (hs :: [*]). GetHeadersFromHList hs => HList hs -> [Header]
getHeadersFromHList HList xs
rest
        UndecodableHeader ByteString
h `HCons` HList xs
rest -> (CI ByteString
headerName,  ByteString
h) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: HList xs -> [Header]
forall (hs :: [*]). GetHeadersFromHList hs => HList hs -> [Header]
getHeadersFromHList HList xs
rest
        ResponseHeader h x
MissingHeader `HCons` HList xs
rest       -> HList xs -> [Header]
forall (hs :: [*]). GetHeadersFromHList hs => HList hs -> [Header]
getHeadersFromHList HList xs
rest
      where
        headerName :: CI ByteString
headerName = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (String -> ByteString) -> String -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack (String -> CI ByteString) -> String -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Proxy h -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy h
forall k (t :: k). Proxy t
Proxy :: Proxy h)

-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance
class GetHeaders' hs where
    getHeaders' :: Headers hs a -> [HTTP.Header]

instance GetHeaders' hs => GetHeaders (Headers hs a) where
    getHeaders :: Headers hs a -> [Header]
getHeaders = Headers hs a -> [Header]
forall (hs :: [*]) a. GetHeaders' hs => Headers hs a -> [Header]
getHeaders'

-- | This instance is an optimisation
instance GetHeaders' '[] where
    getHeaders' :: Headers '[] a -> [Header]
getHeaders' Headers '[] a
_ = []

instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
    => GetHeaders' (Header h v ': rest)
  where
    getHeaders' :: Headers (Header h v : rest) a -> [Header]
getHeaders' Headers (Header h v : rest) a
hs = HList (Header h v : rest) -> [Header]
forall (hs :: [*]). GetHeadersFromHList hs => HList hs -> [Header]
getHeadersFromHList (HList (Header h v : rest) -> [Header])
-> HList (Header h v : rest) -> [Header]
forall a b. (a -> b) -> a -> b
$ Headers (Header h v : rest) a -> HList (Header h v : rest)
forall (ls :: [*]) a. Headers ls a -> HList ls
getHeadersHList Headers (Header h v : rest) a
hs

-- * Adding headers

-- 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
  addOptionalHeader :: ResponseHeader h v -> orig -> new  -- ^ N.B.: The same header can't be added multiple times

-- In this instance, we add a Header on top of something that is already decorated with some headers
instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
         => AddHeader h v (Headers (fst ': rest)  a) (Headers (Header h v  ': fst ': rest) a) where
    addOptionalHeader :: ResponseHeader h v
-> Headers (fst : rest) a -> Headers (Header h v : fst : rest) a
addOptionalHeader ResponseHeader h v
hdr (Headers a
resp HList (fst : rest)
heads) = a
-> HList (Header h v : fst : rest)
-> Headers (Header h v : fst : rest) a
forall (ls :: [*]) a. a -> HList ls -> Headers ls a
Headers a
resp (ResponseHeader h v
-> HList (fst : rest) -> HList (Header h v : fst : rest)
forall (h :: Symbol) x (xs :: [*]).
ResponseHeader h x -> HList xs -> HList (Header h x : xs)
HCons ResponseHeader h v
hdr HList (fst : rest)
heads)

-- In this instance, 'a' parameter is decorated with a Header.
instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
         => AddHeader h v a new where
    addOptionalHeader :: ResponseHeader h v -> a -> new
addOptionalHeader ResponseHeader h v
hdr a
resp = a -> HList '[Header h v] -> Headers '[Header h v] a
forall (ls :: [*]) a. a -> HList ls -> Headers ls a
Headers a
resp (ResponseHeader h v -> HList '[] -> HList '[Header h v]
forall (h :: Symbol) x (xs :: [*]).
ResponseHeader h x -> HList xs -> HList (Header h x : xs)
HCons ResponseHeader h v
hdr HList '[]
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 :: v -> orig -> new
addHeader = ResponseHeader h v -> orig -> new
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
ResponseHeader h v -> orig -> new
addOptionalHeader (ResponseHeader h v -> orig -> new)
-> (v -> ResponseHeader h v) -> v -> orig -> new
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ResponseHeader h v
forall (sym :: Symbol) a. a -> ResponseHeader sym a
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 :: orig -> new
noHeader = ResponseHeader h v -> orig -> new
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
ResponseHeader h v -> orig -> new
addOptionalHeader ResponseHeader h v
forall (sym :: Symbol) a. ResponseHeader sym a
MissingHeader

class HasResponseHeader h a headers where
  hlistLookupHeader :: HList headers -> ResponseHeader h a

instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where
  hlistLookupHeader :: HList (Header h a : rest) -> ResponseHeader h a
hlistLookupHeader (HCons ResponseHeader h x
ha HList xs
_) = ResponseHeader h a
ResponseHeader h x
ha

instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where
  hlistLookupHeader :: HList (first : rest) -> ResponseHeader h a
hlistLookupHeader (HCons ResponseHeader h x
_ HList xs
hs) = HList xs -> ResponseHeader h a
forall (h :: Symbol) a (headers :: [*]).
HasResponseHeader h a headers =>
HList headers -> ResponseHeader h a
hlistLookupHeader HList xs
hs

-- | Look up a specific ResponseHeader,
-- without having to know what position it is in the HList.
--
-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String
-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String
-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int
-- Header 5
--
-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool
-- Header True
--
-- Usage of this function relies on an explicit type annotation of the header to be looked up.
-- This can be done with type annotations on the result, or with an explicit type application.
-- In this example, the type of header value is determined by the type-inference,
-- we only specify the name of the header:
--
-- >>> :set -XTypeApplications
-- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False }
-- True
--
-- @since 0.15
--
lookupResponseHeader :: (HasResponseHeader h a headers)
  => Headers headers r -> ResponseHeader h a
lookupResponseHeader :: Headers headers r -> ResponseHeader h a
lookupResponseHeader = HList headers -> ResponseHeader h a
forall (h :: Symbol) a (headers :: [*]).
HasResponseHeader h a headers =>
HList headers -> ResponseHeader h a
hlistLookupHeader (HList headers -> ResponseHeader h a)
-> (Headers headers r -> HList headers)
-> Headers headers r
-> ResponseHeader h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers headers r -> HList headers
forall (ls :: [*]) a. Headers ls a -> HList ls
getHeadersHList

-- $setup
-- >>> :set -XFlexibleContexts
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }