2082abf · servant · git.iko.soy

.travis.yml+11−17

compare with master

unifiedsplit

@@ -3,33 +3,27 @@ sudo: false

3language: c

4

5env:

6− - GHCVER=7.8.4 CABALVER=1.22

6+ - STACK_YAML=stack-ghc-7.8.4.yaml

7− - GHCVER=7.10.3 CABALVER=1.22

7+ - STACK_YAML=stack.yaml

8− - GHCVER=8.0.1 CABALVER=1.24

8+ - STACK_YAML=stack-ghc-8.0.1.yaml

9

10addons:

11 apt:

12− sources:

13− - hvr-ghc

14 packages:

12 packages:

15− - ghc-7.8.4

16− - ghc-7.10.3

17− - ghc-8.0.1

18− - cabal-install-1.22

19− - cabal-install-1.24

20 - libgmp-dev

13 - libgmp-dev

21

14

22install:

15install:

16+ - mkdir -p ~/.local/bin

17+ - export PATH=$HOME/.local/bin:$PATH

18+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

19+ - stack --version

20+ - stack setup --no-terminal

23− - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)

21+ - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)

24− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

25− - ghc --version

26− - cabal --version

27− - travis_retry cabal update

28− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

29

22

30script:

23script:

31− - ./travis.sh

24+ - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi

32

25

33cache:

26cache:

34 directories:

27 directories:

35 - $HOME/.tinc/cache

28 - $HOME/.tinc/cache

29+ - $HOME/.stack

CONTRIBUTING.md+2−1

@@ -8,9 +8,10 @@ repository. You can use `cabal`:

8./scripts/test-all.sh # Run all the tests

9```

10

11−`stack`:

11+Or `stack`:

12

13```shell

14+stack setup # Downloads and installs a proper GHC version if necessary

14stack build # Install and build packages

15stack build # Install and build packages

15stack test # Run all the tests

16stack test # Run all the tests

16```

17```

doc/requirements.txt+1−1

@@ -17,7 +17,7 @@ recommonmark==0.4.0

17singledispatch==3.4.0.3

18six==1.10.0

19snowballstemmer==1.2.1

20−Sphinx==1.3.4

20+Sphinx==1.3.6

21sphinx-autobuild==0.5.2

22sphinx-rtd-theme==0.1.9

23tornado==4.3

doc/tutorial/ApiType.lhs+10−2

@@ -58,6 +58,14 @@ Let's break that down:

58 is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow

59 equivalent to `/`, but sometimes it just lets you chain another combinator.

60

61+Tip: If your endpoint responds to `/` (the root path), just omit any combinators

62+that introduce path segments. E.g. the following api has only one endpoint on `/`:

63+

64+``` haskell

65+type RootEndpoint =

66+ Get '[JSON] User

67+```

68+

61We can also describe APIs with multiple endpoints by using the `:<|>`

69We can also describe APIs with multiple endpoints by using the `:<|>`

62combinators. Here's an example:

70combinators. Here's an example:

63

71

@@ -311,8 +319,8 @@ Which is used like so:

311

319

312``` haskell

320``` haskell

313type ProtectedAPI12

321type ProtectedAPI12

314− = UserAPI -- this is public

322+ = UserAPI -- this is public

315− :<|> BasicAuth "my-real" User :> UserAPI2 -- this is protected by auth

323+ :<|> BasicAuth "my-realm" User :> UserAPI2 -- this is protected by auth

316```

324```

317

325

318### Interoperability with `wai`: `Raw`

326### Interoperability with `wai`: `Raw`

doc/tutorial/Client.lhs+10−17

@@ -15,11 +15,10 @@ need to have some language extensions and imports:

15

16module Client where

17

18−import Control.Monad.Trans.Except (ExceptT, runExceptT)

19import Data.Aeson

18import Data.Aeson

20import Data.Proxy

19import Data.Proxy

21import GHC.Generics

20import GHC.Generics

22−import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)

21+import Network.HTTP.Client (newManager, defaultManagerSettings)

23import Servant.API

22import Servant.API

24import Servant.Client

23import Servant.Client

25```

24```

@@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que

71``` haskell

70``` haskell

72position :: Int -- ^ value for "x"

71position :: Int -- ^ value for "x"

73 -> Int -- ^ value for "y"

72 -> Int -- ^ value for "y"

74− -> Manager -- ^ the HTTP client to use

73+ -> ClientM Position

75− -> BaseUrl -- ^ the URL at which the API can be found

76− -> ExceptT ServantError IO Position

77

74

78hello :: Maybe String -- ^ an optional value for "name"

75hello :: Maybe String -- ^ an optional value for "name"

79− -> Manager -- ^ the HTTP client to use

80− -> BaseUrl -- ^ the URL at which the API can be found

81− -> ExceptT ServantError IO HelloMessage

76+ -> ClientM HelloMessage

82

77

83marketing :: ClientInfo -- ^ value for the request body

78marketing :: ClientInfo -- ^ value for the request body

84− -> Manager -- ^ the HTTP client to use

79+ -> ClientM Email

85− -> BaseUrl -- ^ the URL at which the API can be found

86− -> ExceptT ServantError IO Email

87```

80```

88

81

89Each function makes available as an argument any value that the response may

82Each function makes available as an argument any value that the response may

@@ -120,17 +113,17 @@ data BaseUrl = BaseUrl

120That's it. Let's now write some code that uses our client functions.

113That's it. Let's now write some code that uses our client functions.

121

114

122``` haskell

115``` haskell

123−queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email)

116+queries :: ClientM (Position, HelloMessage, Email)

124−queries manager baseurl = do

117+queries = do

125− pos <- position 10 10 manager baseurl

118+ pos <- position 10 10

126− message <- hello (Just "servant") manager baseurl

119+ message <- hello (Just "servant")

127− em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl

120+ em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])

128 return (pos, message, em)

121 return (pos, message, em)

129

122

130run :: IO ()

123run :: IO ()

131run = do

124run = do

132 manager <- newManager defaultManagerSettings

125 manager <- newManager defaultManagerSettings

133− res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 ""))

126+ res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))

134 case res of

127 case res of

135 Left err -> putStrLn $ "Error: " ++ show err

128 Left err -> putStrLn $ "Error: " ++ show err

136 Right (pos, message, em) -> do

129 Right (pos, message, em) -> do

doc/tutorial/Javascript.lhs+312−22

@@ -151,21 +151,120 @@ so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.

151

152Very similarly to how one can derive haskell functions, we can derive the

153javascript with just a simple function call to `jsForAPI` from

154−`Servant.JQuery`.

154+`Servant.JS`.

155

156``` haskell

157−apiJS :: Text

157+apiJS1 :: Text

158−apiJS = jsForAPI api vanillaJS

158+apiJS1 = jsForAPI api jquery

159```

160

161This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':

162

163``` javascript

164+

165+var getPoint = function(onSuccess, onError)

166+{

167+ $.ajax(

168+ { url: '/point'

169+ , success: onSuccess

170+ , error: onError

171+ , type: 'GET'

172+ });

173+}

174+

175+var getBooks = function(q, onSuccess, onError)

176+{

177+ $.ajax(

178+ { url: '/books' + '?q=' + encodeURIComponent(q)

179+ , success: onSuccess

180+ , error: onError

181+ , type: 'GET'

182+ });

183+}

184+```

185+

186+We created a directory `static` that contains two static files: `index.html`,

187+which is the entrypoint to our little web application; and `ui.js`, which

188+contains some hand-written javascript. This javascript code assumes the two

189+generated functions `getPoint` and `getBooks` in scope. Therefore we need to

190+write the generated javascript into a file:

191+

192+``` haskell

193+writeJSFiles :: IO ()

194+writeJSFiles = do

195+ T.writeFile "static/api.js" apiJS1

196+ jq <- T.readFile =<< Language.Javascript.JQuery.file

197+ T.writeFile "static/jq.js" jq

198+```

199+

200+(We're also writing the jquery library into a file, as it's also used by

201+`ui.js`.) `static/api.js` will be included in `index.html` and the two

202+generated functions will therefore be available in `ui.js`.

203+

204+And we're good to go. You can start the `main` function of this file and go to

205+`http://localhost:8000/`. Start typing in the name of one of the authors in our

206+database or part of a book title, and check out how long it takes to

207+approximate pi using the method mentioned above.

208+

209+## Customizations

210+

211+Instead of calling `jquery`, you can call its variant `jqueryWith`.

212+Here are the type definitions

213+

214+```haskell ignore

215+jquery :: JavaScriptGenerator

216+jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator

217+```

218+

219+The `CommonGeneratorOptions` will let you define different behaviors to

220+change how functions are generated. Here is the definition of currently

221+available options:

222+

223+```haskell ignore

224+data CommonGeneratorOptions = CommonGeneratorOptions

225+ {

226+ -- | function generating function names

227+ functionNameBuilder :: FunctionName -> Text

228+ -- | name used when a user want to send the request body (to let you redefine it)

229+ , requestBody :: Text

230+ -- | name of the callback parameter when the request was successful

231+ , successCallback :: Text

232+ -- | name of the callback parameter when the request reported an error

233+ , errorCallback :: Text

234+ -- | namespace on which we define the js function (empty mean local var)

235+ , moduleName :: Text

236+ -- | a prefix that should be prepended to the URL in the generated JS

237+ , urlPrefix :: Text

238+ }

239+```

240+

241+This pattern is available with all supported backends, and default values are provided.

242+

243+## Vanilla support

244+

245+If you don't use JQuery for your application, you can reduce your

246+dependencies to simply use the `XMLHttpRequest` object from the standard API.

247+

248+Use the same code as before but simply replace the previous `apiJS` with

249+the following one:

250+

251+``` haskell

252+apiJS2 :: Text

253+apiJS2 = jsForAPI api vanillaJS

254+```

255+

256+The rest is *completely* unchanged.

257+

258+The output file is a bit different, but it has the same parameters,

259+

260+``` javascript

261+

262+

164var getPoint = function(onSuccess, onError)

263var getPoint = function(onSuccess, onError)

165{

264{

166 var xhr = new XMLHttpRequest();

265 var xhr = new XMLHttpRequest();

167 xhr.open('GET', '/point', true);

266 xhr.open('GET', '/point', true);

168− xhr.setRequestHeader("Accept","application/json");

267+ xhr.setRequestHeader(\"Accept\",\"application/json\");

169 xhr.onreadystatechange = function (e) {

268 xhr.onreadystatechange = function (e) {

170 if (xhr.readyState == 4) {

269 if (xhr.readyState == 4) {

171 if (xhr.status == 204 || xhr.status == 205) {

270 if (xhr.status == 204 || xhr.status == 205) {

@@ -186,7 +285,7 @@ var getBooks = function(q, onSuccess, onError)

186{

285{

187 var xhr = new XMLHttpRequest();

286 var xhr = new XMLHttpRequest();

188 xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);

287 xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);

189− xhr.setRequestHeader("Accept","application/json");

288+ xhr.setRequestHeader(\"Accept\",\"application/json\");

190 xhr.onreadystatechange = function (e) {

289 xhr.onreadystatechange = function (e) {

191 if (xhr.readyState == 4) {

290 if (xhr.readyState == 4) {

192 if (xhr.status == 204 || xhr.status == 205) {

291 if (xhr.status == 204 || xhr.status == 205) {

@@ -202,27 +301,218 @@ var getBooks = function(q, onSuccess, onError)

202 }

301 }

203 xhr.send(null);

302 xhr.send(null);

204}

303}

304+

305+

205```

306```

206

307

207−We created a directory `static` that contains two static files: `index.html`,

308+And that's all, your web service can of course be accessible from those

208−which is the entrypoint to our little web application; and `ui.js`, which

309+two clients at the same time!

209−contains some hand-written javascript. This javascript code assumes the two

310+

210−generated functions `getPoint` and `getBooks` in scope. Therefore we need to

311+## Axios support

211−write the generated javascript into a file:

312+

313+### Simple usage

314+

315+If you use Axios library for your application, we support that too!

316+

317+Use the same code as before but simply replace the previous `apiJS` with

318+the following one:

212

319

213``` haskell

320``` haskell

214−writeJSFiles :: IO ()

321+apiJS3 :: Text

215−writeJSFiles = do

322+apiJS3 = jsForAPI api $ axios defAxiosOptions

216− T.writeFile "static/api.js" apiJS

217− jq <- T.readFile =<< Language.Javascript.JQuery.file

218− T.writeFile "static/jq.js" jq

219```

323```

220

324

221−(We're also writing the jquery library into a file, as it's also used by

325+The rest is *completely* unchanged.

222−`ui.js`.) `static/api.js` will be included in `index.html` and the two

326+

223−generated functions will therefore be available in `ui.js`.

327+The output file is a bit different,

328+

329+``` javascript

330+

331+

332+var getPoint = function()

333+{

334+ return axios({ url: '/point'

335+ , method: 'get'

336+ });

337+}

338+

339+

340+

341+var getBooks = function(q)

342+{

343+ return axios({ url: '/books' + '?q=' + encodeURIComponent(q)

344+ , method: 'get'

345+ });

346+}

