5531ada · typeable/servant

scripts/shell.nix+1−3

@@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {

1313 ../servant-jquery {}) "--ghc-options=-Werror";

1414 servant-docs = appendConfigureFlag (self.callPackage ../servant-docs

1515 {}) "--ghc-options=-Werror";

16− servant-examples = appendConfigureFlag (self.callPackage ../servant-examples

17− {}) "--ghc-options=-Werror";

1816 };

1917 };

2018in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [

21− servant servant-server servant-client servant-jquery servant-docs servant-examples

19+ servant servant-server servant-client servant-jquery servant-docs

2220])

scripts/start-sandbox.shnew file+30

@@ -0,0 +1,30 @@

1+#!/bin/bash -

2+#===============================================================================

3+#

4+# FILE: start-sandbox.sh

5+#

6+# USAGE: ./start-sandbox.sh

7+#

8+# DESCRIPTION: Create sandbox at top-level and add all packages as add-source

9+#

10+# REQUIREMENTS: bash >= 4

11+#===============================================================================

12+

13+set -o nounset

14+set -o errexit

15+

16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

17+SOURCES_TXT="$( dirname $DIR)/sources.txt"

18+CABAL=${CABAL:-cabal}

19+

20+declare -a SOURCES

21+readarray -t SOURCES < "$SOURCES_TXT"

22+

23+prepare_sandbox () {

24+ $CABAL sandbox init

25+ for s in ${SOURCES[@]} ; do

26+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)

27+ done

28+}

29+

30+prepare_sandbox

servant-client/src/Servant/Client.hs+71−6

@@ -21,6 +21,9 @@ module Servant.Client

2121 , module Servant.Common.BaseUrl

2222 ) where

2323

24+#if !MIN_VERSION_base(4,8,0)

25+import Control.Applicative ((<$>))

26+#endif

2427import Control.Monad

2528import Control.Monad.Trans.Either

2629import Data.ByteString.Lazy (ByteString)

@@ -32,7 +35,9 @@ import GHC.TypeLits

3235import Network.HTTP.Client (Response)

3336import Network.HTTP.Media

3437import qualified Network.HTTP.Types as H

38+import qualified Network.HTTP.Types.Header as HTTP

3539import Servant.API

40+import Servant.API.ResponseHeaders

3641import Servant.API.ContentTypes

3742import Servant.Common.BaseUrl

3843import Servant.Common.Req

@@ -133,10 +138,10 @@ instance

133138 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where

134139 type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result

135140 clientWithRoute Proxy req host =

136− performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host

141+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host

137142

138143-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content

139−-- HTTP header.

144+-- HTTP status.

140145instance

141146#if MIN_VERSION_base(4,8,0)

