5531ada · servant · git.iko.soy

scripts/shell.nix+1−3

compare with master

unifiedsplit

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

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

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

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

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

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

18 };

16 };

19 };

17 };

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

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

22])

20])

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

21 , module Servant.Common.BaseUrl

22 ) where

23

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

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

26+#endif

24import Control.Monad

27import Control.Monad

25import Control.Monad.Trans.Either

28import Control.Monad.Trans.Either

26import Data.ByteString.Lazy (ByteString)

29import Data.ByteString.Lazy (ByteString)

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

32import Network.HTTP.Client (Response)

35import Network.HTTP.Client (Response)

33import Network.HTTP.Media

36import Network.HTTP.Media

34import qualified Network.HTTP.Types as H

37import qualified Network.HTTP.Types as H

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

35import Servant.API

39import Servant.API

40+import Servant.API.ResponseHeaders

36import Servant.API.ContentTypes

41import Servant.API.ContentTypes

37import Servant.Common.BaseUrl

42import Servant.Common.BaseUrl

38import Servant.Common.Req

43import Servant.Common.Req

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

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

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

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

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

135 clientWithRoute Proxy req host =

140 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

137

142

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

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

139−-- HTTP header.

144+-- HTTP status.

140instance

145instance

141#if MIN_VERSION_base(4,8,0)

146#if MIN_VERSION_base(4,8,0)

142 {-# OVERLAPPING #-}

147 {-# OVERLAPPING #-}

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

146 clientWithRoute Proxy req host =

151 clientWithRoute Proxy req host =

147 performRequestNoBody H.methodGet req [204] host

152 performRequestNoBody H.methodGet req [204] host

148

153

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+

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

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

150-- the corresponding querying function will automatically take

170-- the corresponding querying function will automatically take

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

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

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

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

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

196

216

197 clientWithRoute Proxy req uri =

217 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

199

219

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

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

201-- HTTP header.

221-- HTTP header.

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

208 clientWithRoute Proxy req host =

228 clientWithRoute Proxy req host =

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

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

210

230

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+

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

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

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

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

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

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

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

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

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

221

256

222 clientWithRoute Proxy req host =

257 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

224

259

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

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

226-- HTTP header.

261-- HTTP header.

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

233 clientWithRoute Proxy req host =

268 clientWithRoute Proxy req host =

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

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

235

270

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+

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

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

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

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

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

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

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

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

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

246

296

247 clientWithRoute Proxy req host =

297 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

249

299

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

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

251-- HTTP header.

301-- HTTP header.

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

258 clientWithRoute Proxy req host =

308 clientWithRoute Proxy req host =

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

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

260

310

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+

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

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

262-- the corresponding querying function will automatically take

327-- the corresponding querying function will automatically take

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

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

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

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

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

493-- back the full `Response`.

558-- back the full `Response`.

494instance HasClient Raw where

559instance 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)

496

561

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

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

498 clientWithRoute Proxy req httpMethod host = do

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

22import Network.HTTP.Client.TLS

23import Network.HTTP.Media

24import Network.HTTP.Types

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

25import Network.URI

26import Network.URI

26import Servant.API.ContentTypes

27import Servant.API.ContentTypes

27import Servant.Common.BaseUrl

28import Servant.Common.BaseUrl

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

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

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

137

138

139

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

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

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

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

140performRequest reqMethod req isWantedStatus reqHost = do

143performRequest reqMethod req isWantedStatus reqHost = do

141 partialRequest <- liftIO $ reqToRequest req reqHost

144 partialRequest <- liftIO $ reqToRequest req reqHost

142

145

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

154 Right response -> do

157 Right response -> do

155 let status = Client.responseStatus response

158 let status = Client.responseStatus response

156 body = Client.responseBody response

159 body = Client.responseBody response

160+ headers = Client.responseHeaders response

157 status_code = statusCode status

161 status_code = statusCode status

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

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

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

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

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

162 Just t' -> pure t'

166 Just t' -> pure t'

163 unless (isWantedStatus status_code) $

167 unless (isWantedStatus status_code) $

164 left $ FailureResponse status ct body

168 left $ FailureResponse status ct body

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

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

170+

166

171

167performRequestCT :: MimeUnrender ct result =>

172performRequestCT :: 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)

169performRequestCT ct reqMethod req wantedStatus reqHost = do

174performRequestCT ct reqMethod req wantedStatus reqHost = do

170 let acceptCT = contentType ct