347+

348+```

349+

350+**Caution:** In order to support the promise style of the API, there are no onSuccess

351+nor onError callback functions.

352+

353+### Defining Axios configuration

354+

355+Axios lets you define a 'configuration' to determine the behavior of the

356+program when the AJAX request is sent.

357+

358+We mapped this into a configuration

359+

360+``` haskell

361+data AxiosOptions = AxiosOptions

362+ { -- | indicates whether or not cross-site Access-Control requests

363+ -- should be made using credentials

364+ withCredentials :: !Bool

365+ -- | the name of the cookie to use as a value for xsrf token

366+ , xsrfCookieName :: !(Maybe Text)

367+ -- | the name of the header to use as a value for xsrf token

368+ , xsrfHeaderName :: !(Maybe Text)

369+ }

370+```

371+

372+## Angular support

373+

374+### Simple usage

375+

376+You can apply the same procedure as with `vanillaJS` and `jquery`, and

377+generate top level functions.

378+

379+The difference is that `angular` Generator always takes an argument.

380+

381+``` haskell

382+apiJS4 :: Text

383+apiJS4 = jsForAPI api $ angular defAngularOptions

384+```

385+

386+The generated code will be a bit different than previous generators. An extra

387+argument `$http` will be added to let Angular magical Dependency Injector

388+operate.

389+

390+**Caution:** In order to support the promise style of the API, there are no onSuccess

391+nor onError callback functions.

392+

393+``` javascript

394+

395+

396+var getPoint = function($http)

397+{

398+ return $http(

399+ { url: '/point'

400+ , method: 'GET'

401+ });

402+}

403+

404+

405+

406+var getBooks = function($http, q)

407+{

408+ return $http(

409+ { url: '/books' + '?q=' + encodeURIComponent(q)

410+ , method: 'GET'

411+ });

412+}

413+

414+```

415+

416+You can then build your controllers easily

417+

418+``` javascript

419+

420+app.controller("MyController", function($http) {

421+ this.getPoint = getPoint($http)

422+ .success(/* Do something */)

423+ .error(/* Report error */);

424+

425+ this.getPoint = getBooks($http, q)

426+ .success(/* Do something */)

427+ .error(/* Report error */);

428+});

429+```

430+

431+### Service generator

432+

433+You can also generate automatically a service to wrap the whole API as

434+a single Angular service:

435+

436+``` javascript

437+app.service('MyService', function($http) {

438+ return ({

439+ postCounter: function()

440+ {

441+ return $http(

442+ { url: '/counter'

443+ , method: 'POST'

444+ });

445+ },

446+ getCounter: function()

447+ {

448+ return $http(

449+ { url: '/books' + '?q=' + encodeURIComponent(q), true);

450+ , method: 'GET'

451+ });

452+ }

453+ });

454+});

455+```

456+

457+To do so, you just have to use an alternate generator.

458+

459+``` haskell

460+apiJS5 :: Text

461+apiJS5 = jsForAPI api $ angularService defAngularOptions

462+```

463+

464+Again, it is possible to customize some portions with the options.

465+

466+``` haskell

467+data AngularOptions = AngularOptions

468+ { -- | When generating code with wrapInService, name of the service to generate, default is 'app'

469+ serviceName :: Text

470+ , -- | beginning of the service definition

471+ prologue :: Text -> Text -> Text

472+ , -- | end of the service definition

473+ epilogue :: Text

474+ }

475+```

476+

477+# Custom function name builder

478+

479+Servant comes with three name builders included:

480+

481+- camelCase (the default)

482+- concatCase

483+- snakeCase

484+

485+Keeping the JQuery as an example, let's see the impact:

486+

487+``` haskell

488+apiJS6 :: Text

489+apiJS6 = jsForAPI api $ jqueryWith defCommonGeneratorOptions { functionNameBuilder= snakeCase }

490+```

491+

492+This `Text` contains 2 Javascript functions:

493+

494+``` javascript

495+

496+

497+var get_point = function(onSuccess, onError)

498+{

499+ $.ajax(

500+ { url: '/point'

501+ , success: onSuccess

502+ , error: onError

503+ , type: 'GET'

504+ });

505+}

506+

507+var get_books = function(q, onSuccess, onError)

508+{

509+ $.ajax(

510+ { url: '/books' + '?q=' + encodeURIComponent(q)

511+ , success: onSuccess

512+ , error: onError

513+ , type: 'GET'

514+ });

515+}

516+

517+```

224

518

225−And we're good to go. You can start the `main` function of this file and go to

226−`http://localhost:8000/`. Start typing in the name of one of the authors in our

227−database or part of a book title, and check out how long it takes to

228−approximate pi using the method mentioned above.

doc/tutorial/test/JavascriptSpec.hs+5−2

@@ -15,7 +15,10 @@ spec = do

15 describe "apiJS" $ do

16 it "is contained verbatim in Javascript.lhs" $ do

17 code <- readFile "Javascript.lhs"

18+ cs apiJS1 `shouldSatisfy` (`isInfixOf` code)

19+ cs apiJS3 `shouldSatisfy` (`isInfixOf` code)

20+ cs apiJS4 `shouldSatisfy` (`isInfixOf` code)

18− cs apiJS `shouldSatisfy` (`isInfixOf` code)

21+ cs apiJS6 `shouldSatisfy` (`isInfixOf` code)

19

22

20 describe "writeJSFiles" $ do

23 describe "writeJSFiles" $ do

21 it "[not a test] write apiJS to static/api.js" $ do

24 it "[not a test] write apiJS to static/api.js" $ do

@@ -24,7 +27,7 @@ spec = do

24 describe "app" $ with (return app) $ do

27 describe "app" $ with (return app) $ do

25 context "/api.js" $ do

28 context "/api.js" $ do

26 it "delivers apiJS" $ do

29 it "delivers apiJS" $ do

27− get "/api.js" `shouldRespondWith` (fromString (cs apiJS))

30+ get "/api.js" `shouldRespondWith` (fromString (cs apiJS1))

28

31

29 context "/" $ do

32 context "/" $ do

30 it "delivers something" $ do

33 it "delivers something" $ do

doc/tutorial/tutorial.cabal+6−6

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

1name: tutorial

2−version: 0.8

2+version: 0.9

3synopsis: The servant tutorial

4homepage: http://haskell-servant.readthedocs.org/

5license: BSD3

@@ -25,11 +25,11 @@ library

25 , directory

26 , blaze-markup

27 , containers

28− , servant == 0.8.*

28+ , servant == 0.9.*

29− , servant-server == 0.8.*

29+ , servant-server == 0.9.*

30− , servant-client == 0.8.*

30+ , servant-client == 0.9.*

31− , servant-docs == 0.8.*

31+ , servant-docs == 0.9.*

32− , servant-js == 0.8.*

32+ , servant-js == 0.9.*

33 , warp

34 , http-media

35 , lucid

travis.sh → scripts/ci-cron.shrenamed+8−1

@@ -1,8 +1,15 @@

1#!/usr/bin/env bash

2

3+set -o nounset

3set -o errexit

4set -o errexit

5+set -o verbose

4

6

7+export PATH=$(stack path --bin-path):$PATH

8+

9+stack install cabal-install

10+cabal update

11+

5−for package in $(cat sources.txt) doc/tutorial ; do

12+for package in $(cat sources.txt) ; do

6 echo testing $package

13 echo testing $package

7 pushd $package

14 pushd $package

8 tinc

15 tinc

servant-client/CHANGELOG.md+7

@@ -1,3 +1,10 @@

1+0.9

2+---

3+

4+* BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for

5+ BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be

6+ passed to each method returned by `client`.

7+

10.7.1

80.7.1

2-----

9-----

3

10

servant-client/servant-client.cabal+9−6

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

1name: servant-client

2−version: 0.8

2+version: 0.9

3synopsis: automatical derivation of querying functions for servant webservices

4description:

5 This library lets you derive automatically Haskell functions that

@@ -45,23 +45,24 @@ library

45 Servant.Client.PerformRequest.GHC

46 build-depends:

47 base >= 4.7 && < 4.10

48− , aeson >= 0.7 && < 0.12

48+ , aeson >= 0.7 && < 1.1

49 , attoparsec >= 0.12 && < 0.14

50 , base64-bytestring >= 1.0.0.1 && < 1.1

51 , bytestring >= 0.10 && < 0.11

52 , exceptions >= 0.8 && < 0.9

53− , http-api-data >= 0.1 && < 0.3

53+ , http-api-data >= 0.3 && < 0.4

54 , http-client >= 0.4.18.1 && < 0.6

55 , http-client-tls >= 0.2.2 && < 0.4

56 , http-media >= 0.6.2 && < 0.7

57 , http-types >= 0.8.6 && < 0.10

58 , network-uri >= 2.6 && < 2.7

59 , safe >= 0.3.9 && < 0.4

60− , servant == 0.8.*

60+ , servant == 0.9.*

61 , string-conversions >= 0.3 && < 0.5

62 , text >= 1.2 && < 1.3

63 , transformers >= 0.3 && < 0.6

64 , transformers-compat >= 0.4 && < 0.6

65+ , mtl

65 if impl(ghcjs)

66 if impl(ghcjs)

66 build-depends:

67 build-depends:

67 ghcjs-base

68 ghcjs-base

@@ -106,14 +107,16 @@ test-suite spec

106 , bytestring

107 , bytestring

107 , deepseq

108 , deepseq

108 , hspec >= 2.2.1 && < 2.3

109 , hspec >= 2.2.1 && < 2.3

110+ , http-api-data

109 , http-client

111 , http-client

110 , http-media

112 , http-media

111 , http-types

113 , http-types

112 , HUnit

114 , HUnit

115+ , mtl

113 , network >= 2.6

116 , network >= 2.6

114 , QuickCheck >= 2.7

117 , QuickCheck >= 2.7

115− , servant == 0.8.*

118+ , servant == 0.9.*

116− , servant-server == 0.8.*

119+ , servant-server == 0.9.*

117 , text

120 , text

118 , wai

121 , wai

119 , warp

122 , warp

servant-client/src/Servant/Client.hs+48−14

@@ -20,6 +20,8 @@ module Servant.Client

20 , client

21 , HasClient(..)

22 , ClientM

23+ , runClientM

24+ , ClientEnv (ClientEnv)

23 , mkAuthenticateReq

25 , mkAuthenticateReq

24 , ServantError(..)

26 , ServantError(..)

25 , module Servant.Common.BaseUrl

27 , module Servant.Common.BaseUrl

@@ -34,7 +36,7 @@ import Data.Proxy

34import Data.String.Conversions

36import Data.String.Conversions

35import Data.Text (unpack)

37import Data.Text (unpack)

36import GHC.TypeLits

38import GHC.TypeLits

37−import Network.HTTP.Client (Manager, Response)

39+import Network.HTTP.Client (Response)

38import Network.HTTP.Media

40import Network.HTTP.Media

39import qualified Network.HTTP.Types as H

41import qualified Network.HTTP.Types as H

40import qualified Network.HTTP.Types.Header as HTTP

42import qualified Network.HTTP.Types.Header as HTTP

@@ -119,21 +121,53 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api)

119

121

120 where p = unpack (toUrlPiece val)

122 where p = unpack (toUrlPiece val)

121

123

124+-- | If you use a 'CaptureAll' in one of your endpoints in your API,

125+-- the corresponding querying function will automatically take an

126+-- additional argument of a list of the type specified by your

127+-- 'CaptureAll'. That function will take care of inserting a textual

128+-- representation of this value at the right place in the request

129+-- path.

130+--

131+-- You can control how these values are turned into text by specifying

132+-- a 'ToHttpApiData' instance of your type.

133+--

134+-- Example:

135+--

136+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile

137+-- >

138+-- > myApi :: Proxy

139+-- > myApi = Proxy

140+--

141+-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile

142+-- > getSourceFile = client myApi

143+-- > -- then you can use "getSourceFile" to query that endpoint

144+instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)

145+ => HasClient (CaptureAll capture a :> sublayout) where

146+

147+ type Client (CaptureAll capture a :> sublayout) =

148+ [a] -> Client sublayout

149+

150+ clientWithRoute Proxy req vals =

151+ clientWithRoute (Proxy :: Proxy sublayout)