142147 {-# OVERLAPPING #-}

@@ -146,6 +151,21 @@ instance

146151 clientWithRoute Proxy req host =

147152 performRequestNoBody H.methodGet req [204] host

148153

154+-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the

155+-- corresponding headers.

156+instance

157+#if MIN_VERSION_base(4,8,0)

158+ {-# OVERLAPPING #-}

159+#endif

160+ ( MimeUnrender ct a, BuildHeadersTo ls

161+ ) => HasClient (Get (ct ': cts) (Headers ls a)) where

162+ type Client' (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

163+ clientWithRoute Proxy req host = do

164+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host

165+ return $ Headers { getResponse = resp

166+ , getHeadersHList = buildHeadersTo hdrs

167+ }

168+

149169-- | If you use a 'Header' in one of your endpoints in your API,

150170-- the corresponding querying function will automatically take

151171-- an additional argument of the type specified by your 'Header',

@@ -195,7 +215,7 @@ instance

195215 type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

196216

197217 clientWithRoute Proxy req uri =

198− performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri

218+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri

199219

200220-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content

201221-- HTTP header.

@@ -208,6 +228,21 @@ instance

208228 clientWithRoute Proxy req host =

209229 void $ performRequestNoBody H.methodPost req [204] host

210230

231+-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the

232+-- corresponding headers.

233+instance

234+#if MIN_VERSION_base(4,8,0)

235+ {-# OVERLAPPING #-}

236+#endif

237+ ( MimeUnrender ct a, BuildHeadersTo ls

238+ ) => HasClient (Post (ct ': cts) (Headers ls a)) where

239+ type Client' (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

240+ clientWithRoute Proxy req host = do

241+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host

242+ return $ Headers { getResponse = resp

243+ , getHeadersHList = buildHeadersTo hdrs

244+ }

245+

211246-- | If you have a 'Put' endpoint in your API, the client

212247-- side querying function that is created when calling 'client'

213248-- will just require an argument that specifies the scheme, host

@@ -220,7 +255,7 @@ instance

220255 type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

221256

222257 clientWithRoute Proxy req host =

223− performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host

258+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host

224259

225260-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content

226261-- HTTP header.

@@ -233,6 +268,21 @@ instance

233268 clientWithRoute Proxy req host =

234269 void $ performRequestNoBody H.methodPut req [204] host

235270

271+-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the

272+-- corresponding headers.

273+instance

274+#if MIN_VERSION_base(4,8,0)

275+ {-# OVERLAPPING #-}

276+#endif

277+ ( MimeUnrender ct a, BuildHeadersTo ls

278+ ) => HasClient (Put (ct ': cts) (Headers ls a)) where

279+ type Client' (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

280+ clientWithRoute Proxy req host = do

281+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host

282+ return $ Headers { getResponse = resp

283+ , getHeadersHList = buildHeadersTo hdrs

284+ }

285+

236286-- | If you have a 'Patch' endpoint in your API, the client

237287-- side querying function that is created when calling 'client'

238288-- will just require an argument that specifies the scheme, host

@@ -245,7 +295,7 @@ instance

245295 type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

246296

247297 clientWithRoute Proxy req host =

248− performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host

298+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host

249299

250300-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content

251301-- HTTP header.

@@ -258,6 +308,21 @@ instance

258308 clientWithRoute Proxy req host =

259309 void $ performRequestNoBody H.methodPatch req [204] host

260310

311+-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the

312+-- corresponding headers.

313+instance

314+#if MIN_VERSION_base(4,8,0)

315+ {-# OVERLAPPING #-}

316+#endif

317+ ( MimeUnrender ct a, BuildHeadersTo ls

318+ ) => HasClient (Patch (ct ': cts) (Headers ls a)) where

319+ type Client' (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

320+ clientWithRoute Proxy req host = do

321+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host

322+ return $ Headers { getResponse = resp

323+ , getHeadersHList = buildHeadersTo hdrs

324+ }

325+

261326-- | If you use a 'QueryParam' in one of your endpoints in your API,

262327-- the corresponding querying function will automatically take

263328-- an additional argument of the type specified by your 'QueryParam',

@@ -492,7 +557,7 @@ instance (KnownSymbol sym, HasClient sublayout)

492557-- | Pick a 'Method' and specify where the server you want to query is. You get

493558-- back the full `Response`.

494559instance HasClient Raw where

495− type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)

560+ type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)

496561

497562 clientWithRoute :: Proxy Raw -> Req -> Client' Raw

498563 clientWithRoute Proxy req httpMethod host = do

servant-client/src/Servant/Common/Req.hs+13−10

@@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)

2222import Network.HTTP.Client.TLS

2323import Network.HTTP.Media

2424import Network.HTTP.Types

25+import qualified Network.HTTP.Types.Header as HTTP

2526import Network.URI

2627import Servant.API.ContentTypes

2728import Servant.Common.BaseUrl

@@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String

136137displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"

137138

138139

139−performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)

140+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl

141+ -> EitherT ServantError IO ( Int, ByteString, MediaType

142+ , [HTTP.Header], Response ByteString)

140143performRequest reqMethod req isWantedStatus reqHost = do

141144 partialRequest <- liftIO $ reqToRequest req reqHost

142145

@@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do

154157 Right response -> do

155158 let status = Client.responseStatus response

156159 body = Client.responseBody response

160+ headers = Client.responseHeaders response

157161 status_code = statusCode status

158162 ct <- case lookup "Content-Type" $ Client.responseHeaders response of

159163 Nothing -> pure $ "application"//"octet-stream"

@@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do

162166 Just t' -> pure t'

163167 unless (isWantedStatus status_code) $

164168 left $ FailureResponse status ct body

165− return (status_code, body, ct, response)

169+ return (status_code, body, ct, headers, response)

170+

166171

167172performRequestCT :: MimeUnrender ct result =>

168− Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result

173+ Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)

169174performRequestCT ct reqMethod req wantedStatus reqHost = do

170175 let acceptCT = contentType ct

171− (_status, respBody, respCT, _response) <-

176+ (_status, respBody, respCT, headers, _response) <-

172177 performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost

173− unless (matches respCT (acceptCT)) $

174− left $ UnsupportedContentType respCT respBody

175− either

176− (left . (\s -> DecodeFailure s respCT respBody))

177− return

178− (mimeUnrender ct respBody)

178+ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody

179+ case mimeUnrender ct respBody of

180+ Left err -> left $ DecodeFailure err respCT respBody

181+ Right val -> return (headers, val)

179182

180183performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()

181184performRequestNoBody reqMethod req wantedStatus reqHost = do

servant-client/test/Servant/ClientSpec.hs+24−8

@@ -7,7 +7,7 @@

77{-# LANGUAGE RecordWildCards #-}

88{-# LANGUAGE StandaloneDeriving #-}

99{-# LANGUAGE TypeOperators #-}

10−{-# OPTIONS_GHC -fcontext-stack=25 #-}

10+{-# OPTIONS_GHC -fcontext-stack=100 #-}

1111{-# OPTIONS_GHC -fno-warn-orphans #-}

1212module Servant.ClientSpec where

1313

@@ -28,7 +28,8 @@ import qualified Data.Text as T

2828import GHC.Generics

2929import qualified Network.HTTP.Client as C

3030import Network.HTTP.Media

31−import Network.HTTP.Types

31+import Network.HTTP.Types hiding (Header)

32+import qualified Network.HTTP.Types as HTTP

3233import Network.Socket

3334import Network.Wai hiding (Response)

3435import Network.Wai.Handler.Warp

@@ -74,6 +75,8 @@ instance Eq C.HttpException where

7475alice :: Person

7576alice = Person "Alice" 42

7677

78+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

79+

7780type Api =

7881 "get" :> Get '[JSON] Person

7982 :<|> "delete" :> Delete

@@ -93,6 +96,7 @@ type Api =

9396 QueryFlag "third" :>

9497 ReqBody '[JSON] [(String, [Rational])] :>

9598 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

99+ :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

96100api :: Proxy Api

97101api = Proxy

98102

@@ -105,6 +109,7 @@ server = serve api (

105109 :<|> (\ name -> case name of

106110 Just "alice" -> return alice

107111 Just name -> left (400, name ++ " not found")

112+

108113 Nothing -> left (400, "missing parameter"))

109114 :<|> (\ names -> return (zipWith Person names [0..]))

110115 :<|> return

@@ -116,7 +121,8 @@ server = serve api (

116121 :<|> return

117122 :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")

118123 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")

119− :<|> \ a b c d -> return (a, b, c, d)

124+ :<|> (\ a b c d -> return (a, b, c, d))

125+ :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

120126 )

121127

122128withServer :: (BaseUrl -> IO a) -> IO a

@@ -132,11 +138,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool

132138getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person

133139getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]

134140getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool

135−getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)

136−getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)

141+getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,

142+ MediaType, [HTTP.Header], C.Response ByteString)

143+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,

144+ MediaType, [HTTP.Header], C.Response ByteString)

137145getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

138146 -> BaseUrl

139147 -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])

148+getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)

140149( getGet

141150 :<|> getDelete

142151 :<|> getCapture

@@ -149,7 +158,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

149158 :<|> getMatrixFlag

150159 :<|> getRawSuccess

151160 :<|> getRawFailure

152− :<|> getMultiple)

161+ :<|> getMultiple

162+ :<|> getRespHeaders)

153163 = client api

154164

155165type FailApi =

@@ -218,7 +228,7 @@ spec = do

218228 res <- runEitherT (getRawSuccess methodGet host)

219229 case res of

220230 Left e -> assertFailure $ show e

221− Right (code, body, ct, response) -> do

231+ Right (code, body, ct, _, response) -> do

222232 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")

223233 C.responseBody response `shouldBe` body

224234 C.responseStatus response `shouldBe` ok200

@@ -227,11 +237,17 @@ spec = do

227237 res <- runEitherT (getRawFailure methodGet host)

228238 case res of

229239 Left e -> assertFailure $ show e

230− Right (code, body, ct, response) -> do

240+ Right (code, body, ct, _, response) -> do

231241 (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")

232242 C.responseBody response `shouldBe` body

233243 C.responseStatus response `shouldBe` badRequest400

234244

245+ it "Returns headers appropriately" $ withServer $ \ host -> do

246+ res <- runEitherT (getRespHeaders host)

247+ case res of

248+ Left e -> assertFailure $ show e

249+ Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

250+

235251 modifyMaxSuccess (const 20) $ do

236252 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $

237253 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

servant-docs/example/greet.hs+8−4

@@ -8,6 +8,7 @@

88import Control.Lens

99import Data.Aeson

1010import Data.Proxy

11+import Data.ByteString.Conversion

1112import Data.String.Conversions

1213import Data.Text (Text)

1314import GHC.Generics

@@ -53,14 +54,17 @@ instance ToParam (MatrixParam "lang" String) where

5354 "Get the greeting message selected language. Default is en."

5455 Normal

5556

56−instance ToSample Greet where

57− toSample = Just $ Greet "Hello, haskeller!"

57+instance ToSample Greet Greet where

58+ toSample _ = Just $ Greet "Hello, haskeller!"

5859

59− toSamples =

60+ toSamples _ =

6061 [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")

6162 , ("If you use ?capital=false", Greet "Hello, haskeller")

6263 ]

6364

65+instance ToSample Int Int where

66+ toSample _ = Just 1729

67+

6468-- We define some introductory sections, these will appear at the top of the

6569-- documentation.

6670--

@@ -84,7 +88,7 @@ type TestApi =

8488

8589 -- POST /greet with a Greet as JSON in the request body,

8690 -- returns a Greet as JSON

87− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

91+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)

8892

8993 -- DELETE /greet/:greetid

9094 :<|> "greet" :> Capture "greetid" Text :> Delete

servant-docs/servant-docs.cabal+4

@@ -32,8 +32,11 @@ library

3232 build-depends:

3333 base >=4.7 && <5

3434 , bytestring

35+ , bytestring-conversion

36+ , case-insensitive

3537 , hashable

3638 , http-media >= 0.6

39+ , http-types >= 0.7

3740 , lens

3841 , servant >= 0.2.1

3942 , string-conversions

@@ -50,6 +53,7 @@ executable greet-docs

5053 build-depends:

5154 base

5255 , aeson

56+ , bytestring-conversion

5357 , lens

5458 , servant

5559 , servant-docs

servant-docs/src/Servant/Docs/Internal.hs+113−33

@@ -1,17 +1,22 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TemplateHaskell #-}

11−{-# LANGUAGE TupleSections #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TemplateHaskell #-}

13+{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeOperators #-}

16+{-# LANGUAGE UndecidableInstances #-}

17+#if !MIN_VERSION_base(4,8,0)

18+{-# LANGUAGE OverlappingInstances #-}

19+#endif

1520module Servant.Docs.Internal where

1621

1722#if !MIN_VERSION_base(4,8,0)

@@ -19,6 +24,7 @@ import Control.Applicative

1924#endif

2025import Control.Lens

2126import Data.ByteString.Lazy.Char8 (ByteString)

27+import qualified Data.CaseInsensitive as CI

2228import Data.Hashable

2329import Data.HashMap.Strict (HashMap)

2430import Data.List

@@ -26,6 +32,7 @@ import Data.Maybe

2632import Data.Monoid

2733import Data.Ord (comparing)

2834import Data.Proxy

35+import Data.ByteString.Conversion (ToByteString, toByteString)

2936import Data.String.Conversions

3037import Data.Text (Text, pack, unpack)

3138import GHC.Exts (Constraint)

@@ -33,11 +40,13 @@ import GHC.Generics

3340import GHC.TypeLits

3441import Servant.API

3542import Servant.API.ContentTypes

43+import Servant.API.ResponseHeaders

3644import Servant.Utils.Links

3745

3846import qualified Data.HashMap.Strict as HM

3947import qualified Data.Text as T

4048import qualified Network.HTTP.Media as M

49+import qualified Network.HTTP.Types as HTTP

4150

4251-- | Supported HTTP request methods

4352data Method = DocDELETE -- ^ the DELETE method

@@ -191,9 +200,10 @@ data ParamKind = Normal | List | Flag

191200-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]

192201-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}

193202data Response = Response

194− { _respStatus :: Int

195− , _respTypes :: [M.MediaType]

196− , _respBody :: [(Text, M.MediaType, ByteString)]

203+ { _respStatus :: Int

204+ , _respTypes :: [M.MediaType]

205+ , _respBody :: [(Text, M.MediaType, ByteString)]

206+ , _respHeaders :: [HTTP.Header]

197207 } deriving (Eq, Ord, Show)

198208

199209-- | Default response: status code 200, no response body.

@@ -205,7 +215,12 @@ data Response = Response

205215-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"

206216-- > Response {_respStatus = 204, _respBody = Just "[]"}

207217defResponse :: Response

208−defResponse = Response 200 [] []

218+defResponse = Response

219+ { _respStatus = 200

220+ , _respTypes = []

221+ , _respBody = []

222+ , _respHeaders = []

223+ }

209224

210225-- | A datatype that represents everything that can happen

211226-- at an endpoint, with its lenses:

@@ -371,34 +386,53 @@ class HasDocs layout where

371386-- 'toSample': it lets you specify different responses along with

372387-- some context (as 'Text') that explains when you're supposed to

373388-- get the corresponding response.

374−class ToSample a where

389+class ToSample a b | a -> b where

375390 {-# MINIMAL (toSample | toSamples) #-}

376− toSample :: Maybe a

377− toSample = snd <$> listToMaybe samples

378− where samples = toSamples :: [(Text, a)]

391+ toSample :: Proxy a -> Maybe b

392+ toSample _ = snd <$> listToMaybe samples

393+ where samples = toSamples (Proxy :: Proxy a)

394+

395+ toSamples :: Proxy a -> [(Text, b)]

396+ toSamples _ = maybe [] (return . ("",)) s

397+ where s = toSample (Proxy :: Proxy a)

398+

399+instance ToSample a b => ToSample (Headers ls a) b where

400+ toSample _ = toSample (Proxy :: Proxy a)

401+ toSamples _ = toSamples (Proxy :: Proxy a)

402+

379403

380− toSamples :: [(Text, a)]

381− toSamples = maybe [] (return . ("",)) s

382− where s = toSample :: Maybe a

404+class AllHeaderSamples ls where

405+ allHeaderToSample :: Proxy ls -> [HTTP.Header]

406+

407+instance AllHeaderSamples '[] where

408+ allHeaderToSample _ = []

409+

410+instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)

411+ => AllHeaderSamples (Header h l ': ls) where

412+ allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :

413+ allHeaderToSample (Proxy :: Proxy ls)

414+ where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)

415+ mkHeader (Just x) = (headerName, cs $ toByteString x)

416+ mkHeader Nothing = (headerName, "<no header sample provided>")

383417

384418-- | Synthesise a sample value of a type, encoded in the specified media types.

385419sampleByteString

386− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)

420+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)

387421 => Proxy ctypes

388422 -> Proxy a

389423 -> [(M.MediaType, ByteString)]

390424sampleByteString ctypes@Proxy Proxy =

391− maybe [] (allMimeRender ctypes) (toSample :: Maybe a)

425+ maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)

392426

393427-- | Synthesise a list of sample values of a particular type, encoded in the

394428-- specified media types.

395429sampleByteStrings

396− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)

430+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)

397431 => Proxy ctypes

398432 -> Proxy a

399433 -> [(Text, M.MediaType, ByteString)]

400434sampleByteStrings ctypes@Proxy Proxy =

401− let samples = toSamples :: [(Text, a)]

435+ let samples = toSamples (Proxy :: Proxy a)

402436 enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s

403437 in concatMap enc samples

404438

@@ -580,6 +614,7 @@ markdown api = unlines $

580614 "#### Response:" :

581615 "" :

582616 ("- Status code " ++ show (resp ^. respStatus)) :

617+ ("- Headers: " ++ show (resp ^. respHeaders)) :

583618 "" :

584619 formatTypes (resp ^. respTypes) ++

585620 bodies

@@ -630,7 +665,7 @@ instance HasDocs Delete where

630665 action' = action & response.respBody .~ []

631666 & response.respStatus .~ 204

632667

633−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

668+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)

634669 => HasDocs (Get cts a) where

635670 docsFor Proxy (endpoint, action) =

636671 single endpoint' action'

@@ -641,6 +676,20 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

641676 t = Proxy :: Proxy cts

642677 p = Proxy :: Proxy a

643678

679+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts

680+ , AllHeaderSamples ls , GetHeaders (HList ls) )

681+ => HasDocs (Get cts (Headers ls a)) where

682+ docsFor Proxy (endpoint, action) =

683+ single endpoint' action'

684+

685+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)

686+ endpoint' = endpoint & method .~ DocGET

687+ action' = action & response.respBody .~ sampleByteStrings t p

688+ & response.respTypes .~ supportedTypes t

689+ & response.respHeaders .~ hdrs

690+ t = Proxy :: Proxy cts

691+ p = Proxy :: Proxy a

692+

644693instance (KnownSymbol sym, HasDocs sublayout)

645694 => HasDocs (Header sym a :> sublayout) where

646695 docsFor Proxy (endpoint, action) =

@@ -650,7 +699,7 @@ instance (KnownSymbol sym, HasDocs sublayout)

650699 action' = over headers (|> headername) action

651700 headername = pack $ symbolVal (Proxy :: Proxy sym)

652701

653−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

702+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)

