summaryrefslogtreecommitdiff
path: root/src/Servant/API/ResponseHeaders.hs
blob: 6ca42b6f47ebc43e436c55a804994da41cc974ef (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveDataTypeable     #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# 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 { getResponse :: a
                            -- ^ The underlying value of a 'Headers'
                            , getHeadersHList :: HList ls
                            -- ^ HList of headers.
                            } deriving (Functor)

instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where
    rnf (Headers x hdrs) = rnf x `seq` rnf hdrs

data ResponseHeader (sym :: Symbol) a
    = Header a
    | MissingHeader
    | UndecodableHeader ByteString
  deriving (Typeable, Eq, Show, Functor)

instance NFData a => NFData (ResponseHeader sym a) where
    rnf MissingHeader          = ()
    rnf (UndecodableHeader bs) = rnf bs
    rnf (Header x)             = rnf 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 HNil = ()
instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where
    rnfHList (HCons h xs) = rnf h `seq` rnfHList xs

instance NFDataHList xs => NFData (HList xs) where
    rnf = 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 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>)

instance {-# OVERLAPPING #-} BuildHeadersTo '[] where
    buildHeadersTo _ = HNil

instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
         => BuildHeadersTo (Header h v ': xs) where
    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
        xs -> case parseHeader (BS.init $ BS.unlines xs) of
          Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)
             `HCons` buildHeadersTo headers
          Right h   -> Header h `HCons` buildHeadersTo headers

-- * Getting

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 = getHeadersFromHList

instance GetHeadersFromHList '[] where
    getHeadersFromHList _ = []

instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
    => GetHeadersFromHList (Header h x ': xs)
  where
    getHeadersFromHList hdrs = case hdrs of
        Header val `HCons` rest          -> (headerName , toHeader val) : getHeadersFromHList rest
        UndecodableHeader h `HCons` rest -> (headerName,  h) : getHeadersFromHList rest
        MissingHeader `HCons` rest       -> getHeadersFromHList rest
      where
        headerName = CI.mk . pack $ symbolVal (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 = getHeaders'

-- | This instance is an optimisation
instance GetHeaders' '[] where
    getHeaders' _ = []

instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
    => GetHeaders' (Header h v ': rest)
  where
    getHeaders' hs = getHeadersFromHList $ getHeadersHList hs

-- * Adding

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


instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
         => AddHeader h v (Headers (fst ': rest)  a) (Headers (Header h v  ': fst ': rest) a) where
    addOptionalHeader 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
    addOptionalHeader 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 = addOptionalHeader . 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 = addOptionalHeader MissingHeader

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

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

instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where
  hlistLookupHeader (HCons _ hs) = hlistLookupHeader 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 = hlistLookupHeader . getHeadersHList

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