152+ (foldl' (flip appendToPath) req ps)

153+

154+ where ps = map (unpack . toUrlPiece) vals

155+

122instance OVERLAPPABLE_

156instance OVERLAPPABLE_

123 -- Note [Non-Empty Content Types]

157 -- Note [Non-Empty Content Types]

124 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

158 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

125 ) => HasClient (Verb method status cts' a) where

159 ) => HasClient (Verb method status cts' a) where

126− type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a

160+ type Client (Verb method status cts' a) = ClientM a

127− clientWithRoute Proxy req manager baseurl =

161+ clientWithRoute Proxy req = do

128− snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl

162+ snd <$> performRequestCT (Proxy :: Proxy ct) method req

129 where method = reflectMethod (Proxy :: Proxy method)

163 where method = reflectMethod (Proxy :: Proxy method)

130

164

131instance OVERLAPPING_

165instance OVERLAPPING_

132 (ReflectMethod method) => HasClient (Verb method status cts NoContent) where

166 (ReflectMethod method) => HasClient (Verb method status cts NoContent) where

133 type Client (Verb method status cts NoContent)

167 type Client (Verb method status cts NoContent)

134− = Manager -> BaseUrl -> ClientM NoContent

168+ = ClientM NoContent

135− clientWithRoute Proxy req manager baseurl =

169+ clientWithRoute Proxy req = do

136− performRequestNoBody method req manager baseurl >> return NoContent

170+ performRequestNoBody method req >> return NoContent

137 where method = reflectMethod (Proxy :: Proxy method)

171 where method = reflectMethod (Proxy :: Proxy method)

138

172

139instance OVERLAPPING_

173instance OVERLAPPING_

@@ -141,10 +175,10 @@ instance OVERLAPPING_

141 ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)

175 ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)

142 ) => HasClient (Verb method status cts' (Headers ls a)) where

176 ) => HasClient (Verb method status cts' (Headers ls a)) where

143 type Client (Verb method status cts' (Headers ls a))

177 type Client (Verb method status cts' (Headers ls a))

144− = Manager -> BaseUrl -> ClientM (Headers ls a)

178+ = ClientM (Headers ls a)

145− clientWithRoute Proxy req manager baseurl = do

179+ clientWithRoute Proxy req = do

146 let method = reflectMethod (Proxy :: Proxy method)

180 let method = reflectMethod (Proxy :: Proxy method)

147− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl

181+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req

148 return $ Headers { getResponse = resp

182 return $ Headers { getResponse = resp

149 , getHeadersHList = buildHeadersTo hdrs

183 , getHeadersHList = buildHeadersTo hdrs

150 }

184 }

@@ -153,10 +187,10 @@ instance OVERLAPPING_

153 ( BuildHeadersTo ls, ReflectMethod method

187 ( BuildHeadersTo ls, ReflectMethod method

154 ) => HasClient (Verb method status cts (Headers ls NoContent)) where

188 ) => HasClient (Verb method status cts (Headers ls NoContent)) where

155 type Client (Verb method status cts (Headers ls NoContent))

189 type Client (Verb method status cts (Headers ls NoContent))

156− = Manager -> BaseUrl -> ClientM (Headers ls NoContent)

190+ = ClientM (Headers ls NoContent)

157− clientWithRoute Proxy req manager baseurl = do

191+ clientWithRoute Proxy req = do

158 let method = reflectMethod (Proxy :: Proxy method)

192 let method = reflectMethod (Proxy :: Proxy method)

159− hdrs <- performRequestNoBody method req manager baseurl

193+ hdrs <- performRequestNoBody method req

160 return $ Headers { getResponse = NoContent

194 return $ Headers { getResponse = NoContent

161 , getHeadersHList = buildHeadersTo hdrs

195 , getHeadersHList = buildHeadersTo hdrs

162 }

196 }

@@ -341,7 +375,7 @@ instance (KnownSymbol sym, HasClient api)

341-- back the full `Response`.

375-- back the full `Response`.

342instance HasClient Raw where

376instance HasClient Raw where

343 type Client Raw

377 type Client Raw

344− = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)

378+ = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)

345

379

346 clientWithRoute :: Proxy Raw -> Req -> Client Raw

380 clientWithRoute :: Proxy Raw -> Req -> Client Raw

347 clientWithRoute Proxy req httpMethod = do

381 clientWithRoute Proxy req httpMethod = do

servant-client/src/Servant/Common/Req.hs+62−29

@@ -1,7 +1,9 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5

7

6#if MIN_VERSION_base(4,9,0)

8#if MIN_VERSION_base(4,9,0)

7{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

9{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

@@ -15,14 +17,25 @@ import Control.Applicative

15import Control.Exception

17import Control.Exception

16import Control.Monad

18import Control.Monad

17import Control.Monad.Catch (MonadThrow)

19import Control.Monad.Catch (MonadThrow)

20+

21+#if MIN_VERSION_mtl(2,2,0)

22+import Control.Monad.Except (MonadError(..))

23+#else

18−import Control.Monad.IO.Class

24+import Control.Monad.Error.Class (MonadError(..))

25+#endif

19import Control.Monad.Trans.Except

26import Control.Monad.Trans.Except

27+

28+

29+import GHC.Generics

30+import Control.Monad.IO.Class ()

31+import Control.Monad.Reader

20import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)

32import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)

21import Data.String

33import Data.String

22import Data.String.Conversions

34import Data.String.Conversions

23import Data.Proxy

35import Data.Proxy

24import Data.Text (Text)

36import Data.Text (Text)

25import Data.Text.Encoding

37import Data.Text.Encoding

38+import Data.Typeable

26import Network.HTTP.Client hiding (Proxy, path)

39import Network.HTTP.Client hiding (Proxy, path)

27import Network.HTTP.Media

40import Network.HTTP.Media

28import Network.HTTP.Types

41import Network.HTTP.Types

@@ -68,7 +81,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }

68

81

69reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

82reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

70reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

83reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

71− setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url

84+ setheaders . setAccept . setrqb . setQS <$> parseRequest url

72

85

73 where url = show $ nullURI { uriScheme = case reqScheme of

86 where url = show $ nullURI { uriScheme = case reqScheme of

74 Http -> "http:"

87 Http -> "http:"

@@ -94,8 +107,18 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

94 | not . null . reqAccept $ req] }

107 | not . null . reqAccept $ req] }

95 toProperHeader (name, val) =

108 toProperHeader (name, val) =

96 (fromString name, encodeUtf8 val)

109 (fromString name, encodeUtf8 val)

110+

97#if !MIN_VERSION_http_client(0,4,30)

111#if !MIN_VERSION_http_client(0,4,30)

98− parseUrlThrow = parseUrl

112+-- 'parseRequest' is introduced in http-client-0.4.30

113+-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses

114+--

115+-- See for implementations:

116+-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest

117+-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest

118+parseRequest :: MonadThrow m => String -> m Request

119+parseRequest url = liftM disableStatusCheck (parseUrl url)

120+ where

121+ disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }

99#endif

122#endif

100

123

101

124

@@ -104,21 +127,40 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

104displayHttpRequest :: Method -> String

127displayHttpRequest :: Method -> String

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

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

106

129

107−type ClientM = ExceptT ServantError IO

130+data ClientEnv

131+ = ClientEnv

132+ { manager :: Manager

133+ , baseUrl :: BaseUrl

134+ }

135+

108

136

137+-- | @ClientM@ is the monad in which client functions run. Contains the

138+-- 'Manager' and 'BaseUrl' used for requests in the reader environment.

139+

140+newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

141+ deriving ( Functor, Applicative, Monad, MonadIO, Generic

142+ , MonadReader ClientEnv

143+ , MonadError ServantError

144+ )

145+

146+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

147+runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm

148+

149+

109−performRequest :: Method -> Req -> Manager -> BaseUrl

150+performRequest :: Method -> Req

110 -> ClientM ( Int, ByteString, MediaType

151 -> ClientM ( Int, ByteString, MediaType

111 , [HTTP.Header], Response ByteString)

152 , [HTTP.Header], Response ByteString)

112−performRequest reqMethod req manager reqHost = do

153+performRequest reqMethod req = do

154+ m <- asks manager

155+ reqHost <- asks baseUrl

113 partialRequest <- liftIO $ reqToRequest req reqHost

156 partialRequest <- liftIO $ reqToRequest req reqHost

114

157

115− let request = disableStatusCheck $

116− partialRequest { Client.method = reqMethod }

158+ let request = partialRequest { Client.method = reqMethod }

117

159

118− eResponse <- liftIO $ performHttpRequest manager request

160+ eResponse <- liftIO $ performHttpRequest m request

119 case eResponse of

161 case eResponse of

120 Left err ->

162 Left err ->

121− throwE . ConnectionError $ SomeException err

163+ throwError . ConnectionError $ SomeException err

122

164

123 Right response -> do

165 Right response -> do

124 let status = Client.responseStatus response

166 let status = Client.responseStatus response

@@ -128,33 +170,24 @@ performRequest reqMethod req manager reqHost = do

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

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

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

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

130 Just t -> case parseAccept t of

172 Just t -> case parseAccept t of

131− Nothing -> throwE $ InvalidContentTypeHeader (cs t) body

173+ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body

132 Just t' -> pure t'

174 Just t' -> pure t'

133 unless (status_code >= 200 && status_code < 300) $

175 unless (status_code >= 200 && status_code < 300) $

134− throwE $ FailureResponse status ct body

176+ throwError $ FailureResponse status ct body

135 return (status_code, body, ct, hdrs, response)

177 return (status_code, body, ct, hdrs, response)

136

178

137−disableStatusCheck :: Request -> Request

138−#if MIN_VERSION_http_client(0,5,0)

139−disableStatusCheck req = req { checkResponse = \ _req _res -> return () }

140−#else

141−disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }

142−#endif

143−

144−performRequestCT :: MimeUnrender ct result =>

179+performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req

145− Proxy ct -> Method -> Req -> Manager -> BaseUrl

146 -> ClientM ([HTTP.Header], result)

180 -> ClientM ([HTTP.Header], result)

147−performRequestCT ct reqMethod req manager reqHost = do

181+performRequestCT ct reqMethod req = do

148 let acceptCT = contentType ct

182 let acceptCT = contentType ct

149 (_status, respBody, respCT, hdrs, _response) <-

183 (_status, respBody, respCT, hdrs, _response) <-

150− performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost

184+ performRequest reqMethod (req { reqAccept = [acceptCT] })

151− unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody

185+ unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody

152 case mimeUnrender ct respBody of

186 case mimeUnrender ct respBody of

153− Left err -> throwE $ DecodeFailure err respCT respBody

187+ Left err -> throwError $ DecodeFailure err respCT respBody

154 Right val -> return (hdrs, val)

188 Right val -> return (hdrs, val)

155

189

156−performRequestNoBody :: Method -> Req -> Manager -> BaseUrl

190+performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]

157− -> ClientM [HTTP.Header]

158−performRequestNoBody reqMethod req manager reqHost = do

191+performRequestNoBody reqMethod req = do

159− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost

192+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req

160 return hdrs

193 return hdrs

servant-client/test/Servant/ClientSpec.hs+52−53

@@ -26,14 +26,13 @@ import Prelude ()

26import Prelude.Compat

27

28import Control.Arrow (left)

29−import Control.Monad.Trans.Except (runExceptT, throwE)

29+import Control.Monad.Trans.Except (throwE )

30import Data.Aeson

31import qualified Data.ByteString.Lazy as BS

32import Data.Char (chr, isPrint)

33import Data.Foldable (forM_)

34import Data.Monoid hiding (getLast)

35import Data.Proxy

36−import qualified Data.Text as T

37import GHC.Generics (Generic)

36import GHC.Generics (Generic)

38import qualified Network.HTTP.Client as C

37import qualified Network.HTTP.Client as C

39import Network.HTTP.Media

38import Network.HTTP.Media

@@ -46,10 +45,12 @@ import Test.HUnit

46import Test.Hspec

45import Test.Hspec

47import Test.Hspec.QuickCheck

46import Test.Hspec.QuickCheck

48import Test.QuickCheck

47import Test.QuickCheck

48+import Web.FormUrlEncoded (FromForm, ToForm)

49

50import Servant.API

51import Servant.Client

52import Servant.Client.TestServer

53+import Servant.Client.TestServer.GHC

53import qualified Servant.Common.Req as SCR

54import qualified Servant.Common.Req as SCR

54import Servant.Server

55import Servant.Server

55import Servant.Server.Experimental.Auth

56import Servant.Server.Experimental.Auth

@@ -117,19 +118,8 @@ data Person = Person {

117instance ToJSON Person

118instance ToJSON Person

118instance FromJSON Person

119instance FromJSON Person

119

120

120−instance ToFormUrlEncoded Person where

121+instance ToForm Person where

121− toFormUrlEncoded Person{..} =

122− [("name", T.pack name), ("age", T.pack (show age))]

123−

124−lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b

125−lookupEither x xs = do

126− maybe (Left $ "could not find key " <> show x) return $ lookup x xs

127−

128−instance FromFormUrlEncoded Person where

122+instance FromForm Person where

129− fromFormUrlEncoded xs = do

130− n <- lookupEither "name" xs

131− a <- lookupEither "age" xs

132− return $ Person (T.unpack n) (read $ T.unpack a)

133

123

134alice :: Person

124alice :: Person

135alice = Person "Alice" 42

125alice = Person "Alice" 42

@@ -140,6 +130,7 @@ type Api =

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

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

141 :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

131 :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

142 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

133+ :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

143 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

134 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

144 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

135 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

145 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

136 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

@@ -157,24 +148,26 @@ type Api =

157api :: Proxy Api

148api :: Proxy Api

158api = Proxy

149api = Proxy

159

150

160−getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person

151+getGet :: SCR.ClientM Person

161−getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent

152+getDeleteEmpty :: SCR.ClientM NoContent

162−getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person

153+getCapture :: String -> SCR.ClientM Person

154+getCaptureAll :: [String] -> SCR.ClientM [Person]

163−getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person

155+getBody :: Person -> SCR.ClientM Person

164−getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person

156+getQueryParam :: Maybe String -> SCR.ClientM Person

165−getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]