654703 => HasDocs (Post cts a) where

655704 docsFor Proxy (endpoint, action) =

656705 single endpoint' action'

@@ -662,7 +711,22 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

662711 t = Proxy :: Proxy cts

663712 p = Proxy :: Proxy a

664713

665−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

714+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts

715+ , AllHeaderSamples ls , GetHeaders (HList ls) )

716+ => HasDocs (Post cts (Headers ls a)) where

717+ docsFor Proxy (endpoint, action) =

718+ single endpoint' action'

719+

720+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)

721+ endpoint' = endpoint & method .~ DocPOST

722+ action' = action & response.respBody .~ sampleByteStrings t p

723+ & response.respTypes .~ supportedTypes t

724+ & response.respStatus .~ 201

725+ & response.respHeaders .~ hdrs

726+ t = Proxy :: Proxy cts

727+ p = Proxy :: Proxy a

728+

729+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)

666730 => HasDocs (Put cts a) where

667731 docsFor Proxy (endpoint, action) =

668732 single endpoint' action'

@@ -674,6 +738,21 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

674738 t = Proxy :: Proxy cts

675739 p = Proxy :: Proxy a

676740

741+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts

742+ , AllHeaderSamples ls , GetHeaders (HList ls) )

743+ => HasDocs (Put cts (Headers ls a)) where