175 let acceptCT = contentType ct

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

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

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

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

173− unless (matches respCT (acceptCT)) $

174− left $ UnsupportedContentType respCT respBody

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

175− either

179+ case mimeUnrender ct respBody of

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

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

177− return

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

178− (mimeUnrender ct respBody)

179

182

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

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

181performRequestNoBody reqMethod req wantedStatus reqHost = do

184performRequestNoBody reqMethod req wantedStatus reqHost = do

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

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE TypeOperators #-}

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

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

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

12module Servant.ClientSpec where

13

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

28import GHC.Generics

29import qualified Network.HTTP.Client as C

30import Network.HTTP.Media

31−import Network.HTTP.Types

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

32+import qualified Network.HTTP.Types as HTTP

32import Network.Socket

33import Network.Socket

33import Network.Wai hiding (Response)

34import Network.Wai hiding (Response)

34import Network.Wai.Handler.Warp

35import Network.Wai.Handler.Warp

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

74alice :: Person

75alice :: Person

75alice = Person "Alice" 42

76alice = Person "Alice" 42

76

77

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

79+

77type Api =

80type Api =

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

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

79 :<|> "delete" :> Delete

82 :<|> "delete" :> Delete

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

93 QueryFlag "third" :>

96 QueryFlag "third" :>

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

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

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

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

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

96api :: Proxy Api

100api :: Proxy Api

97api = Proxy

101api = Proxy

98

102

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

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

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

106 Just "alice" -> return alice

110 Just "alice" -> return alice

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

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

112+

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

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

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

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

110 :<|> return

115 :<|> return

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

116 :<|> return

121 :<|> return

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

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

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

123 :<|> (\ _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)

120 )

126 )

121

127

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

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

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

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

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

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

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

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

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

135−getRawSuccess :: 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)

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

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

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

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

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

138 -> BaseUrl

146 -> BaseUrl

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

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

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

140( getGet

149( getGet

141 :<|> getDelete

150 :<|> getDelete

142 :<|> getCapture

151 :<|> getCapture

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

149 :<|> getMatrixFlag

158 :<|> getMatrixFlag

150 :<|> getRawSuccess

159 :<|> getRawSuccess

151 :<|> getRawFailure

160 :<|> getRawFailure

152− :<|> getMultiple)

161+ :<|> getMultiple

162+ :<|> getRespHeaders)

153 = client api

163 = client api

154

164

155type FailApi =

165type FailApi =

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

218 res <- runEitherT (getRawSuccess methodGet host)

228 res <- runEitherT (getRawSuccess methodGet host)

219 case res of

229 case res of

220 Left e -> assertFailure $ show e

230 Left e -> assertFailure $ show e

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

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

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

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

223 C.responseBody response `shouldBe` body

233 C.responseBody response `shouldBe` body

224 C.responseStatus response `shouldBe` ok200

234 C.responseStatus response `shouldBe` ok200

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

227 res <- runEitherT (getRawFailure methodGet host)

237 res <- runEitherT (getRawFailure methodGet host)

228 case res of

238 case res of

229 Left e -> assertFailure $ show e

239 Left e -> assertFailure $ show e

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

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

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

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

232 C.responseBody response `shouldBe` body

242 C.responseBody response `shouldBe` body

233 C.responseStatus response `shouldBe` badRequest400

243 C.responseStatus response `shouldBe` badRequest400

234

244

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+

235 modifyMaxSuccess (const 20) $ do

251 modifyMaxSuccess (const 20) $ do

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

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

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

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

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

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

8import Control.Lens

9import Data.Aeson

10import Data.Proxy

11+import Data.ByteString.Conversion

11import Data.String.Conversions

12import Data.String.Conversions

12import Data.Text (Text)

13import Data.Text (Text)

13import GHC.Generics

14import GHC.Generics

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

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

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

54 Normal

55 Normal

55

56

56−instance ToSample Greet where

57+instance ToSample Greet Greet where

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

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

58

59

59− toSamples =

60+ toSamples _ =

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

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

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

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

62 ]

63 ]

63

64

65+instance ToSample Int Int where

66+ toSample _ = Just 1729

67+

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

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

65-- documentation.

69-- documentation.

66--

70--

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

84

88

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

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

86 -- returns a Greet as JSON

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

88

92

89 -- DELETE /greet/:greetid

93 -- DELETE /greet/:greetid

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

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

servant-docs/servant-docs.cabal+4

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