157+getQueryParams :: [String] -> SCR.ClientM [Person]

166−getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool

158+getQueryFlag :: Bool -> SCR.ClientM Bool

167−getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl

159+getRawSuccess :: HTTP.Method

168 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

160 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

169−getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl

161+getRawFailure :: HTTP.Method

170 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

162 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

171−getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl

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

172 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])

164 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])

173−getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)

165+getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)

174−getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent

166+getDeleteContentType :: SCR.ClientM NoContent

175getGet

167getGet

176 :<|> getDeleteEmpty

168 :<|> getDeleteEmpty

177 :<|> getCapture

169 :<|> getCapture

170+ :<|> getCaptureAll

178 :<|> getBody

171 :<|> getBody

179 :<|> getQueryParam

172 :<|> getQueryParam

180 :<|> getQueryParams

173 :<|> getQueryParams

@@ -190,6 +183,7 @@ server = TestServer "server" $ serve api (

190 return alice

183 return alice

191 :<|> return NoContent

184 :<|> return NoContent

192 :<|> (\ name -> return $ Person name 0)

185 :<|> (\ name -> return $ Person name 0)

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

193 :<|> return

187 :<|> return

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

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

195 Just "alice" -> return alice

189 Just "alice" -> return alice

@@ -275,38 +269,42 @@ sucessSpec :: Spec

275sucessSpec = around (withTestServer "server") $ do

269sucessSpec = around (withTestServer "server") $ do

276

270

277 it "Servant.API.Get" $ \baseUrl -> do

271 it "Servant.API.Get" $ \baseUrl -> do

278− (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice

272+ (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice

279

273

280 describe "Servant.API.Delete" $ do

274 describe "Servant.API.Delete" $ do

281 it "allows empty content type" $ \baseUrl -> do

275 it "allows empty content type" $ \baseUrl -> do

282− (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent

276+ (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent

283

277

284 it "allows content type" $ \baseUrl -> do

278 it "allows content type" $ \baseUrl -> do

285− (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent

279+ (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent

286

280

287 it "Servant.API.Capture" $ \baseUrl -> do

281 it "Servant.API.Capture" $ \baseUrl -> do

288− (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)

282+ (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)

283+

284+ it "Servant.API.CaptureAll" $ \baseUrl -> do

285+ let expected = [(Person "Paula" 0), (Person "Peta" 1)]

286+ (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected

289

287

290 it "Servant.API.ReqBody" $ \baseUrl -> do

288 it "Servant.API.ReqBody" $ \baseUrl -> do

291 let p = Person "Clara" 42

289 let p = Person "Clara" 42

292− (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p

290+ (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p

293

291

294 it "Servant.API.QueryParam" $ \baseUrl -> do

292 it "Servant.API.QueryParam" $ \baseUrl -> do

295− left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice

293+ left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice

296− Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)

294+ Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)

297 responseStatus `shouldBe` HTTP.Status 400 "bob not found"

295 responseStatus `shouldBe` HTTP.Status 400 "bob not found"

298

296

299 it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do

297 it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do

300− (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []

298+ (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []

301− (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))

299+ (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))

302 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]

300 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]

303

301

304 context "Servant.API.QueryParam.QueryFlag" $

302 context "Servant.API.QueryParam.QueryFlag" $

305 forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do

303 forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do

306− (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag

304+ (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag

307

305

308 it "Servant.API.Raw on success" $ \baseUrl -> do

306 it "Servant.API.Raw on success" $ \baseUrl -> do

309− res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)

307+ res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)

310 case res of

308 case res of

311 Left e -> assertFailure $ show e

309 Left e -> assertFailure $ show e

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

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

@@ -315,7 +313,7 @@ sucessSpec = around (withTestServer "server") $ do

315 C.responseStatus response `shouldBe` HTTP.ok200

313 C.responseStatus response `shouldBe` HTTP.ok200

316

314

317 it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do

315 it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do

318− res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)

316+ res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)

319 case res of

317 case res of

320 Right _ -> assertFailure "expected Left, but got Right"

318 Right _ -> assertFailure "expected Left, but got Right"

321 Left e -> do

319 Left e -> do

@@ -323,7 +321,7 @@ sucessSpec = around (withTestServer "server") $ do

323 Servant.Client.responseBody e `shouldBe` "rawFailure"

321 Servant.Client.responseBody e `shouldBe` "rawFailure"

324

322

325 it "Returns headers appropriately" $ \baseUrl -> do

323 it "Returns headers appropriately" $ \baseUrl -> do

326− res <- runExceptT (getRespHeaders manager baseUrl)

324+ res <- runClientM getRespHeaders (ClientEnv manager baseUrl)

327 case res of

325 case res of

328 Left e -> assertFailure $ show e

326 Left e -> assertFailure $ show e

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

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

@@ -332,7 +330,7 @@ sucessSpec = around (withTestServer "server") $ do

332 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->

330 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->

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

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

334 ioProperty $ do

332 ioProperty $ do

335− result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)

333+ result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)

336 return $

334 return $

337 result === Right (cap, num, flag, body)

335 result === Right (cap, num, flag, body)

338

336

@@ -358,9 +356,9 @@ errorSpec =

358 it "reports error statuses correctly" $ \baseUrl -> do

356 it "reports error statuses correctly" $ \baseUrl -> do

359 let delete :<|> get :<|> post :<|> put =

357 let delete :<|> get :<|> post :<|> put =

360 client errorApi

358 client errorApi

361− actions = map (\ f -> f manager baseUrl) [delete, get, post, put]

359+ actions = [delete, get, post, put]

362 forM_ actions $ \ clientAction -> do

360 forM_ actions $ \ clientAction -> do

363− Left FailureResponse{..} <- runExceptT clientAction

361+ Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)

364 responseStatus `shouldBe` HTTP.Status 500 "error message"

362 responseStatus `shouldBe` HTTP.Status 500 "error message"

365

363

366basicAuthSpec :: Spec

364basicAuthSpec :: Spec

@@ -370,14 +368,14 @@ basicAuthSpec = around (withTestServer "basicAuthServer") $ do

370 it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do

368 it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do

371 let getBasic = client basicAuthAPI

369 let getBasic = client basicAuthAPI

372 let basicAuthData = BasicAuthData "servant" "server"

370 let basicAuthData = BasicAuthData "servant" "server"

373− (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice

371+ (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice

374

372

375 context "Authentication is rejected when requests are not authenticated properly" $ do

373 context "Authentication is rejected when requests are not authenticated properly" $ do

376

374

377 it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do

375 it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do

378 let getBasic = client basicAuthAPI

376 let getBasic = client basicAuthAPI

379 let basicAuthData = BasicAuthData "not" "password"

377 let basicAuthData = BasicAuthData "not" "password"

380− Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)

378+ Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)

381 responseStatus `shouldBe` HTTP.Status 403 "Forbidden"

379 responseStatus `shouldBe` HTTP.Status 403 "Forbidden"

382

380

383genAuthSpec :: Spec

381genAuthSpec :: Spec

@@ -387,14 +385,14 @@ genAuthSpec = around (withTestServer "genAuthServer") $ do

387 it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do

385 it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do

388 let getProtected = client genAuthAPI

386 let getProtected = client genAuthAPI

389 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)

387 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)

390− (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice

388+ (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice

391

389

392 context "Authentication is rejected when requests are not authenticated properly" $ do

390 context "Authentication is rejected when requests are not authenticated properly" $ do

393

391

394 it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do

392 it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do

395 let getProtected = client genAuthAPI

393 let getProtected = client genAuthAPI

396 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

394 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

397− Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)

395+ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)

398 responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")

396 responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")

399

397

400failSpec :: Spec

398failSpec :: Spec

@@ -403,35 +401,36 @@ failSpec = around (withTestServer "failServer") $ do

403 context "client returns errors appropriately" $ do

401 context "client returns errors appropriately" $ do

404 it "reports FailureResponse" $ \baseUrl -> do

402 it "reports FailureResponse" $ \baseUrl -> do

405 let (_ :<|> getDeleteEmpty :<|> _) = client api

403 let (_ :<|> getDeleteEmpty :<|> _) = client api

406− Left res <- runExceptT (getDeleteEmpty manager baseUrl)

404+ Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)

407 case res of

405 case res of

408 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()

406 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()

409 _ -> fail $ "expected 404 response, but got " <> show res

407 _ -> fail $ "expected 404 response, but got " <> show res

410

408

411 it "reports DecodeFailure" $ \baseUrl -> do

409 it "reports DecodeFailure" $ \baseUrl -> do

412 let (_ :<|> _ :<|> getCapture :<|> _) = client api

410 let (_ :<|> _ :<|> getCapture :<|> _) = client api

413− Left res <- runExceptT (getCapture "foo" manager baseUrl)

411+ Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)

414 case res of

412 case res of

415 DecodeFailure _ ("application/json") _ -> return ()

413 DecodeFailure _ ("application/json") _ -> return ()

416 _ -> fail $ "expected DecodeFailure, but got " <> show res

414 _ -> fail $ "expected DecodeFailure, but got " <> show res

417

415

418 it "reports ConnectionError" $ \_ -> do

416 it "reports ConnectionError" $ \_ -> do

419 let (getGetWrongHost :<|> _) = client api

417 let (getGetWrongHost :<|> _) = client api

420− Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))

418+ Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))

421 case res of

419 case res of

422 ConnectionError _ -> return ()

420 ConnectionError _ -> return ()

423 _ -> fail $ "expected ConnectionError, but got " <> show res

421 _ -> fail $ "expected ConnectionError, but got " <> show res

424

422

425 it "reports UnsupportedContentType" $ \baseUrl -> do

423 it "reports UnsupportedContentType" $ \baseUrl -> do

426 let (getGet :<|> _ ) = client api

424 let (getGet :<|> _ ) = client api

427− Left res <- runExceptT (getGet manager baseUrl)

425+ Left res <- runClientM getGet (ClientEnv manager baseUrl)

428 case res of

426 case res of

429 UnsupportedContentType ("application/octet-stream") _ -> return ()

427 UnsupportedContentType ("application/octet-stream") _ -> return ()

430 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

428 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

431

429

432 it "reports InvalidContentTypeHeader" $ \baseUrl -> do

430 it "reports InvalidContentTypeHeader" $ \baseUrl -> do

433− let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

431+ let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

434− Left res <- runExceptT (getBody alice manager baseUrl)

432+ Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)

433+

435 case res of

434 case res of

436 InvalidContentTypeHeader "fooooo" _ -> return ()

435 InvalidContentTypeHeader "fooooo" _ -> return ()

437 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

436 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

servant-docs/servant-docs.cabal+2−4

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

1name: servant-docs

2−version: 0.8

2+version: 0.9

3synopsis: generate API docs for your servant webservice

4description:

5 Library for generating API docs from a servant API definition.

@@ -36,13 +36,12 @@ library

36 , aeson

37 , aeson-pretty

38 , bytestring

39− , bytestring-conversion

40 , case-insensitive

39 , case-insensitive

41 , hashable

40 , hashable

42 , http-media >= 0.6

41 , http-media >= 0.6

43 , http-types >= 0.7

42 , http-types >= 0.7

44 , lens

43 , lens

45− , servant == 0.8.*

44+ , servant == 0.9.*

46 , string-conversions

45 , string-conversions

47 , text

46 , text

48 , unordered-containers

47 , unordered-containers

@@ -61,7 +60,6 @@ executable greet-docs

61 build-depends:

60 build-depends:

62 base

61 base

63 , aeson

62 , aeson

64− , bytestring-conversion

65 , lens

63 , lens

66 , servant

64 , servant

67 , servant-docs

65 , servant-docs

servant-docs/src/Servant/Docs/Internal.hs+18−3

@@ -25,7 +25,6 @@ import Control.Arrow (second)

25import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),

26 (&), (.~), (<>~), (^.), (|>))

27import qualified Control.Monad.Omega as Omega

28−import Data.ByteString.Conversion (ToByteString, toByteString)

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

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

30import qualified Data.ByteString.Char8 as BSC

29import qualified Data.ByteString.Char8 as BSC

31import qualified Data.CaseInsensitive as CI

30import qualified Data.CaseInsensitive as CI

@@ -461,12 +460,12 @@ class AllHeaderSamples ls where

461instance AllHeaderSamples '[] where

460instance AllHeaderSamples '[] where

462 allHeaderToSample _ = []

461 allHeaderToSample _ = []

463

462

464−instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)

463+instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)

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

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

466 allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :

465 allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :

467 allHeaderToSample (Proxy :: Proxy ls)

466 allHeaderToSample (Proxy :: Proxy ls)

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

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

469− mkHeader (Just x) = (headerName, cs $ toByteString x)