744+ docsFor Proxy (endpoint, action) =

745+ single endpoint' action'

746+

747+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)

748+ endpoint' = endpoint & method .~ DocPUT

749+ action' = action & response.respBody .~ sampleByteStrings t p

750+ & response.respTypes .~ supportedTypes t

751+ & response.respStatus .~ 200

752+ & response.respHeaders .~ hdrs

753+ t = Proxy :: Proxy cts

754+ p = Proxy :: Proxy a

755+

677756instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)

678757 => HasDocs (QueryParam sym a :> sublayout) where

679758

@@ -756,7 +835,8 @@ instance HasDocs Raw where

756835-- example data. However, there's no reason to believe that the instances of

757836-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that

758837-- both are even defined) for any particular type.

759−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)

838+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout

839+ , SupportedTypes cts)

760840 => HasDocs (ReqBody cts a :> sublayout) where

761841

762842 docsFor Proxy (endpoint, action) =

servant-server/src/Servant/Server/Internal.hs+10−5

@@ -46,7 +46,8 @@ import Servant.API ((:<|>) (..), (:>), Capture,

4646import Servant.API.ContentTypes (AcceptHeader (..),

4747 AllCTRender (..),

4848 AllCTUnrender (..))

49−import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)

49+import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,

50+ getHeaders)