32 build-depends:

33 base >=4.7 && <5

34 , bytestring

35+ , bytestring-conversion

36+ , case-insensitive

35 , hashable

37 , hashable

36 , http-media >= 0.6

38 , http-media >= 0.6

39+ , http-types >= 0.7

37 , lens

40 , lens

38 , servant >= 0.2.1

41 , servant >= 0.2.1

39 , string-conversions

42 , string-conversions

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

50 build-depends:

53 build-depends:

51 base

54 base

52 , aeson

55 , aeson

56+ , bytestring-conversion

53 , lens

57 , lens

54 , servant

58 , servant

55 , servant-docs

59 , servant-docs

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

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE TemplateHaskell #-}

11−{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TupleSections #-}

12−{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableInstances #-}

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

18+{-# LANGUAGE OverlappingInstances #-}

19+#endif

15module Servant.Docs.Internal where

20module Servant.Docs.Internal where

16

21

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

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

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

19#endif

24#endif

20import Control.Lens

25import Control.Lens

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

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

27+import qualified Data.CaseInsensitive as CI

22import Data.Hashable

28import Data.Hashable

23import Data.HashMap.Strict (HashMap)

29import Data.HashMap.Strict (HashMap)

24import Data.List

30import Data.List

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

26import Data.Monoid

32import Data.Monoid

27import Data.Ord (comparing)

33import Data.Ord (comparing)

28import Data.Proxy

34import Data.Proxy

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

29import Data.String.Conversions

36import Data.String.Conversions

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

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

31import GHC.Exts (Constraint)

38import GHC.Exts (Constraint)

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

33import GHC.TypeLits

40import GHC.TypeLits

34import Servant.API

41import Servant.API

35import Servant.API.ContentTypes

42import Servant.API.ContentTypes

43+import Servant.API.ResponseHeaders

36import Servant.Utils.Links

44import Servant.Utils.Links

37

45

38import qualified Data.HashMap.Strict as HM

46import qualified Data.HashMap.Strict as HM

39import qualified Data.Text as T

47import qualified Data.Text as T

40import qualified Network.HTTP.Media as M

48import qualified Network.HTTP.Media as M

49+import qualified Network.HTTP.Types as HTTP

41

50

42-- | Supported HTTP request methods

51-- | Supported HTTP request methods

43data Method = DocDELETE -- ^ the DELETE method

52data Method = DocDELETE -- ^ the DELETE method

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

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

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

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

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

193data Response = Response

202data Response = Response

194− { _respStatus :: Int

203+ { _respStatus :: Int

195− , _respTypes :: [M.MediaType]

204+ , _respTypes :: [M.MediaType]

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

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

206+ , _respHeaders :: [HTTP.Header]

197 } deriving (Eq, Ord, Show)

207 } deriving (Eq, Ord, Show)

198

208

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

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

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

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

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

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

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

207defResponse :: Response

217defResponse :: Response

208−defResponse = Response 200 [] []

218+defResponse = Response

219+ { _respStatus = 200

220+ , _respTypes = []

221+ , _respBody = []

222+ , _respHeaders = []

223+ }

209

224

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

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

211-- at an endpoint, with its lenses:

226-- at an endpoint, with its lenses:

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

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

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

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

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

373-- get the corresponding response.

388-- get the corresponding response.

374−class ToSample a where

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

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

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

376− toSample :: Maybe a

391+ toSample :: Proxy a -> Maybe b

377− toSample = snd <$> listToMaybe samples

392+ toSample _ = snd <$> listToMaybe samples

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

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+

379

403

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

404+class AllHeaderSamples ls where

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

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

382− where s = toSample :: Maybe a

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

383

417

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

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

385sampleByteString

419sampleByteString

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

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

387 => Proxy ctypes

421 => Proxy ctypes

388 -> Proxy a

422 -> Proxy a

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

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

390sampleByteString ctypes@Proxy Proxy =

424sampleByteString ctypes@Proxy Proxy =

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

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

392

426

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

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

394-- specified media types.

428-- specified media types.

395sampleByteStrings

429sampleByteStrings

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

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

397 => Proxy ctypes

431 => Proxy ctypes

398 -> Proxy a

432 -> Proxy a

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

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

400sampleByteStrings ctypes@Proxy Proxy =

434sampleByteStrings ctypes@Proxy Proxy =

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

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

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

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

403 in concatMap enc samples

437 in concatMap enc samples

404

438

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

580 "#### Response:" :

614 "#### Response:" :

581 "" :

615 "" :

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

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

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

583 "" :

618 "" :

584 formatTypes (resp ^. respTypes) ++

619 formatTypes (resp ^. respTypes) ++

585 bodies

620 bodies

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

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

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

631 & response.respStatus .~ 204

666 & response.respStatus .~ 204

632

667

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

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

634 => HasDocs (Get cts a) where

669 => HasDocs (Get cts a) where

635 docsFor Proxy (endpoint, action) =

670 docsFor Proxy (endpoint, action) =

636 single endpoint' action'

671 single endpoint' action'

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

641 t = Proxy :: Proxy cts

676 t = Proxy :: Proxy cts

642 p = Proxy :: Proxy a

677 p = Proxy :: Proxy a

643

678

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+

644instance (KnownSymbol sym, HasDocs sublayout)

693instance (KnownSymbol sym, HasDocs sublayout)

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

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

646 docsFor Proxy (endpoint, action) =

695 docsFor Proxy (endpoint, action) =

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

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

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

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

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

652

701

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

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

654 => HasDocs (Post cts a) where

703 => HasDocs (Post cts a) where

655 docsFor Proxy (endpoint, action) =

704 docsFor Proxy (endpoint, action) =

656 single endpoint' action'

705 single endpoint' action'

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

662 t = Proxy :: Proxy cts

711 t = Proxy :: Proxy cts

663 p = Proxy :: Proxy a

712 p = Proxy :: Proxy a

664

713

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)

666 => HasDocs (Put cts a) where

730 => HasDocs (Put cts a) where

667 docsFor Proxy (endpoint, action) =

731 docsFor Proxy (endpoint, action) =

668 single endpoint' action'

732 single endpoint' action'

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

674 t = Proxy :: Proxy cts

738 t = Proxy :: Proxy cts

675 p = Proxy :: Proxy a

739 p = Proxy :: Proxy a

676

740

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+

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

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

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

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

679

758

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

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

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

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

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

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

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

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

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

761

841

762 docsFor Proxy (endpoint, action) =

842 docsFor Proxy (endpoint, action) =

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

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

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

47 AllCTRender (..),

48 AllCTUnrender (..))

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

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

50+ getHeaders)

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

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