468+ mkHeader (Just x) = (headerName, cs $ toHeader x)

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

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

471

470

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

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

@@ -702,6 +701,22 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

702 symP = Proxy :: Proxy sym

701 symP = Proxy :: Proxy sym

703

702

704

703

704+-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

705+-- @/books/:isbn@ in the docs.

706+instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)

707+ => HasDocs (CaptureAll sym a :> sublayout) where

708+

709+ docsFor Proxy (endpoint, action) =

710+ docsFor sublayoutP (endpoint', action')

711+

712+ where sublayoutP = Proxy :: Proxy sublayout

713+ captureP = Proxy :: Proxy (CaptureAll sym a)

714+

715+ action' = over captures (|> toCapture captureP) action

716+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

717+ symP = Proxy :: Proxy sym

718+

719+

705instance OVERLAPPABLE_

720instance OVERLAPPABLE_

706 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

721 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

707 , ReflectMethod method)

722 , ReflectMethod method)

servant-docs/test/Servant/DocsSpec.hs+2

@@ -34,6 +34,8 @@ instance ToParam (QueryFlag "foo") where

34 toParam = error "unused"

35instance ToCapture (Capture "foo" Int) where

36 toCapture = error "unused"

37+instance ToCapture (CaptureAll "foo" Int) where

38+ toCapture = error "unused"

37

39

38-- * specs

40-- * specs

39

41

servant-foreign/servant-foreign.cabal+2−2

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

1name: servant-foreign

2−version: 0.8

2+version: 0.9

3synopsis: Helpers for generating clients for servant APIs in any programming language

4description:

5 Helper types and functions for generating client functions for servant APIs in any programming language

@@ -32,7 +32,7 @@ library

32 , Servant.Foreign.Inflections

33 build-depends: base == 4.*

34 , lens == 4.*

35− , servant == 0.8.*

35+ , servant == 0.9.*

36 , text >= 1.2 && < 1.3

37 , http-types

38 hs-source-dirs: src

servant-foreign/src/Servant/Foreign/Internal.hs+15

@@ -211,6 +211,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype ap

211 { _argName = PathSegment str

212 , _argType = ftype }

213

214+instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)

215+ => HasForeign lang ftype (CaptureAll sym t :> sublayout) where

216+ type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout

217+

218+ foreignFor lang Proxy Proxy req =

219+ foreignFor lang Proxy (Proxy :: Proxy sublayout) $

220+ req & reqUrl . path <>~ [Segment (Cap arg)]

221+ & reqFuncName . _FunctionName %~ (++ ["by", str])

222+ where

223+ str = pack . symbolVal $ (Proxy :: Proxy sym)

224+ ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])

225+ arg = Arg

226+ { _argName = PathSegment str

227+ , _argType = ftype }

228+

214instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

229instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

215 => HasForeign lang ftype (Verb method status list a) where

230 => HasForeign lang ftype (Verb method status list a) where

216 type Foreign ftype (Verb method status list a) = Req ftype

231 type Foreign ftype (Verb method status list a) = Req ftype

servant-foreign/test/Servant/ForeignSpec.hs+16−2

@@ -46,6 +46,7 @@ type TestApi

46 :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent

47 :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent

48 :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent

49+ :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]

49

50

50testApi :: [Req String]

51testApi :: [Req String]

51testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)

52testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)

@@ -53,9 +54,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P

53listFromAPISpec :: Spec

54listFromAPISpec :: Spec

54listFromAPISpec = describe "listFromAPI" $ do

55listFromAPISpec = describe "listFromAPI" $ do

55 it "generates 4 endpoints for TestApi" $ do

56 it "generates 4 endpoints for TestApi" $ do

56− length testApi `shouldBe` 4

57+ length testApi `shouldBe` 5

57

58

58− let [getReq, postReq, putReq, deleteReq] = testApi

59+ let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi

59

60

60 it "collects all info for get request" $ do

61 it "collects all info for get request" $ do

61 shouldBe getReq $ defReq

62 shouldBe getReq $ defReq

@@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do

106 , _reqReturnType = Just "voidX"

107 , _reqReturnType = Just "voidX"

107 , _reqFuncName = FunctionName ["delete", "test", "by", "id"]

108 , _reqFuncName = FunctionName ["delete", "test", "by", "id"]

108 }

109 }

110+

111+ it "collects all info for capture all request" $ do

112+ shouldBe captureAllReq $ defReq

113+ { _reqUrl = Url

114+ [ Segment $ Static "test"

115+ , Segment $ Cap (Arg "ids" "listX of intX") ]

116+ []

117+ , _reqMethod = "GET"

118+ , _reqHeaders = []

119+ , _reqBody = Nothing

120+ , _reqReturnType = Just "listX of intX"

121+ , _reqFuncName = FunctionName ["get", "test", "by", "ids"]

122+ }

servant-js/README.md+2−2

@@ -78,8 +78,8 @@ server counter = counterPlusOne counter -- (+1) on the TVar

78 :<|> currentValue counter -- read the TVar

79

80server' :: TVar Counter -> Server TestApi'

81−server counter = server counter

81+server' counter = server counter

82− :<|> serveDirectory www -- serve static files

82+ :<|> serveDirectory www -- serve static files

83

84runServer :: TVar Counter -- ^ shared variable for the counter

85 -> Int -- ^ port the server should listen on

servant-js/examples/counter.hs+2−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5

6

6import Control.Concurrent.STM

7import Control.Concurrent.STM

@@ -92,7 +93,7 @@ main = do

92

93

93 writeJSForAPI testApi (angular defAngularOptions) (www </> "angular" </> "api.js")

94 writeJSForAPI testApi (angular defAngularOptions) (www </> "angular" </> "api.js")

94

95

95− writeJSForAPI testApi axios (www </> "axios" </> "api.js")

96+ writeJSForAPI testApi (axios defAxiosOptions) (www </> "axios" </> "api.js")

96

97

97 writeServiceJS (www </> "angular" </> "api.service.js")

98 writeServiceJS (www </> "angular" </> "api.service.js")

98

99

servant-js/servant-js.cabal+6−6

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

1name: servant-js

2−version: 0.8

2+version: 0.9

3synopsis: Automatically derive javascript functions to query servant webservices.

4description:

5 Automatically derive javascript functions to query servant webservices.

@@ -45,8 +45,8 @@ library

45 , base-compat >= 0.9

46 , charset >= 0.3

47 , lens >= 4

48− , servant-foreign == 0.8.*

48+ , servant-foreign == 0.9.*

49− , servant == 0.8.*

49+ , servant == 0.9.*

50 , text >= 1.2 && < 1.3

51

52 hs-source-dirs: src

@@ -65,11 +65,11 @@ executable counter

65 buildable: False

66

67 build-depends: base >= 4.7 && < 5

68− , aeson >= 0.7 && < 0.12

68+ , aeson >= 0.7 && < 1.1

69 , filepath >= 1

70 , lens >= 4

71− , servant == 0.8.*

71+ , servant == 0.9.*

72− , servant-server == 0.8.*

72+ , servant-server == 0.9.*

73 , servant-js

74 , stm

75 , transformers

servant-js/src/Servant/JS.hs+1

@@ -112,6 +112,7 @@ module Servant.JS

112 , javascript

113 , NoTypes

114 , GenerateList(..)

115+ , FunctionName(..)

115 ) where

116 ) where

116

117

117import Prelude hiding (writeFile)

118import Prelude hiding (writeFile)

servant-js/test/Servant/JSSpec.hs+1−1

@@ -33,7 +33,7 @@ import Servant.JSSpec.CustomHeaders

33-- * comprehensive api

34

35-- This declaration simply checks that all instances are in place.

36−_ = jsForAPI comprehensiveAPI vanillaJS :: Text

36+_ = jsForAPI comprehensiveAPIWithoutRaw vanillaJS :: Text

37

38-- * specs

39

servant-mock/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude

servant-mock/LICENSEdeleted−30

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

2−

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Alp Mestanogullari nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-mock/Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

servant-mock/example/main.hsdeleted−26

@@ -1,26 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE TypeOperators #-}

5−