5051import Servant.Common.Text (FromText, fromText)

5152

5253data ReqBodyState = Uncalled

@@ -335,7 +336,8 @@ instance

335336#if MIN_VERSION_base(4,8,0)

336337 {-# OVERLAPPING #-}

337338#endif

338− ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

339+ ( GetHeaders (Headers h v), AllCTRender ctypes v

340+ ) => HasServer (Get ctypes (Headers h v)) where

339341

340342 type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)

341343

@@ -450,7 +452,8 @@ instance

450452#if MIN_VERSION_base(4,8,0)

451453 {-# OVERLAPPING #-}

452454#endif

453− ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

455+ ( GetHeaders (Headers h v), AllCTRender ctypes v

456+ ) => HasServer (Post ctypes (Headers h v)) where

454457

455458 type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)

456459

@@ -532,7 +535,8 @@ instance

532535#if MIN_VERSION_base(4,8,0)

533536 {-# OVERLAPPING #-}

534537#endif

535− ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

538+ ( GetHeaders (Headers h v), AllCTRender ctypes v

539+ ) => HasServer (Put ctypes (Headers h v)) where

536540

537541 type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)

538542

@@ -612,7 +616,8 @@ instance

612616#if MIN_VERSION_base(4,8,0)

613617 {-# OVERLAPPING #-}

614618#endif

615− ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where

619+ ( GetHeaders (Headers h v), AllCTRender ctypes v

620+ ) => HasServer (Patch ctypes (Headers h v)) where

616621

617622 type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)