51

52

52data ReqBodyState = Uncalled

53data ReqBodyState = Uncalled

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

335#if MIN_VERSION_base(4,8,0)

336#if MIN_VERSION_base(4,8,0)

336 {-# OVERLAPPING #-}

337 {-# OVERLAPPING #-}

337#endif

338#endif

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

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

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

339

341

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

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

341

343

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

450#if MIN_VERSION_base(4,8,0)

452#if MIN_VERSION_base(4,8,0)

451 {-# OVERLAPPING #-}

453 {-# OVERLAPPING #-}

452#endif

454#endif

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

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

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

454

457

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

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

456

459

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

532#if MIN_VERSION_base(4,8,0)

535#if MIN_VERSION_base(4,8,0)

533 {-# OVERLAPPING #-}

536 {-# OVERLAPPING #-}

534#endif

537#endif

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

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

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

536

540

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

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

538

542

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

612#if MIN_VERSION_base(4,8,0)

616#if MIN_VERSION_base(4,8,0)

613 {-# OVERLAPPING #-}

617 {-# OVERLAPPING #-}

614#endif

618#endif

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

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

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

616

621

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

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

618

623

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,

78 QueryParams)

79import Servant.API.Raw (Raw)

80import Servant.API.ReqBody (ReqBody)

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

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

82+ getHeadersHList, getResponse,

82− , AddHeader(addHeader) )

83+ buildHeadersTo, addHeader)

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

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

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

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

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

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

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE TypeOperators #-}

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

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

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

5

6

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

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

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

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

4module Servant.API.Capture (Capture) where

5module Servant.API.Capture (Capture) where

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

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

13

14

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

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

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

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

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

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

1{-# LANGUAGE DeriveDataTypeable #-}

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

2module Servant.API.Delete (Delete) where

3module Servant.API.Delete (Delete) where

3

4

4import Data.Typeable ( Typeable )

5import Data.Typeable ( Typeable )

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE KindSignatures #-}

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

4module Servant.API.Get (Get) where

5module Servant.API.Get (Get) where

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE PolyKinds #-}

4{-# LANGUAGE PolyKinds #-}

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

4module Servant.API.Header where

6module Servant.API.Header where

5

7

6−import Data.Typeable (Typeable)

8+import Data.ByteString (ByteString)

9+import Data.Typeable (Typeable)

7−import GHC.TypeLits (Symbol)

10+import GHC.TypeLits (Symbol)

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

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

9--

12--

10-- Example:

13-- Example:

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

14-- >>> -- GET /view-my-referer

17-- >>> -- GET /view-my-referer

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

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

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

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

20+ | MissingHeader

21+ | UndecodableHeader ByteString

17− deriving Typeable

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

18

23

19-- $setup

24-- $setup

20-- >>> import Servant.API

25-- >>> import Servant.API

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

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

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

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

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE KindSignatures #-}

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

4module Servant.API.Patch (Patch) where

5module Servant.API.Patch (Patch) where

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE KindSignatures #-}

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

4module Servant.API.Post (Post) where

5module Servant.API.Post (Post) where

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

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

4module Servant.API.Put (Put) where

5module Servant.API.Put (Put) where

5

6

6import Data.Typeable ( Typeable )

7import Data.Typeable ( Typeable )

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

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

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE PolyKinds #-}

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

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

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

6

7

7import Data.Typeable (Typeable)

8import Data.Typeable (Typeable)

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

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

1{-# LANGUAGE DeriveDataTypeable #-}

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

2module Servant.API.Raw where

3module Servant.API.Raw where

3

4

4import Data.Typeable (Typeable)

5import Data.Typeable (Typeable)

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

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

4module Servant.API.ReqBody where

5module Servant.API.ReqBody where

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

9{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

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

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

15{-# LANGUAGE OverlappingInstances #-}

16{-# LANGUAGE OverlappingInstances #-}

16#endif

17#endif

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

17

19

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

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

19--

21--

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

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

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

23-- example above).

25-- example above).

24module Servant.API.ResponseHeaders

26module Servant.API.ResponseHeaders

25− ( Headers

27+ ( Headers(..)

28+ , addHeader

29+ , BuildHeadersTo(buildHeadersTo)

30+ , GetHeaders(getHeaders)

31+ , getHeadersHList

26 , getResponse

32 , getResponse

27− , getHeaders

33+ , HeaderValMap

28− , AddHeader(addHeader)

34+ , HList(..)

29 ) where

35 ) where

30

36

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

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

39+#endif

31−import Data.ByteString.Char8 (pack)

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

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

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

42+ FromByteString, fromByteString)

33import qualified Data.CaseInsensitive as CI

43import qualified Data.CaseInsensitive as CI

34import Data.Proxy

44import Data.Proxy

35import GHC.TypeLits (KnownSymbol, symbolVal)

45import GHC.TypeLits (KnownSymbol, symbolVal)

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

41-- Instead, use 'addHeader'.

51-- Instead, use 'addHeader'.

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

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

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

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

44− , getHeaders :: [HTTP.Header]

54+ , getHeadersHList :: HList ls

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

55+ -- ^ HList of headers.

46− -- These are guaranteed to correspond with the

56+ } deriving (Functor)

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

57+

48− -- 'addHeader'.

58+data HList a where

49− } deriving (Eq, Show, Functor)

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

50

135

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

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

52class AddHeader h v orig new

137class AddHeader h v orig new

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

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

55

141

56instance

142instance

57#if MIN_VERSION_base(4,8,0)

143#if MIN_VERSION_base(4,8,0)

58 {-# OVERLAPPING #-}

144 {-# OVERLAPPING #-}

59#endif

145#endif

60− ( KnownSymbol h, ToByteString v

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

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

147+ ) => 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)

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

63− where

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

65

149

66instance

150instance

67#if MIN_VERSION_base(4,8,0)

151#if MIN_VERSION_base(4,8,0)

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

70 ( KnownSymbol h, ToByteString v

154 ( KnownSymbol h, ToByteString v

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

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

72 ) => AddHeader h v a new where

156 ) => AddHeader h v a new where

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

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

74− where

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

76

158

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

77

163

78-- $setup

164-- $setup

79-- >>> import Servant.API

165-- >>> import Servant.API

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

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

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE PolyKinds #-}

3{-# LANGUAGE TypeOperators #-}

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

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

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

5

6

6import Data.Typeable (Typeable)

7import Data.Typeable (Typeable)

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

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

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE UndecidableInstances #-}

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

11

12

12-- | Type safe generation of internal links.

13-- | Type safe generation of internal links.

13--

14--