6−{-# OPTIONS_GHC -fno-warn-unused-binds #-}

7−

8−import Data.Aeson

9−import GHC.Generics

10−import Network.Wai.Handler.Warp

11−import Servant

12−import Servant.Mock

13−import Test.QuickCheck.Arbitrary

14−

15−newtype User = User { username :: String }

16− deriving (Eq, Show, Arbitrary, Generic)

17−

18−instance ToJSON User

19−

20−type API = "user" :> Get '[JSON] User

21−

22−api :: Proxy API

23−api = Proxy

24−

25−main :: IO ()

26−main = run 8080 (serve api $ mock api Proxy)

servant-mock/include/overlapping-compat.hdeleted−8

@@ -1,8 +0,0 @@

1−#if __GLASGOW_HASKELL__ >= 710

2−#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}

3−#define OVERLAPPING_ {-# OVERLAPPING #-}

4−#else

5−{-# LANGUAGE OverlappingInstances #-}

6−#define OVERLAPPABLE_

7−#define OVERLAPPING_

8−#endif

servant-mock/servant-mock.cabaldeleted−73

@@ -1,73 +0,0 @@

1−name: servant-mock

2−version: 0.8

3−synopsis: Derive a mock server for free from your servant API types

4−description:

5− Derive a mock server for free from your servant API types

6− .

7− See the @Servant.Mock@ module for the documentation and an example.

8−homepage: http://github.com/haskell-servant/servant

9−license: BSD3

10−license-file: LICENSE

11−author: Servant Contributors

12−maintainer: haskell-servant-maintainers@googlegroups.com

13−copyright: 2015-2016 Servant Contributors

14−category: Web

15−build-type: Simple

16−extra-source-files: include/*.h

17−cabal-version: >=1.10

18−bug-reports: http://github.com/haskell-servant/servant/issues

19−source-repository head

20− type: git

21− location: http://github.com/haskell-servant/servant.git

22−

23−flag example

24− description: Build the example too

25− default: True

26−

27−library

28− exposed-modules:

29− Servant.Mock

30− build-depends:

31− base >=4.7 && <5,

32− bytestring >= 0.10 && <0.11,

33− http-types >= 0.8 && <0.10,

34− servant == 0.8.*,

35− servant-server == 0.8.*,

36− transformers >= 0.3 && <0.6,

37− QuickCheck >= 2.7 && <2.9,

38− wai >= 3.0 && <3.3

39− hs-source-dirs: src

40− default-language: Haskell2010

41− include-dirs: include

42− ghc-options: -Wall

43−

44−executable mock-app

45− main-is: main.hs

46− hs-source-dirs: example

47− default-language: Haskell2010

48− build-depends: aeson, base, servant-mock, servant-server, QuickCheck, warp

49− if flag(example)

50− buildable: True

51− else

52− buildable: False

53− ghc-options: -Wall

54−

55−test-suite spec

56− type: exitcode-stdio-1.0

57− ghc-options: -Wall

58− default-language: Haskell2010

59− hs-source-dirs: test

60− main-is: Spec.hs

61− other-modules:

62− Servant.MockSpec

63− build-depends:

64− base,

65− hspec,

66− hspec-wai,

67− QuickCheck,

68− servant,

69− servant-server,

70− servant-mock,

71− aeson,

72− bytestring-conversion,

73− wai

servant-mock/src/Servant/Mock.hsdeleted−185

@@ -1,185 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

10−{-# OPTIONS_GHC -fno-warn-orphans #-}

11−

12−#include "overlapping-compat.h"

13−

14−-- |

15−-- Module : Servant.Mock

16−-- Copyright : 2015 Alp Mestanogullari

17−-- License : BSD3

18−--

19−-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>

20−-- Stability : experimental

21−-- Portability : portable

22−--

23−-- Automatically derive a mock webserver that implements some API type,

24−-- just from the said API type's definition.

25−--

26−-- Using this module couldn't be simpler. Given some API type, like:

27−--

28−-- > type API = "user" :> Get '[JSON] User

29−--

30−-- that describes your web application, all you have to do is define

31−-- a 'Proxy' to it:

32−--

33−-- > myAPI :: Proxy API

34−-- > myAPI = Proxy

35−--

36−-- and call 'mock', which has the following type:

37−--

38−-- @

39−-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api

40−-- @

41−--

42−-- What this says is, given some API type @api@ that it knows it can

43−-- "mock", 'mock' hands you an implementation of the API type. It does so

44−-- by having each request handler generate a random value of the

45−-- appropriate type (@User@ in our case). All you need for this to work is

46−-- to provide 'Arbitrary' instances for the data types returned as response

47−-- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'.

48−--

49−-- To put this all to work and run the mock server, just call 'serve' on the

50−-- result of 'mock' to get an 'Application' that you can then run with warp.

51−--

52−-- @

53−-- main :: IO ()

54−-- main = Network.Wai.Handler.Warp.run 8080 $

55−-- 'serve' myAPI ('mock' myAPI Proxy)

56−-- @

57−module Servant.Mock ( HasMock(..) ) where

58−

59−#if !MIN_VERSION_base(4,8,0)

60−import Control.Applicative

61−#endif

62−import Control.Monad.IO.Class

63−import Data.ByteString.Lazy.Char8 (pack)

64−import Data.Proxy

65−import GHC.TypeLits

66−import Network.HTTP.Types.Status

67−import Network.Wai

68−import Servant

69−import Servant.API.ContentTypes

70−import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)

71−import Test.QuickCheck.Gen (Gen, generate)

72−

73−-- | 'HasMock' defines an interpretation of API types

74−-- than turns them into random-response-generating

75−-- request handlers, hence providing an instance for

76−-- all the combinators of the core /servant/ library.

77−class HasServer api context => HasMock api context where

78− -- | Calling this method creates request handlers of

79− -- the right type to implement the API described by

80− -- @api@ that just generate random response values of

81− -- the right type. E.g:

82− --

83− -- @

84− -- type API = "user" :> Get '[JSON] User

85− -- :<|> "book" :> Get '[JSON] Book

86− --

87− -- api :: Proxy API

88− -- api = Proxy

89− --

90− -- -- let's say we will start with the frontend,

91− -- -- and hence need a placeholder server

92− -- server :: Server API

93− -- server = mock api Proxy

94− -- @

95− --

96− -- What happens here is that @'Server' API@

97− -- actually "means" 2 request handlers, of the following types:

98− --

99− -- @

100− -- getUser :: Handler User

101− -- getBook :: Handler Book

102− -- @

103− --

104− -- So under the hood, 'mock' uses the 'IO' bit to generate

105− -- random values of type 'User' and 'Book' every time these

106− -- endpoints are requested.

107− mock :: Proxy api -> Proxy context -> Server api

108−

109−instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where

110− mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context

111−

112−instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where

113− mock _ = mock (Proxy :: Proxy rest)

114−

115−instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where

116− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

117−

118−instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where

119− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

120−

121−instance HasMock rest context => HasMock (RemoteHost :> rest) context where

122− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

123−

124−instance HasMock rest context => HasMock (IsSecure :> rest) context where

125− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

126−

127−instance HasMock rest context => HasMock (Vault :> rest) context where

128− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

129−

130−instance HasMock rest context => HasMock (HttpVersion :> rest) context where

131− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

132−

133−instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)

134− => HasMock (QueryParam s a :> rest) context where

135− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

136−

137−instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)

138− => HasMock (QueryParams s a :> rest) context where

139− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

140−

141−instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where

142− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

143−

144−instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where

145− mock _ context = \_ -> mock (Proxy :: Proxy rest) context

146−

147−instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)

148− => HasMock (Verb method status ctypes a) context where

149− mock _ _ = mockArbitrary

150−

151−instance OVERLAPPING_

152− (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),

153− Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)

154− => HasMock (Verb method status ctypes (Headers headerTypes a)) context where

155− mock _ _ = mockArbitrary

156−

157−instance HasMock Raw context where

158− mock _ _ = \_req respond -> do

159− bdy <- genBody

160− respond $ responseLBS status200 [] bdy

161−

162− where genBody = pack <$> generate (vector 100 :: Gen [Char])

163−

164−instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) =>

165− HasMock (WithNamedContext name subContext rest) context where

166−

167− mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext)

168−

169−mockArbitrary :: (MonadIO m, Arbitrary a) => m a

170−mockArbitrary = liftIO (generate arbitrary)

171−

172−-- utility instance

173−instance (Arbitrary (HList ls), Arbitrary a)

174− => Arbitrary (Headers ls a) where

175− arbitrary = Headers <$> arbitrary <*> arbitrary

176−

177−instance Arbitrary (HList '[]) where

178− arbitrary = pure HNil

179−

180−instance (Arbitrary a, Arbitrary (HList hs))

181− => Arbitrary (HList (Header h a ': hs)) where

182− arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary

183−

184−instance Arbitrary NoContent where

185− arbitrary = pure NoContent

servant-mock/test/Servant/MockSpec.hsdeleted−85

@@ -1,85 +0,0 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Servant.MockSpec where

9−

10−import Data.Aeson as Aeson

11−import Data.ByteString.Conversion.To

12−import Data.Proxy

13−import Data.String

14−import GHC.Generics

15−import Network.Wai

16−import Servant.API

17−import Test.Hspec hiding (pending)

18−import Test.Hspec.Wai

19−import Test.QuickCheck

20−

21−import Servant

22−import Servant.API.Internal.Test.ComprehensiveAPI

23−import Servant.Mock

24−

25−-- This declaration simply checks that all instances are in place.

26−_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]])

27−

28−data Body

29− = Body

30− | ArbitraryBody

31− deriving (Generic)

32−

33−instance ToJSON Body

34−

35−instance Arbitrary Body where

36− arbitrary = return ArbitraryBody

37−

38−data TestHeader

39− = TestHeader

40− | ArbitraryHeader

41− deriving (Show)

42−

43−instance ToByteString TestHeader where

44− builder = fromString . show

45−

46−instance Arbitrary TestHeader where

47− arbitrary = return ArbitraryHeader

48−

49−spec :: Spec

50−spec = do

51− describe "mock" $ do

52− context "Get" $ do

53− let api :: Proxy (Get '[JSON] Body)

54− api = Proxy

55− app = serve api (mock api Proxy)

56− with (return app) $ do

57− it "serves arbitrary response bodies" $ do

58− get "/" `shouldRespondWith` 200{

59− matchBody = Just $ Aeson.encode ArbitraryBody

60− }

61−

62− context "response headers" $ do

63− let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body))

64− withHeader = Proxy

65− withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))

66− withoutHeader = Proxy

67− toApp :: (HasMock api '[]) => Proxy api -> IO Application

68− toApp api = return $ serve api (mock api (Proxy :: Proxy '[]))

69− with (toApp withHeader) $ do

70− it "serves arbitrary response bodies" $ do

71− get "/" `shouldRespondWith` 200{

72− matchHeaders = return $ MatchHeader $ \ h ->

73− if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")]

74− then Nothing

75− else Just ("headers not correct\n")

76− }

77−

78− with (toApp withoutHeader) $ do

79− it "works for no additional headers" $ do

80− get "/" `shouldRespondWith` 200{

81− matchHeaders = return $ MatchHeader $ \ h ->

82− if h == [("Content-Type", "application/json")]

83− then Nothing

84− else Just ("headers not correct\n")

85− }

servant-mock/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-mock/tinc.yamldeleted−5

@@ -1,5 +0,0 @@

1−dependencies:

2− - name: servant

3− path: ../servant

4− - name: servant-server

5− path: ../servant-server

servant-server/servant-server.cabal+5−5

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

1name: servant-server

2−version: 0.8

2+version: 0.9

3synopsis: A family of combinators for defining webservices APIs and serving them

4description:

5 A family of combinators for defining webservices APIs and serving them

@@ -47,18 +47,18 @@ library

47 build-depends:

48 base >= 4.7 && < 4.10

49 , base-compat >= 0.9 && < 0.10

50− , aeson >= 0.7 && < 0.12

50+ , aeson >= 0.7 && < 1.1

51 , attoparsec >= 0.12 && < 0.14

52 , base64-bytestring >= 1.0 && < 1.1

53 , bytestring >= 0.10 && < 0.11

54 , containers >= 0.5 && < 0.6

55− , http-api-data >= 0.1 && < 0.3

55+ , http-api-data >= 0.3 && < 0.4

56 , http-types >= 0.8 && < 0.10

57 , network-uri >= 2.6 && < 2.7

58 , mtl >= 2 && < 2.3

59 , network >= 2.6 && < 2.7

60 , safe >= 0.3 && < 0.4

61− , servant == 0.8.*

61+ , servant == 0.9.*

62 , split >= 0.2 && < 0.3

63 , string-conversions >= 0.3 && < 0.5

64 , system-filepath >= 0.4 && < 0.5

@@ -99,6 +99,7 @@ test-suite spec

99 hs-source-dirs: test

100 main-is: Spec.hs

101 other-modules:

102+ Servant.ArbitraryMonadServerSpec

102 Servant.Server.ErrorSpec

103 Servant.Server.ErrorSpec

103 Servant.Server.Internal.ContextSpec

104 Servant.Server.Internal.ContextSpec

104 Servant.Server.RouterSpec

105 Servant.Server.RouterSpec

@@ -113,7 +114,6 @@ test-suite spec

113 , aeson

114 , aeson

114 , base64-bytestring

115 , base64-bytestring

115 , bytestring

116 , bytestring

116− , bytestring-conversion

117 , directory

118 , exceptions

119 , hspec == 2.*

servant-server/src/Servant/Server/Internal.hs+42−9

@@ -42,16 +42,16 @@ import Network.Wai (Application, Request, Response,

42 responseLBS, vault)

43import Prelude ()

44import Prelude.Compat

45−import Web.HttpApiData (FromHttpApiData)

45+import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,

46−import Web.HttpApiData.Internal (parseHeaderMaybe,

47 parseQueryParamMaybe,

46 parseQueryParamMaybe,

48− parseUrlPieceMaybe)

47+ parseUrlPieceMaybe,

49−

48+ parseUrlPieces)

50import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

49import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

50+ CaptureAll, Verb,

51− Verb, ReflectMethod(reflectMethod),

51+ ReflectMethod(reflectMethod),

52− IsSecure(..), Header,

52+ IsSecure(..), Header, QueryFlag,

53− QueryFlag, QueryParam, QueryParams,

53+ QueryParam, QueryParams, Raw,

54− Raw, RemoteHost, ReqBody, Vault,

54+ RemoteHost, ReqBody, Vault,

55 WithNamedContext)

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

57 AllCTRender (..),

@@ -128,11 +128,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

128 CaptureRouter $

129 route (Proxy :: Proxy api)

130 context

131− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of

131+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of

132 Nothing -> delayedFail err400

133 Just v -> return v

134 )

135

136+-- | If you use 'CaptureAll' in one of the endpoints for your API,

137+-- this automatically requires your server-side handler to be a

138+-- function that takes an argument of a list of the type specified by

139+-- the 'CaptureAll'. This lets servant worry about getting values from

140+-- the URL and turning them into values of the type you specify.

141+--

142+-- You can control how they'll be converted from 'Text' to your type

143+-- by simply providing an instance of 'FromHttpApiData' for your type.

144+--

145+-- Example:

146+--

147+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile

148+-- >

149+-- > server :: Server MyApi

150+-- > server = getSourceFile

151+-- > where getSourceFile :: [Text] -> Handler Book

152+-- > getSourceFile pathSegments = ...

153+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)

154+ => HasServer (CaptureAll capture a :> sublayout) context where

155+

156+ type ServerT (CaptureAll capture a :> sublayout) m =

157+ [a] -> ServerT sublayout m

158+

159+ route Proxy context d =

160+ CaptureAllRouter $

161+ route (Proxy :: Proxy sublayout)

162+ context

163+ (addCapture d $ \ txts -> case parseUrlPieces txts of

164+ Left _ -> delayedFail err400

165+ Right v -> return v

166+ )

167+

168+

136allowedMethodHead :: Method -> Request -> Bool

169allowedMethodHead :: Method -> Request -> Bool

137allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

170allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

138

171

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

@@ -31,6 +31,9 @@ data Router' env a =

31 | CaptureRouter (Router' (Text, env) a)

32 -- ^ first path component is passed to the child router in its

33 -- environment and removed afterwards

34+ | CaptureAllRouter (Router' ([Text], env) a)

35+ -- ^ all path components are passed to the child router in its

36+ -- environment and are removed afterwards

34 | RawRouter (env -> a)

37 | RawRouter (env -> a)

35 -- ^ to be used for routes we do not know anything about

38 -- ^ to be used for routes we do not know anything about

36 | Choice (Router' env a) (Router' env a)

39 | Choice (Router' env a) (Router' env a)

@@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =

90routerStructure (CaptureRouter router) =

93routerStructure (CaptureRouter router) =

91 CaptureRouterStructure $

94 CaptureRouterStructure $

92 routerStructure router

95 routerStructure router

96+routerStructure (CaptureAllRouter router) =

97+ CaptureRouterStructure $

98+ routerStructure router

93routerStructure (RawRouter _) =

99routerStructure (RawRouter _) =

94 RawRouterStructure

100 RawRouterStructure

95routerStructure (Choice r1 r2) =

101routerStructure (Choice r1 r2) =

@@ -163,6 +169,10 @@ runRouterEnv router env request respond =

163 first : rest

169 first : rest

164 -> let request' = request { pathInfo = rest }

170 -> let request' = request { pathInfo = rest }

165 in runRouterEnv router' (first, env) request' respond

171 in runRouterEnv router' (first, env) request' respond

172+ CaptureAllRouter router' ->

173+ let segments = pathInfo request

174+ request' = request { pathInfo = [] }

175+ in runRouterEnv router' (segments, env) request' respond

166 RawRouter app ->

176 RawRouter app ->

167 app env request respond

177 app env request respond

168 Choice r1 r2 ->

178 Choice r1 r2 ->

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3

@@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where

11import Control.Monad (ap, liftM)

12import Control.Monad.Trans (MonadIO(..))

13import Control.Monad.Trans.Except (runExceptT)

14−import Data.Text (Text)

15import Network.Wai (Application, Request,

14import Network.Wai (Application, Request,

16 Response, ResponseReceived)

15 Response, ResponseReceived)

17import Prelude ()

16import Prelude ()

@@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)

161

160

162-- | Add a capture to the end of the capture block.

161-- | Add a capture to the end of the capture block.

163addCapture :: Delayed env (a -> b)

162addCapture :: Delayed env (a -> b)

164− -> (Text -> DelayedIO a)

163+ -> (captured -> DelayedIO a)

165− -> Delayed (Text, env) b

164+ -> Delayed (captured, env) b

166addCapture Delayed{..} new =

165addCapture Delayed{..} new =

167 Delayed

166 Delayed

168 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

167 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

servant-server/test/Servant/ServerSpec.hs+56−2

@@ -17,7 +17,6 @@ import Control.Monad (forM_, when, unless)

17import Control.Monad.Trans.Except (throwE)

18import Data.Aeson (FromJSON, ToJSON, decode', encode)

19import qualified Data.ByteString.Base64 as Base64

20−import Data.ByteString.Conversion ()

21import Data.Char (toUpper)

20import Data.Char (toUpper)

22import Data.Monoid

21import Data.Monoid

23import Data.Proxy (Proxy (Proxy))

22import Data.Proxy (Proxy (Proxy))

@@ -39,7 +38,7 @@ import Network.Wai.Test (defaultRequest, request,

39 simpleHeaders, simpleStatus)

38 simpleHeaders, simpleStatus)

40import Servant.API ((:<|>) (..), (:>), AuthProtect,

39import Servant.API ((:<|>) (..), (:>), AuthProtect,

41 BasicAuth, BasicAuthData(BasicAuthData),

40 BasicAuth, BasicAuthData(BasicAuthData),

42− Capture, Delete, Get, Header (..),

41+ Capture, CaptureAll, Delete, Get, Header (..),

43 Headers, HttpVersion,

42 Headers, HttpVersion,

44 IsSecure (..), JSON,

43 IsSecure (..), JSON,

45 NoContent (..), Patch, PlainText,

44 NoContent (..), Patch, PlainText,

@@ -216,6 +215,58 @@ captureSpec = do

216 it "strips the captured path snippet from pathInfo" $ do

215 it "strips the captured path snippet from pathInfo" $ do

217 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

216 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

218

217

218+-- }}}

219+------------------------------------------------------------------------------

220+-- * captureAllSpec {{{

221+------------------------------------------------------------------------------

222+

223+type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal

224+captureAllApi :: Proxy CaptureAllApi

225+captureAllApi = Proxy

226+captureAllServer :: [Integer] -> Handler Animal

227+captureAllServer legs = case sum legs of

228+ 4 -> return jerry

229+ 2 -> return tweety

230+ 0 -> return beholder

231+ _ -> throwE err404

232+

233+captureAllSpec :: Spec

234+captureAllSpec = do

235+ describe "Servant.API.CaptureAll" $ do

236+ with (return (serve captureAllApi captureAllServer)) $ do

237+

238+ it "can capture a single element of the 'pathInfo'" $ do

239+ response <- get "/2"

240+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety

241+

242+ it "can capture multiple elements of the 'pathInfo'" $ do

243+ response <- get "/2/2"

244+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry

245+

246+ it "can capture arbitrarily many elements of the 'pathInfo'" $ do

247+ response <- get "/1/1/0/1/0/1"

248+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry

249+

250+ it "can capture when there are no elements in 'pathInfo'" $ do

251+ response <- get "/"

252+ liftIO $ decode' (simpleBody response) `shouldBe` Just beholder

253+

254+ it "returns 400 if the decoding fails" $ do

255+ get "/notAnInt" `shouldRespondWith` 400

256+

257+ it "returns 400 if the decoding fails, regardless of which element" $ do

258+ get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400

259+

260+ it "returns 400 if the decoding fails, even when it's multiple elements" $ do

261+ get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400

262+

263+ with (return (serve

264+ (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

265+ (\ _captured request_ respond ->

266+ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

267+ it "consumes everything from pathInfo" $ do

268+ get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

269+

219-- }}}

270-- }}}

220------------------------------------------------------------------------------

271------------------------------------------------------------------------------

221-- * queryParamSpec {{{

272-- * queryParamSpec {{{

@@ -644,4 +695,7 @@ jerry = Animal "Mouse" 4

644

695

645tweety :: Animal

696tweety :: Animal

646tweety = Animal "Bird" 2

697tweety = Animal "Bird" 2

698+

699+beholder :: Animal

700+beholder = Animal "Beholder" 0

647-- }}}

701-- }}}

servant/CHANGELOG.md+12

@@ -1,3 +1,15 @@

1+0.9

2+---

3+

4+* Added Eq, Show, Read, Generic and Ord instances to IsSecure

5+* BACKWARDS INCOMPATIBLE: replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo`

6+* BACKWARDS INCOMPATIBLE: Moved `From/ToFormUrlEncoded` classes, which were renamed to `From/ToForm` to `http-api-data`

7+

8+0.8.1

9+----

10+

11+* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL.

12+

10.8

130.8

2---

14---

3

15

servant/servant.cabal+3−4

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

1name: servant

2−version: 0.8

2+version: 0.9

3synopsis: A family of combinators for defining webservices APIs

4description:

5 A family of combinators for defining webservices APIs and serving them

@@ -51,12 +51,11 @@ library

51 build-depends:

52 base >= 4.7 && < 4.10

53 , base-compat >= 0.9 && < 0.10

54− , aeson >= 0.7 && < 0.12

54+ , aeson >= 0.7 && < 1.1

55 , attoparsec >= 0.12 && < 0.14

56 , bytestring >= 0.10 && < 0.11

57− , bytestring-conversion >= 0.3 && < 0.4

58 , case-insensitive >= 1.2 && < 1.3

57 , case-insensitive >= 1.2 && < 1.3

59− , http-api-data >= 0.1 && < 0.3

58+ , http-api-data >= 0.3 && < 0.4

60 , http-media >= 0.4 && < 0.7

59 , http-media >= 0.4 && < 0.7

61 , http-types >= 0.8 && < 0.10

60 , http-types >= 0.8 && < 0.10

62 , mtl >= 2.0 && < 2.3

61 , mtl >= 2.0 && < 2.3

servant/src/Servant/API.hs+4−4

@@ -8,7 +8,7 @@ module Servant.API (

8

9 -- * Accessing information from the request

10 module Servant.API.Capture,

11− -- | Capturing parts of the url path as parsed values: @'Capture'@

11+ -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@

12 module Servant.API.Header,

13 -- | Retrieving specific headers from the request

14 module Servant.API.HttpVersion,

@@ -60,12 +60,12 @@ module Servant.API (

60

61import Servant.API.Alternative ((:<|>) (..))

62import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))

63−import Servant.API.Capture (Capture)

63+import Servant.API.Capture (Capture, CaptureAll)

64import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

65− FromFormUrlEncoded (..), JSON,

65+ JSON,

66 MimeRender (..), NoContent (NoContent),

67 MimeUnrender (..), OctetStream,

68− PlainText, ToFormUrlEncoded (..))

68+ PlainText)

69import Servant.API.Experimental.Auth (AuthProtect)

70import Servant.API.Header (Header (..))

71import Servant.API.HttpVersion (HttpVersion (..))

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

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

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

4{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Capture (Capture) where

5+module Servant.API.Capture (Capture, CaptureAll) where

6

7import Data.Typeable (Typeable)

8import GHC.TypeLits (Symbol)

@@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol)

15data Capture (sym :: Symbol) a

16 deriving (Typeable)

17

18+

19+-- | Capture all remaining values from the request path under a certain type

20+-- @a@.

21+--

22+-- Example:

23+--

24+-- >>> -- GET /src/*

25+-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile

26+data CaptureAll (sym :: Symbol) a

27+ deriving (Typeable)

28+

18-- $setup

29-- $setup

19-- >>> import Servant.API

30-- >>> import Servant.API

20-- >>> import Data.Aeson

31-- >>> import Data.Aeson

21-- >>> import Data.Text

32-- >>> import Data.Text

22-- >>> data Book

33-- >>> data Book

23-- >>> instance ToJSON Book where { toJSON = undefined }

34-- >>> instance ToJSON Book where { toJSON = undefined }

35+-- >>> data SourceFile

36+-- >>> instance ToJSON SourceFile where { toJSON = undefined }

servant/src/Servant/API/ContentTypes.hs+9−55

@@ -66,8 +66,6 @@ module Servant.API.ContentTypes

66 , AllMime(..)

67 , AllMimeRender(..)

68 , AllMimeUnrender(..)

69− , FromFormUrlEncoded(..)

70− , ToFormUrlEncoded(..)

71 , eitherDecodeLenient

69 , eitherDecodeLenient

72 , canHandleAcceptH

70 , canHandleAcceptH

73 ) where

71 ) where

@@ -82,10 +80,8 @@ import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,

82import qualified Data.ByteString as BS

80import qualified Data.ByteString as BS

83import Data.ByteString.Lazy (ByteString, fromStrict,

81import Data.ByteString.Lazy (ByteString, fromStrict,

84 toStrict)

82 toStrict)

85−import qualified Data.ByteString.Lazy as B

86import qualified Data.ByteString.Lazy.Char8 as BC

83import qualified Data.ByteString.Lazy.Char8 as BC

87import Data.Maybe (isJust)

84import Data.Maybe (isJust)

88−import Data.Monoid.Compat

89import Data.String.Conversions (cs)

85import Data.String.Conversions (cs)

90import qualified Data.Text as TextS

86import qualified Data.Text as TextS

91import qualified Data.Text.Encoding as TextS

87import qualified Data.Text.Encoding as TextS

@@ -94,8 +90,9 @@ import qualified Data.Text.Lazy.Encoding as TextL

94import Data.Typeable

90import Data.Typeable

95import GHC.Generics (Generic)

91import GHC.Generics (Generic)

96import qualified Network.HTTP.Media as M

92import qualified Network.HTTP.Media as M

97−import Network.URI (escapeURIString,

93+import Web.FormUrlEncoded (FromForm, ToForm,

98− isUnreserved, unEscapeString)

94+ urlEncodeAsForm,

95+ urlDecodeAsForm)

99import Prelude ()

96import Prelude ()

100import Prelude.Compat

97import Prelude.Compat

101

98

@@ -290,12 +287,12 @@ instance OVERLAPPABLE_

290 ToJSON a => MimeRender JSON a where

287 ToJSON a => MimeRender JSON a where

291 mimeRender _ = encode

288 mimeRender _ = encode

292

289

293−-- | @encodeFormUrlEncoded . toFormUrlEncoded@

290+-- | @urlEncodeAsForm@

294-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

291-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

295-- holds if every element of x is non-null (i.e., not @("", "")@)

292-- holds if every element of x is non-null (i.e., not @("", "")@)

296instance OVERLAPPABLE_

293instance OVERLAPPABLE_

297− ToFormUrlEncoded a => MimeRender FormUrlEncoded a where

294+ ToForm a => MimeRender FormUrlEncoded a where

298− mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded

295+ mimeRender _ = urlEncodeAsForm

299

296

300-- | `TextL.encodeUtf8`

297-- | `TextL.encodeUtf8`

301instance MimeRender PlainText TextL.Text where

298instance MimeRender PlainText TextL.Text where

@@ -348,11 +345,11 @@ eitherDecodeLenient input =

348instance FromJSON a => MimeUnrender JSON a where

345instance FromJSON a => MimeUnrender JSON a where

349 mimeUnrender _ = eitherDecodeLenient

346 mimeUnrender _ = eitherDecodeLenient

350

347

351−-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@

348+-- | @urlDecodeAsForm@

352-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

349-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

353-- holds if every element of x is non-null (i.e., not @("", "")@)

350-- holds if every element of x is non-null (i.e., not @("", "")@)

354−instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where

351+instance FromForm a => MimeUnrender FormUrlEncoded a where

355− mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded

352+ mimeUnrender _ = left TextS.unpack . urlDecodeAsForm

356

353

357-- | @left show . TextL.decodeUtf8'@

354-- | @left show . TextL.decodeUtf8'@

358instance MimeUnrender PlainText TextL.Text where

355instance MimeUnrender PlainText TextL.Text where

@@ -375,49 +372,6 @@ instance MimeUnrender OctetStream BS.ByteString where

375 mimeUnrender _ = Right . toStrict

372 mimeUnrender _ = Right . toStrict

376

373

377

374

378−--------------------------------------------------------------------------

379−-- * FormUrlEncoded

380−

381−-- | A type that can be converted to @application/x-www-form-urlencoded@

382−class ToFormUrlEncoded a where

383− toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)]

384−

385−instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where

386− toFormUrlEncoded = id

387−

388−-- | A type that can be converted from @application/x-www-form-urlencoded@,

389−-- with the possibility of failure.

390−class FromFormUrlEncoded a where

391− fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a

392−

393−instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where

394− fromFormUrlEncoded = return

395−

396−encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString

397−encodeFormUrlEncoded xs =

398− let escape :: TextS.Text -> ByteString

399− escape = cs . escapeURIString isUnreserved . cs

400− encodePair :: (TextS.Text, TextS.Text) -> ByteString

401− encodePair (k, "") = escape k

402− encodePair (k, v) = escape k <> "=" <> escape v

403− in B.intercalate "&" $ map encodePair xs

404−

405−decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]

406−decodeFormUrlEncoded "" = return []

407−decodeFormUrlEncoded q = do

408− let xs :: [TextS.Text]

409− xs = TextS.splitOn "&" . cs $ q

410− parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)

411− parsePair p =

412− case TextS.splitOn "=" p of

413− [k,v] -> return ( unescape k

414− , unescape v

415− )

416− [k] -> return ( unescape k, "" )

417− _ -> Left $ "not a valid pair: " <> cs p

418− unescape :: TextS.Text -> TextS.Text

419− unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"

420− mapM parsePair xs

421

375

422-- $setup

376-- $setup

423-- >>> import Servant.API

377-- >>> import Servant.API

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+11−4

@@ -13,6 +13,13 @@ import Servant.API

13type GET = Get '[JSON] NoContent

14

15type ComprehensiveAPI =

16+ ComprehensiveAPIWithoutRaw :<|>

17+ Raw

18+

19+comprehensiveAPI :: Proxy ComprehensiveAPI

20+comprehensiveAPI = Proxy

21+

22+type ComprehensiveAPIWithoutRaw =

16 GET :<|>

23 GET :<|>

17 Get '[JSON] Int :<|>

24 Get '[JSON] Int :<|>

18 Capture "foo" Int :> GET :<|>

25 Capture "foo" Int :> GET :<|>

@@ -22,7 +29,6 @@ type ComprehensiveAPI =

22 QueryParam "foo" Int :> GET :<|>

29 QueryParam "foo" Int :> GET :<|>

23 QueryParams "foo" Int :> GET :<|>

30 QueryParams "foo" Int :> GET :<|>

24 QueryFlag "foo" :> GET :<|>

31 QueryFlag "foo" :> GET :<|>

25−-- Raw :<|>

26 RemoteHost :> GET :<|>

32 RemoteHost :> GET :<|>

27 ReqBody '[JSON] Int :> GET :<|>

33 ReqBody '[JSON] Int :> GET :<|>

28 Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>

34 Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>

@@ -30,7 +36,8 @@ type ComprehensiveAPI =

30 Vault :> GET :<|>

36 Vault :> GET :<|>

31 Verb 'POST 204 '[JSON] NoContent :<|>

37 Verb 'POST 204 '[JSON] NoContent :<|>

32 Verb 'POST 204 '[JSON] Int :<|>

38 Verb 'POST 204 '[JSON] Int :<|>

33− WithNamedContext "foo" '[] GET

39+ WithNamedContext "foo" '[] GET :<|>

40+ CaptureAll "foo" Int :> GET

34

41

35−comprehensiveAPI :: Proxy ComprehensiveAPI

42+comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw

36−comprehensiveAPI = Proxy

43+comprehensiveAPIWithoutRaw = Proxy

servant/src/Servant/API/IsSecure.hs+3−1

@@ -1,10 +1,12 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

2module Servant.API.IsSecure

3module Servant.API.IsSecure

3 ( -- $issecure

4 ( -- $issecure

4 IsSecure(..)

5 IsSecure(..)

5 ) where

6 ) where

6

7

7import Data.Typeable

8import Data.Typeable

9+import GHC.Generics (Generic)

8

10

9-- | Was this request made over an SSL connection?

11-- | Was this request made over an SSL connection?

10--

12--

@@ -19,7 +21,7 @@ data IsSecure = Secure -- ^ the connection to the server

19 -- is secure (HTTPS)

21 -- is secure (HTTPS)

20 | NotSecure -- ^ the connection to the server

22 | NotSecure -- ^ the connection to the server

21 -- is not secure (HTTP)

23 -- is not secure (HTTP)

22− deriving Typeable

24+ deriving (Eq, Show, Read, Generic, Ord, Typeable)

23

25

24-- $issecure

26-- $issecure

25--

27--

servant/src/Servant/API/ResponseHeaders.hs+12−12

@@ -31,8 +31,8 @@ module Servant.API.ResponseHeaders

31 ) where

32

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

34−import Data.ByteString.Conversion (ToByteString, toByteString',

34+import Web.HttpApiData (ToHttpApiData, toHeader,

35− FromByteString, fromByteString)

35+ FromHttpApiData, parseHeader)

36import qualified Data.CaseInsensitive as CI

37import Data.Proxy

38import GHC.TypeLits (KnownSymbol, symbolVal)

@@ -68,17 +68,17 @@ class BuildHeadersTo hs where

68instance OVERLAPPING_ BuildHeadersTo '[] where

69 buildHeadersTo _ = HNil

70

71−instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )

71+instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )

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

73 buildHeadersTo headers =

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

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

76 in case matching of

77 [] -> MissingHeader `HCons` buildHeadersTo headers

78− xs -> case fromByteString (BS.init $ BS.unlines xs) of

78+ xs -> case parseHeader (BS.init $ BS.unlines xs) of

79− Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)

79+ Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)

80 `HCons` buildHeadersTo headers

81− Just h -> Header h `HCons` buildHeadersTo headers

81+ Right h -> Header h `HCons` buildHeadersTo headers

82

83-- * Getting

84

@@ -88,18 +88,18 @@ class GetHeaders ls where

88instance OVERLAPPING_ GetHeaders (HList '[]) where

89 getHeaders _ = []

90

91−instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) )

91+instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )

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

93 getHeaders hdrs = case hdrs of

94− Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest

94+ Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest

95− UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest

95+ UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest

96 MissingHeader `HCons` rest -> getHeaders rest

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

98

99instance OVERLAPPING_ GetHeaders (Headers '[] a) where

100 getHeaders _ = []

101

102−instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v )

102+instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )

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

104 getHeaders hs = getHeaders $ getHeadersHList hs

105

@@ -111,11 +111,11 @@ class AddHeader h v orig new

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

112

113

114−instance OVERLAPPING_ ( KnownSymbol h, ToByteString v )

114+instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )

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

116 addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)

117

118−instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v

118+instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v

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

120 => AddHeader h v a new where

121 addHeader a resp = Headers resp (HCons (Header a) HNil)

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

@@ -107,7 +107,7 @@ import Prelude.Compat

107

108import Web.HttpApiData

109import Servant.API.BasicAuth ( BasicAuth )

110−import Servant.API.Capture ( Capture )

110+import Servant.API.Capture ( Capture, CaptureAll )

111import Servant.API.ReqBody ( ReqBody )

112import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )

113import Servant.API.Header ( Header )

@@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where

163 IsElem sa (ReqBody y x :> sb) = IsElem sa sb

164 IsElem (Capture z y :> sa) (Capture x y :> sb)

165 = IsElem sa sb

166+ IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)

167+ = IsElem sa sb

166 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

168 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

167 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

169 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

168 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

170 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

@@ -284,6 +286,13 @@ instance (ToHttpApiData v, HasLink sub)

284 toLink (Proxy :: Proxy sub) $

286 toLink (Proxy :: Proxy sub) $

285 addSegment (escape . Text.unpack $ toUrlPiece v) l

287 addSegment (escape . Text.unpack $ toUrlPiece v) l

286

288

289+instance (ToHttpApiData v, HasLink sub)

290+ => HasLink (CaptureAll sym v :> sub) where

291+ type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub

292+ toLink _ l vs =

293+ toLink (Proxy :: Proxy sub) $

294+ foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs

295+

287instance HasLink sub => HasLink (Header sym a :> sub) where

296instance HasLink sub => HasLink (Header sym a :> sub) where

288 type MkLink (Header sym a :> sub) = MkLink sub

297 type MkLink (Header sym a :> sub) = MkLink sub

289 toLink _ = toLink (Proxy :: Proxy sub)

298 toLink _ = toLink (Proxy :: Proxy sub)

servant/test/Servant/API/ContentTypesSpec.hs−17

@@ -11,7 +11,6 @@ module Servant.API.ContentTypesSpec where

11import Prelude ()

12import Prelude.Compat

13

14−import Control.Arrow

15import Data.Aeson

14import Data.Aeson

16import Data.ByteString.Char8 (ByteString, append, pack)

15import Data.ByteString.Char8 (ByteString, append, pack)

17import qualified Data.ByteString.Lazy as BSL

16import qualified Data.ByteString.Lazy as BSL

@@ -25,7 +24,6 @@ import Data.String.Conversions (cs)

25import qualified Data.Text as TextS

24import qualified Data.Text as TextS

26import qualified Data.Text.Lazy as TextL

25import qualified Data.Text.Lazy as TextL

27import GHC.Generics

26import GHC.Generics

28−import Network.URL (exportParams, importParams)

29import Test.Hspec

27import Test.Hspec

30import Test.QuickCheck

28import Test.QuickCheck

31import "quickcheck-instances" Test.QuickCheck.Instances ()

29import "quickcheck-instances" Test.QuickCheck.Instances ()

@@ -68,21 +66,6 @@ spec = describe "Servant.API.ContentTypes" $ do

68 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

66 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

69 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

67 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

70

68

71− describe "The FormUrlEncoded Content-Type type" $ do

72− let p = Proxy :: Proxy FormUrlEncoded

73−

74− it "has mimeUnrender reverse mimeRender" $ do

75− property $ \x -> mempty `notElem` x

76− ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])

77−

78− it "has mimeUnrender reverse exportParams (Network.URL)" $ do

79− property $ \x -> mempty `notElem` x

80− ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])

81−

82− it "has importParams (Network.URL) reverse mimeRender" $ do

83− property $ \x -> mempty `notElem` x

84− ==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])

85−

86 describe "The PlainText Content-Type type" $ do

69 describe "The PlainText Content-Type type" $ do

87 let p = Proxy :: Proxy PlainText

70 let p = Proxy :: Proxy PlainText

88

71

servant/test/Servant/Utils/LinksSpec.hs+5

@@ -13,6 +13,7 @@ import Servant.API

13type TestApi =

14 -- Capture and query params

15 "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent

16+ :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent

16

17

17 -- Flags

18 -- Flags

18 :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent

19 :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent

@@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do

46 :> Delete '[JSON] NoContent)

47 :> Delete '[JSON] NoContent)

47 apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"

48 apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"

48

49

50+ it "generates correct links for CaptureAll" $ do

51+ apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))

52+ ["roads", "lead", "to", "rome"]

53+ `shouldBeURI` "all/roads/lead/to/rome"

49

54

50 it "generates correct links for query flags" $ do

55 it "generates correct links for query flags" $ do

51 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"

56 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"

sources.txt−1

@@ -4,4 +4,3 @@ servant-client

4servant-docs

5servant-foreign

6servant-js

7−servant-mock

stack-ghc-7.8.4.yaml+2−6

@@ -5,7 +5,6 @@ packages:

5- servant-docs/

6- servant-foreign/

7- servant-js/

8−- servant-mock/

9- servant-server/

8- servant-server/

10extra-deps:

9extra-deps:

11- base-compat-0.9.1

10- base-compat-0.9.1

@@ -16,13 +15,10 @@ extra-deps:

16- hspec-core-2.2.3

15- hspec-core-2.2.3

17- hspec-discover-2.2.3

16- hspec-discover-2.2.3

18- hspec-expectations-0.7.2

17- hspec-expectations-0.7.2

19−- http-api-data-0.2.2

18+- http-api-data-0.3

20- primitive-0.6.1.0

19- primitive-0.6.1.0

21−- servant-0.7.1

22−- servant-client-0.7.1

23−- servant-docs-0.7.1

24−- servant-server-0.7.1

25- should-not-typecheck-2.1.0

20- should-not-typecheck-2.1.0

26- time-locale-compat-0.1.1.1

21- time-locale-compat-0.1.1.1

22+- uri-bytestring-0.2.2.0

27- wai-app-static-3.1.5

23- wai-app-static-3.1.5

28resolver: lts-2.22

24resolver: lts-2.22

stack-ghc-8.0.1.yaml+3−2

@@ -5,7 +5,8 @@ packages:

5- servant-docs/

6- servant-foreign/

7- servant-js/

8−- servant-mock/

9- servant-server/

8- servant-server/

10−extra-deps: []

9+extra-deps:

10+- http-api-data-0.3

11+- uri-bytestring-0.2.2.0

11flags: {}

12flags: {}

stack.yaml+1−1

@@ -5,8 +5,8 @@ packages:

5- servant-docs/

6- servant-foreign/

7- servant-js/

8−- servant-mock/

9- servant-server/

8- servant-server/

10- doc/tutorial

9- doc/tutorial

11extra-deps:

10extra-deps:

11+- http-api-data-0.3

12resolver: lts-6.0