618623

servant/Setupnew file

Binary file not shown.

servant/shell.nixnew file+2

@@ -0,0 +1,2 @@

1+with (import <nixpkgs> {}).pkgs;

2+(haskellngPackages.callPackage ./. {}).env

servant/src/Servant/API.hs+3−2

@@ -78,8 +78,9 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,

7878 QueryParams)

7979import Servant.API.Raw (Raw)

8080import Servant.API.ReqBody (ReqBody)

81−import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse

82− , AddHeader(addHeader) )

81+import Servant.API.ResponseHeaders (Headers, getHeaders,

82+ getHeadersHList, getResponse,

83+ buildHeadersTo, addHeader)

8384import Servant.API.Sub ((:>))

8485import Servant.Common.Text (FromText (..), ToText (..))

8586import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

servant/src/Servant/API/Alternative.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE TypeOperators #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Alternative ((:<|>)(..)) where

56

67#if !MIN_VERSION_base(4,8,0)

servant/src/Servant/API/Capture.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE PolyKinds #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Capture (Capture) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/ContentTypes.hs+1

@@ -10,6 +10,7 @@

1010{-# LANGUAGE TypeFamilies #-}

1111{-# LANGUAGE TypeOperators #-}

1212{-# LANGUAGE UndecidableInstances #-}

13+{-# OPTIONS_HADDOCK not-home #-}

1314

1415-- | A collection of basic Content-Types (also known as Internet Media

1516-- Types, or MIME types). Additionally, this module provides classes that

servant/src/Servant/API/Delete.hs+1

@@ -1,4 +1,5 @@

11{-# LANGUAGE DeriveDataTypeable #-}

2+{-# OPTIONS_HADDOCK not-home #-}

23module Servant.API.Delete (Delete) where

34

45import Data.Typeable ( Typeable )

servant/src/Servant/API/Get.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE KindSignatures #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Get (Get) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/Header.hs+8−3

@@ -1,10 +1,13 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

34{-# LANGUAGE PolyKinds #-}

5+{-# OPTIONS_HADDOCK not-home #-}

46module Servant.API.Header where

57

6−import Data.Typeable (Typeable)

7−import GHC.TypeLits (Symbol)

8+import Data.ByteString (ByteString)

9+import Data.Typeable (Typeable)

10+import GHC.TypeLits (Symbol)

811-- | Extract the given header's value as a value of type @a@.

912--

1013-- Example:

@@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol)

1417-- >>> -- GET /view-my-referer

1518-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer

1619data Header (sym :: Symbol) a = Header a

17− deriving Typeable

20+ | MissingHeader

21+ | UndecodableHeader ByteString

22+ deriving (Typeable, Eq, Show, Functor)

1823

1924-- $setup

2025-- >>> import Servant.API

servant/src/Servant/API/MatrixParam.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE PolyKinds #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/Patch.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE KindSignatures #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Patch (Patch) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/Post.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE KindSignatures #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Post (Post) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/Put.hs+3−2

@@ -1,6 +1,7 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Put (Put) where

56

67import Data.Typeable ( Typeable )

servant/src/Servant/API/QueryParam.hs+1

@@ -2,6 +2,7 @@

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE TypeOperators #-}

44{-# LANGUAGE PolyKinds #-}

5+{-# OPTIONS_HADDOCK not-home #-}

56module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where

67

78import Data.Typeable (Typeable)

servant/src/Servant/API/Raw.hs+1

@@ -1,4 +1,5 @@

11{-# LANGUAGE DeriveDataTypeable #-}

2+{-# OPTIONS_HADDOCK not-home #-}

23module Servant.API.Raw where

34

45import Data.Typeable (Typeable)

servant/src/Servant/API/ReqBody.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE PolyKinds #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.ReqBody where

56

67import Data.Typeable (Typeable)

servant/src/Servant/API/ResponseHeaders.hs+106−20

@@ -9,11 +9,13 @@

99{-# LANGUAGE MultiParamTypeClasses #-}

1010{-# LANGUAGE PolyKinds #-}

1111{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeFamilies #-}

1213{-# LANGUAGE TypeOperators #-}

1314{-# LANGUAGE UndecidableInstances #-}

1415#if !MIN_VERSION_base(4,8,0)

1516{-# LANGUAGE OverlappingInstances #-}

1617#endif

18+{-# OPTIONS_HADDOCK not-home #-}

1719

1820-- | This module provides facilities for adding headers to a response.

1921--

@@ -22,14 +24,22 @@

2224-- The value is added to the header specified by the type (@Location@ in the

2325-- example above).

2426module Servant.API.ResponseHeaders

25− ( Headers

27+ ( Headers(..)

28+ , addHeader

29+ , BuildHeadersTo(buildHeadersTo)

30+ , GetHeaders(getHeaders)

31+ , getHeadersHList

2632 , getResponse

27− , getHeaders

28− , AddHeader(addHeader)

33+ , HeaderValMap

34+ , HList(..)

2935 ) where

3036

31−import Data.ByteString.Char8 (pack)

32−import Data.ByteString.Conversion (ToByteString, toByteString')

37+#if !MIN_VERSION_base(4,8,0)

38+import Control.Applicative ((<$>))

39+#endif

40+import Data.ByteString.Char8 as BS (pack, unlines, init)

41+import Data.ByteString.Conversion (ToByteString, toByteString',

42+ FromByteString, fromByteString)

3343import qualified Data.CaseInsensitive as CI

3444import Data.Proxy

3545import GHC.TypeLits (KnownSymbol, symbolVal)

@@ -41,27 +51,101 @@ import Servant.API.Header (Header (..))

4151-- Instead, use 'addHeader'.

4252data Headers ls a = Headers { getResponse :: a

4353 -- ^ The underlying value of a 'Headers'

44− , getHeaders :: [HTTP.Header]

45− -- ^ The list of header values of a 'Headers'.

46− -- These are guaranteed to correspond with the

47− -- first type of @Headers@ if constructed with

48− -- 'addHeader'.

49− } deriving (Eq, Show, Functor)

54+ , getHeadersHList :: HList ls

55+ -- ^ HList of headers.

56+ } deriving (Functor)

57+

58+data HList a where

59+ HNil :: HList '[]

60+ HCons :: Header h x -> HList xs -> HList (Header h x ': xs)

61+

62+type family HeaderValMap (f :: * -> *) (xs :: [*]) where

63+ HeaderValMap f '[] = '[]

64+ HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs)

65+

66+

67+class BuildHeadersTo hs where

68+ buildHeadersTo :: [HTTP.Header] -> HList hs

69+ -- ^ Note: if there are multiple occurences of a header in the argument,

70+ -- the values are interspersed with commas before deserialization (see

71+ -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)

72+

73+instance

74+#if MIN_VERSION_base(4,8,0)

75+ {-# OVERLAPPING #-}

76+#endif

77+ BuildHeadersTo '[] where

78+ buildHeadersTo _ = HNil

79+

80+instance

81+#if MIN_VERSION_base(4,8,0)

82+ {-# OVERLAPPABLE #-}

83+#endif

84+ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False

85+ ) => BuildHeadersTo ((Header h v) ': xs) where

86+ buildHeadersTo headers =

87+ let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)

88+ matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers

89+ in case matching of

90+ [] -> MissingHeader `HCons` buildHeadersTo headers

91+ xs -> case fromByteString (BS.init $ BS.unlines xs) of

92+ Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)

93+ `HCons` buildHeadersTo headers

94+ Just h -> Header h `HCons` buildHeadersTo headers

95+

96+-- * Getting

97+

98+class GetHeaders ls where

99+ getHeaders :: ls -> [HTTP.Header]

100+

101+instance

102+#if MIN_VERSION_base(4,8,0)

103+ {-# OVERLAPPING #-}

104+#endif

105+ GetHeaders (HList '[]) where

106+ getHeaders _ = []

107+

108+instance

109+#if MIN_VERSION_base(4,8,0)

110+ {-# OVERLAPPABLE #-}

111+#endif

112+ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)

113+ ) => GetHeaders (HList (Header h x ': xs)) where

114+ getHeaders (Header val `HCons` rest) = (headerName , toByteString' val):getHeaders rest

115+ where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)

116+ getHeaders (UndecodableHeader h `HCons` rest) = (headerName, h) : getHeaders rest

117+ where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)

118+

119+instance

120+#if MIN_VERSION_base(4,8,0)

121+ {-# OVERLAPPING #-}

122+#endif

123+ GetHeaders (Headers '[] a) where

124+ getHeaders _ = []

125+

126+instance

127+#if MIN_VERSION_base(4,8,0)

128+ {-# OVERLAPPABLE #-}

129+#endif

130+ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v

131+ ) => GetHeaders (Headers (Header h v ': rest) a) where

132+ getHeaders hs = getHeaders $ getHeadersHList hs

133+

134+-- * Adding

50135

51136-- We need all these fundeps to save type inference

52137class AddHeader h v orig new

53138 | h v orig -> new, new -> h, new -> v, new -> orig where

54− addHeader :: v -> orig -> new

139+ addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times

140+

55141

56142instance

57143#if MIN_VERSION_base(4,8,0)

58144 {-# OVERLAPPING #-}

59145#endif

60− ( KnownSymbol h, ToByteString v

61− ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where

62− addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)

63− where

64− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)

146+ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False

147+ ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where

148+ addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)

65149

66150instance

67151#if MIN_VERSION_base(4,8,0)

@@ -70,10 +154,12 @@ instance

70154 ( KnownSymbol h, ToByteString v

71155 , new ~ (Headers '[Header h v] a)

72156 ) => AddHeader h v a new where

73− addHeader a resp = Headers resp [(headerName, toByteString' a)]

74− where

75− headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)

157+ addHeader a resp = Headers resp (HCons (Header a) HNil)

76158

159+type family Contains x xs where

160+ Contains x ((Header x a) ': xs) = 'True

161+ Contains x ((Header y a) ': xs) = Contains x xs

162+ Contains x '[] = 'False

77163

78164-- $setup

79165-- >>> import Servant.API

servant/src/Servant/API/Sub.hs+1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE PolyKinds #-}

33{-# LANGUAGE TypeOperators #-}

4+{-# OPTIONS_HADDOCK not-home #-}

45module Servant.API.Sub ((:>)) where

56

67import Data.Typeable (Typeable)

servant/src/Servant/Utils/Links.hs+1

@@ -8,6 +8,7 @@

88{-# LANGUAGE TypeFamilies #-}

99{-# LANGUAGE TypeOperators #-}

1010{-# LANGUAGE UndecidableInstances #-}

11+{-# OPTIONS_HADDOCK not-home #-}

1112

1213-- | Type safe generation of internal links.

1314--