fc517a2 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #60 from codedmart/fix-baseurl

fc517a2Julian Arni11 years ago

servant-client/src/Servant/Client.hs+121−94

compare with master

unifiedsplit

@@ -52,16 +52,17 @@ import Servant.Common.Req

52-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]

53-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book

54-- > (getAllBooks :<|> postNewBook) = client myApi

55−client :: HasClient layout => Proxy layout -> Client layout

55+client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout

56−client p = clientWithRoute p defReq

56+client p baseurl = clientWithRoute p defReq baseurl

58-- | This class lets us define how each API combinator

59-- influences the creation of an HTTP request. It's mostly

60-- an internal class, you can just use 'client'.

61class HasClient layout where

62 type Client layout :: *

63− clientWithRoute :: Proxy layout -> Req -> Client layout

63+ clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout

65+{-type Client layout = Client layout-}

66-- | A client querying function for @a ':<|>' b@ will actually hand you

67-- | A client querying function for @a ':<|>' b@ will actually hand you

67-- one function for querying @a@ and another one for querying @b@,

68-- one function for querying @a@ and another one for querying @b@,

@@ -78,9 +79,9 @@ class HasClient layout where

78-- > (getAllBooks :<|> postNewBook) = client myApi

79-- > (getAllBooks :<|> postNewBook) = client myApi

79instance (HasClient a, HasClient b) => HasClient (a :<|> b) where

80instance (HasClient a, HasClient b) => HasClient (a :<|> b) where

80 type Client (a :<|> b) = Client a :<|> Client b

81 type Client (a :<|> b) = Client a :<|> Client b

81− clientWithRoute Proxy req =

82+ clientWithRoute Proxy req baseurl =

82− clientWithRoute (Proxy :: Proxy a) req :<|>

83+ clientWithRoute (Proxy :: Proxy a) req baseurl :<|>

83− clientWithRoute (Proxy :: Proxy b) req

84+ clientWithRoute (Proxy :: Proxy b) req baseurl

85-- | If you use a 'Capture' in one of your endpoints in your API,

86-- | If you use a 'Capture' in one of your endpoints in your API,

86-- the corresponding querying function will automatically take

87-- the corresponding querying function will automatically take

@@ -107,9 +108,10 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)

107 type Client (Capture capture a :> sublayout) =

108 type Client (Capture capture a :> sublayout) =

108 a -> Client sublayout

109 a -> Client sublayout

109

110

110− clientWithRoute Proxy req val =

111+ clientWithRoute Proxy req baseurl val =

111− clientWithRoute (Proxy :: Proxy sublayout) $

112+ clientWithRoute (Proxy :: Proxy sublayout)

112− appendToPath p req

113+ (appendToPath p req)

114+ baseurl

113

115

114 where p = unpack (toText val)

116 where p = unpack (toText val)

115

117

@@ -122,9 +124,9 @@ instance

122 {-# OVERLAPPABLE #-}

124 {-# OVERLAPPABLE #-}

123#endif

125#endif

124 (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where

126 (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where

125− type Client (Delete (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

127+ type Client (Delete (ct ': cts) a) = EitherT ServantError IO a

126− clientWithRoute Proxy req host =

128+ clientWithRoute Proxy req baseurl =

127− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host

129+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

128

130

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

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

130-- HTTP header.

132-- HTTP header.

@@ -133,9 +135,9 @@ instance

133 {-# OVERLAPPING #-}

135 {-# OVERLAPPING #-}

134#endif

136#endif

135 HasClient (Delete (ct ': cts) ()) where

137 HasClient (Delete (ct ': cts) ()) where

136− type Client (Delete (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()

138+ type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()

137− clientWithRoute Proxy req host =

139+ clientWithRoute Proxy req baseurl =

138− void $ performRequestNoBody H.methodDelete req [204] host

140+ void $ performRequestNoBody H.methodDelete req [204] baseurl

139

141

140-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the

142-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the

141-- corresponding headers.

143-- corresponding headers.

@@ -145,14 +147,13 @@ instance

145#endif

147#endif

146 ( MimeUnrender ct a, BuildHeadersTo ls

148 ( MimeUnrender ct a, BuildHeadersTo ls

147 ) => HasClient (Delete (ct ': cts) (Headers ls a)) where

149 ) => HasClient (Delete (ct ': cts) (Headers ls a)) where

148− type Client (Delete (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

150+ type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

149− clientWithRoute Proxy req host = do

151+ clientWithRoute Proxy req baseurl = do

150− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host

152+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

151 return $ Headers { getResponse = resp

153 return $ Headers { getResponse = resp

152 , getHeadersHList = buildHeadersTo hdrs

154 , getHeadersHList = buildHeadersTo hdrs

153 }

155 }

154

156

155−

156-- | If you have a 'Get' endpoint in your API, the client

157-- | If you have a 'Get' endpoint in your API, the client

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

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

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

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

@@ -162,9 +163,9 @@ instance

162 {-# OVERLAPPABLE #-}

163 {-# OVERLAPPABLE #-}

163#endif

164#endif

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

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

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

166+ type Client (Get (ct ': cts) result) = EitherT ServantError IO result

166− clientWithRoute Proxy req host =

167+ clientWithRoute Proxy req baseurl =

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

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

168

169

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

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

170-- HTTP status.

171-- HTTP status.

@@ -173,9 +174,9 @@ instance

173 {-# OVERLAPPING #-}

174 {-# OVERLAPPING #-}

174#endif

175#endif

175 HasClient (Get (ct ': cts) ()) where

176 HasClient (Get (ct ': cts) ()) where

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

177+ type Client (Get (ct ': cts) ()) = EitherT ServantError IO ()

177− clientWithRoute Proxy req host =

178+ clientWithRoute Proxy req baseurl =

178− performRequestNoBody H.methodGet req [204] host

179+ performRequestNoBody H.methodGet req [204] baseurl

179

180

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

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

181-- corresponding headers.

182-- corresponding headers.

@@ -185,9 +186,9 @@ instance

185#endif

186#endif

186 ( MimeUnrender ct a, BuildHeadersTo ls

187 ( MimeUnrender ct a, BuildHeadersTo ls

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

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

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

189+ type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

189− clientWithRoute Proxy req host = do

190+ clientWithRoute Proxy req baseurl = do

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

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

191 return $ Headers { getResponse = resp

192 return $ Headers { getResponse = resp

192 , getHeadersHList = buildHeadersTo hdrs

193 , getHeadersHList = buildHeadersTo hdrs

193 }

194 }

@@ -223,9 +224,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)

223 type Client (Header sym a :> sublayout) =

224 type Client (Header sym a :> sublayout) =

224 Maybe a -> Client sublayout

225 Maybe a -> Client sublayout

225

226

226− clientWithRoute Proxy req mval =

227+ clientWithRoute Proxy req baseurl mval =

227− clientWithRoute (Proxy :: Proxy sublayout) $

228+ clientWithRoute (Proxy :: Proxy sublayout)

229+ (maybe req

228− maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval

230+ (\value -> Servant.Common.Req.addHeader hname value req)

231+ mval

232+ )

233+ baseurl

229

234

230 where hname = symbolVal (Proxy :: Proxy sym)

235 where hname = symbolVal (Proxy :: Proxy sym)

231

236

@@ -238,10 +243,9 @@ instance

238 {-# OVERLAPPABLE #-}

243 {-# OVERLAPPABLE #-}

239#endif

244#endif

240 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where

245 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where

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

246+ type Client (Post (ct ': cts) a) = EitherT ServantError IO a

242−

243− clientWithRoute Proxy req uri =

247+ clientWithRoute Proxy req baseurl =

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

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

245

249

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

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

247-- HTTP header.

251-- HTTP header.

@@ -250,9 +254,9 @@ instance

250 {-# OVERLAPPING #-}

254 {-# OVERLAPPING #-}

251#endif

255#endif

252 HasClient (Post (ct ': cts) ()) where

256 HasClient (Post (ct ': cts) ()) where

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

257+ type Client (Post (ct ': cts) ()) = EitherT ServantError IO ()

254− clientWithRoute Proxy req host =

258+ clientWithRoute Proxy req baseurl =

255− void $ performRequestNoBody H.methodPost req [204] host

259+ void $ performRequestNoBody H.methodPost req [204] baseurl

256

260

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

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

258-- corresponding headers.

262-- corresponding headers.

@@ -262,9 +266,9 @@ instance

262#endif

266#endif

263 ( MimeUnrender ct a, BuildHeadersTo ls

267 ( MimeUnrender ct a, BuildHeadersTo ls

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

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

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

269+ type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

266− clientWithRoute Proxy req host = do

270+ clientWithRoute Proxy req baseurl = do

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

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

268 return $ Headers { getResponse = resp

272 return $ Headers { getResponse = resp

269 , getHeadersHList = buildHeadersTo hdrs

273 , getHeadersHList = buildHeadersTo hdrs

270 }

274 }

@@ -278,10 +282,9 @@ instance

278 {-# OVERLAPPABLE #-}

282 {-# OVERLAPPABLE #-}

279#endif

283#endif

280 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where

284 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where

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

285+ type Client (Put (ct ': cts) a) = EitherT ServantError IO a

282−

283− clientWithRoute Proxy req host =

286+ clientWithRoute Proxy req baseurl =

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

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

285

288

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

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

287-- HTTP header.

290-- HTTP header.

@@ -290,9 +293,9 @@ instance

290 {-# OVERLAPPING #-}

293 {-# OVERLAPPING #-}

291#endif

294#endif

292 HasClient (Put (ct ': cts) ()) where

295 HasClient (Put (ct ': cts) ()) where

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

296+ type Client (Put (ct ': cts) ()) = EitherT ServantError IO ()

294− clientWithRoute Proxy req host =

297+ clientWithRoute Proxy req baseurl =

295− void $ performRequestNoBody H.methodPut req [204] host

298+ void $ performRequestNoBody H.methodPut req [204] baseurl

296

299

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

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

298-- corresponding headers.

301-- corresponding headers.

@@ -302,9 +305,9 @@ instance

302#endif

305#endif

303 ( MimeUnrender ct a, BuildHeadersTo ls

306 ( MimeUnrender ct a, BuildHeadersTo ls

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

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

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

308+ type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

306− clientWithRoute Proxy req host = do

309+ clientWithRoute Proxy req baseurl = do

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

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

308 return $ Headers { getResponse = resp

311 return $ Headers { getResponse = resp

309 , getHeadersHList = buildHeadersTo hdrs

312 , getHeadersHList = buildHeadersTo hdrs

310 }

313 }

@@ -318,10 +321,9 @@ instance

318 {-# OVERLAPPABLE #-}

321 {-# OVERLAPPABLE #-}

319#endif

322#endif

320 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where

323 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where

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

324+ type Client (Patch (ct ': cts) a) = EitherT ServantError IO a

322−

323− clientWithRoute Proxy req host =

325+ clientWithRoute Proxy req baseurl =

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

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

325

327

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

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

327-- HTTP header.

329-- HTTP header.

@@ -330,9 +332,9 @@ instance

330 {-# OVERLAPPING #-}

332 {-# OVERLAPPING #-}

331#endif

333#endif

332 HasClient (Patch (ct ': cts) ()) where

334 HasClient (Patch (ct ': cts) ()) where

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

335+ type Client (Patch (ct ': cts) ()) = EitherT ServantError IO ()

334− clientWithRoute Proxy req host =

336+ clientWithRoute Proxy req baseurl =

335− void $ performRequestNoBody H.methodPatch req [204] host

337+ void $ performRequestNoBody H.methodPatch req [204] baseurl

336

338

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

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

338-- corresponding headers.

340-- corresponding headers.

@@ -342,9 +344,9 @@ instance

342#endif

344#endif

343 ( MimeUnrender ct a, BuildHeadersTo ls

345 ( MimeUnrender ct a, BuildHeadersTo ls

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

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

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

347+ type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

346− clientWithRoute Proxy req host = do

348+ clientWithRoute Proxy req baseurl = do

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

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

348 return $ Headers { getResponse = resp

350 return $ Headers { getResponse = resp

349 , getHeadersHList = buildHeadersTo hdrs

351 , getHeadersHList = buildHeadersTo hdrs

350 }

352 }

@@ -381,9 +383,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)

381 Maybe a -> Client sublayout

383 Maybe a -> Client sublayout

382

384

383 -- if mparam = Nothing, we don't add it to the query string

385 -- if mparam = Nothing, we don't add it to the query string

384− clientWithRoute Proxy req mparam =

386+ clientWithRoute Proxy req baseurl mparam =

385− clientWithRoute (Proxy :: Proxy sublayout) $

387+ clientWithRoute (Proxy :: Proxy sublayout)

388+ (maybe req

386− maybe req (flip (appendToQueryString pname) req . Just) mparamText

389+ (flip (appendToQueryString pname) req . Just)

390+ mparamText

391+ )

392+ baseurl

387

393

388 where pname = cs pname'

394 where pname = cs pname'

389 pname' = symbolVal (Proxy :: Proxy sym)

395 pname' = symbolVal (Proxy :: Proxy sym)

@@ -422,9 +428,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)

422 type Client (QueryParams sym a :> sublayout) =

428 type Client (QueryParams sym a :> sublayout) =

423 [a] -> Client sublayout

429 [a] -> Client sublayout

424

430

425− clientWithRoute Proxy req paramlist =

431+ clientWithRoute Proxy req baseurl paramlist =

426− clientWithRoute (Proxy :: Proxy sublayout) $

432+ clientWithRoute (Proxy :: Proxy sublayout)

427− foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist'

433+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))

434+ req

435+ paramlist'

436+ )

437+ baseurl

428

438

429 where pname = cs pname'

439 where pname = cs pname'

430 pname' = symbolVal (Proxy :: Proxy sym)

440 pname' = symbolVal (Proxy :: Proxy sym)

@@ -457,11 +467,13 @@ instance (KnownSymbol sym, HasClient sublayout)

457 type Client (QueryFlag sym :> sublayout) =

467 type Client (QueryFlag sym :> sublayout) =

458 Bool -> Client sublayout

468 Bool -> Client sublayout

459

469

460− clientWithRoute Proxy req flag =

470+ clientWithRoute Proxy req baseurl flag =

461− clientWithRoute (Proxy :: Proxy sublayout) $

471+ clientWithRoute (Proxy :: Proxy sublayout)

462− if flag

472+ (if flag

463− then appendToQueryString paramname Nothing req

473+ then appendToQueryString paramname Nothing req

464− else req

474+ else req

475+ )

476+ baseurl

465

477

466 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

478 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

467

479

@@ -497,9 +509,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)

497 Maybe a -> Client sublayout

509 Maybe a -> Client sublayout

498

510

499 -- if mparam = Nothing, we don't add it to the query string

511 -- if mparam = Nothing, we don't add it to the query string

500− clientWithRoute Proxy req mparam =

512+ clientWithRoute Proxy req baseurl mparam =

501− clientWithRoute (Proxy :: Proxy sublayout) $

513+ clientWithRoute (Proxy :: Proxy sublayout)

514+ (maybe req

502− maybe req (flip (appendToMatrixParams pname . Just) req) mparamText

515+ (flip (appendToMatrixParams pname . Just) req)

516+ mparamText

517+ )

518+ baseurl

503

519

504 where pname = symbolVal (Proxy :: Proxy sym)

520 where pname = symbolVal (Proxy :: Proxy sym)

505 mparamText = fmap (cs . toText) mparam

521 mparamText = fmap (cs . toText) mparam

@@ -537,9 +553,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)

537 type Client (MatrixParams sym a :> sublayout) =

553 type Client (MatrixParams sym a :> sublayout) =

538 [a] -> Client sublayout

554 [a] -> Client sublayout

539

555

540− clientWithRoute Proxy req paramlist =

556+ clientWithRoute Proxy req baseurl paramlist =

541− clientWithRoute (Proxy :: Proxy sublayout) $

557+ clientWithRoute (Proxy :: Proxy sublayout)

542− foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist'

558+ (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)

559+ req

560+ paramlist'

561+ )

562+ baseurl

543

563

544 where pname = cs pname'

564 where pname = cs pname'

545 pname' = symbolVal (Proxy :: Proxy sym)

565 pname' = symbolVal (Proxy :: Proxy sym)

@@ -572,22 +592,24 @@ instance (KnownSymbol sym, HasClient sublayout)

572 type Client (MatrixFlag sym :> sublayout) =

592 type Client (MatrixFlag sym :> sublayout) =

573 Bool -> Client sublayout

593 Bool -> Client sublayout

574

594

575− clientWithRoute Proxy req flag =

595+ clientWithRoute Proxy req baseurl flag =

576− clientWithRoute (Proxy :: Proxy sublayout) $

596+ clientWithRoute (Proxy :: Proxy sublayout)

577− if flag

597+ (if flag

578− then appendToMatrixParams paramname Nothing req

598+ then appendToMatrixParams paramname Nothing req

579− else req

599+ else req

600+ )

601+ baseurl

580

602

581 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

603 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

582

604

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

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

584-- back the full `Response`.

606-- back the full `Response`.

585instance HasClient Raw where

607instance HasClient Raw where

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

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

587

609

588− clientWithRoute :: Proxy Raw -> Req -> Client Raw

610+ clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw

589− clientWithRoute Proxy req httpMethod host = do

611+ clientWithRoute Proxy req baseurl httpMethod = do

590− performRequest httpMethod req (const True) host

612+ performRequest httpMethod req (const True) baseurl

591

613

592-- | If you use a 'ReqBody' in one of your endpoints in your API,

614-- | If you use a 'ReqBody' in one of your endpoints in your API,

593-- the corresponding querying function will automatically take

615-- the corresponding querying function will automatically take

@@ -613,18 +635,23 @@ instance (MimeRender ct a, HasClient sublayout)

613 type Client (ReqBody (ct ': cts) a :> sublayout) =

635 type Client (ReqBody (ct ': cts) a :> sublayout) =

614 a -> Client sublayout

636 a -> Client sublayout

615

637

616− clientWithRoute Proxy req body =

638+ clientWithRoute Proxy req baseurl body =

617− clientWithRoute (Proxy :: Proxy sublayout) $ do

639+ clientWithRoute (Proxy :: Proxy sublayout)

618− let ctProxy = Proxy :: Proxy ct

640+ (let ctProxy = Proxy :: Proxy ct

619− setRQBody (mimeRender ctProxy body) (contentType ctProxy) req

641+ in setRQBody (mimeRender ctProxy body)

642+ (contentType ctProxy)

643+ req

644+ )

645+ baseurl

620

646

621-- | Make the querying function append @path@ to the request path.

647-- | Make the querying function append @path@ to the request path.

622instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where

648instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where

623 type Client (path :> sublayout) = Client sublayout

649 type Client (path :> sublayout) = Client sublayout

624

650

625− clientWithRoute Proxy req =

651+ clientWithRoute Proxy req baseurl =

626− clientWithRoute (Proxy :: Proxy sublayout) $

652+ clientWithRoute (Proxy :: Proxy sublayout)

627− appendToPath p req

653+ (appendToPath p req)

654+ baseurl

628

655

629 where p = symbolVal (Proxy :: Proxy path)

656 where p = symbolVal (Proxy :: Proxy path)

630

657

servant-client/test/Servant/ClientSpec.hs+169−165

@@ -9,6 +9,7 @@

9{-# LANGUAGE TypeOperators #-}

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

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

12+

12module Servant.ClientSpec where

13module Servant.ClientSpec where

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

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

@@ -80,7 +81,6 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

80type Api =

81type Api =

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

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

82 :<|> "delete" :> Delete '[JSON] ()

83 :<|> "delete" :> Delete '[JSON] ()

83− :<|> "deleteString" :> Delete '[JSON] String

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

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

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

@@ -105,7 +105,6 @@ server :: Application

105server = serve api (

106 return alice

107 :<|> return ()

108− :<|> return "ok"

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

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

110 :<|> return

109 :<|> return

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

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

@@ -129,42 +128,6 @@ server = serve api (

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

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

130withServer action = withWaiDaemon (return server) action

129withServer action = withWaiDaemon (return server) action

131

130

132−getGet :: BaseUrl -> EitherT ServantError IO Person

133−getDelete :: BaseUrl -> EitherT ServantError IO ()

134−getDeleteString :: BaseUrl -> EitherT ServantError IO String

135−getCapture :: String -> BaseUrl -> EitherT ServantError IO Person

136−getBody :: Person -> BaseUrl -> EitherT ServantError IO Person

137−getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person

138−getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]

139−getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool

140−getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person

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

142−getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool

143−getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,

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

145−getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,

146− MediaType, [HTTP.Header], C.Response ByteString)

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

148− -> BaseUrl

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

150−getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)

151−( getGet

152− :<|> getDelete

153− :<|> getDeleteString

154− :<|> getCapture

155− :<|> getBody

156− :<|> getQueryParam

157− :<|> getQueryParams

158− :<|> getQueryFlag

159− :<|> getMatrixParam

160− :<|> getMatrixParams

161− :<|> getMatrixFlag

162− :<|> getRawSuccess

163− :<|> getRawFailure

164− :<|> getMultiple

165− :<|> getRespHeaders)

166− = client api

167−

168type FailApi =

131type FailApi =

169 "get" :> Raw

132 "get" :> Raw

170 :<|> "capture" :> Capture "name" String :> Raw

133 :<|> "capture" :> Capture "name" String :> Raw

@@ -182,141 +145,182 @@ failServer = serve failApi (

182withFailServer :: (BaseUrl -> IO a) -> IO a

145withFailServer :: (BaseUrl -> IO a) -> IO a

183withFailServer action = withWaiDaemon (return failServer) action

146withFailServer action = withWaiDaemon (return failServer) action

184

147

185−spec :: Spec

148+spec :: IO ()

186−spec = do

149+spec = withServer $ \ baseUrl -> do

187− it "Servant.API.Get" $ withServer $ \ host -> do

150+ let getGet :: EitherT ServantError IO Person

188− (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice

151+ getDelete :: EitherT ServantError IO ()

189−

152+ getCapture :: String -> EitherT ServantError IO Person

190− context "Servant.API.Delete" $ do

153+ getBody :: Person -> EitherT ServantError IO Person

191− it "return no body" $ withServer $ \ host -> do

154+ getQueryParam :: Maybe String -> EitherT ServantError IO Person

155+ getQueryParams :: [String] -> EitherT ServantError IO [Person]

156+ getQueryFlag :: Bool -> EitherT ServantError IO Bool

157+ getMatrixParam :: Maybe String -> EitherT ServantError IO Person

158+ getMatrixParams :: [String] -> EitherT ServantError IO [Person]

159+ getMatrixFlag :: Bool -> EitherT ServantError IO Bool

160+ getRawSuccess :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)

161+ getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)

162+ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])

163+ getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)

164+ ( getGet

165+ :<|> getDelete

166+ :<|> getCapture

167+ :<|> getBody

168+ :<|> getQueryParam

169+ :<|> getQueryParams

170+ :<|> getQueryFlag

171+ :<|> getMatrixParam

172+ :<|> getMatrixParams

173+ :<|> getMatrixFlag

174+ :<|> getRawSuccess

175+ :<|> getRawFailure

176+ :<|> getMultiple

177+ :<|> getRespHeaders)

178+ = client api baseUrl

179+

180+ hspec $ do

181+ it "Servant.API.Get" $ do

192− (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()

182+ (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice

193−

183+

194− it "return body" $ withServer $ \ host -> do

184+ it "Servant.API.Delete" $ do

195− (Arrow.left show <$> runEitherT (getDeleteString host)) `shouldReturn` Right "ok"

185+ (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()

196−

186+

197− it "Servant.API.Capture" $ withServer $ \ host -> do

187+ it "Servant.API.Capture" $ do

198− (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)

188+ (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)

199−

189+

200− it "Servant.API.ReqBody" $ withServer $ \ host -> do

190+ it "Servant.API.ReqBody" $ do

201− let p = Person "Clara" 42

191+ let p = Person "Clara" 42

202− (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p

192+ (Arrow.left show <$> runEitherT (getBody p)) `shouldReturn` Right p

203−

193+

204− it "Servant.API.QueryParam" $ withServer $ \ host -> do

194+ it "Servant.API.QueryParam" $ do

205− Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice

195+ Arrow.left show <$> runEitherT (getQueryParam (Just "alice")) `shouldReturn` Right alice

206− Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host)

196+ Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob"))

207− responseStatus `shouldBe` Status 400 "bob not found"

197+ responseStatus `shouldBe` Status 400 "bob not found"

208−

198+

209− it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do

199+ it "Servant.API.QueryParam.QueryParams" $ do

210− (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []

200+ (Arrow.left show <$> runEitherT (getQueryParams [])) `shouldReturn` Right []

211− (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))

201+ (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"]))

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

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

213−

203+

214− context "Servant.API.QueryParam.QueryFlag" $

204+ context "Servant.API.QueryParam.QueryFlag" $

215− forM_ [False, True] $ \ flag ->

205+ forM_ [False, True] $ \ flag ->

216− it (show flag) $ withServer $ \ host -> do

206+ it (show flag) $ do

217− (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag

207+ (Arrow.left show <$> runEitherT (getQueryFlag flag)) `shouldReturn` Right flag

218−

208+

219− it "Servant.API.MatrixParam" $ withServer $ \ host -> do

209+ it "Servant.API.MatrixParam" $ do

220− Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice

210+ Arrow.left show <$> runEitherT (getMatrixParam (Just "alice")) `shouldReturn` Right alice

221− Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host)

211+ Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob"))

222− responseStatus `shouldBe` Status 400 "bob not found"

212+ responseStatus `shouldBe` Status 400 "bob not found"

223−

213+

224− it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do

214+ it "Servant.API.MatrixParam.MatrixParams" $ do

225− Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right []

215+ Arrow.left show <$> runEitherT (getMatrixParams []) `shouldReturn` Right []

226− Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host)

216+ Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"])

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

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

228−

218+

229− context "Servant.API.MatrixParam.MatrixFlag" $

219+ context "Servant.API.MatrixParam.MatrixFlag" $

230− forM_ [False, True] $ \ flag ->

220+ forM_ [False, True] $ \ flag ->

231− it (show flag) $ withServer $ \ host -> do

221+ it (show flag) $ do

232− Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag

222+ Arrow.left show <$> runEitherT (getMatrixFlag flag) `shouldReturn` Right flag

233−

223+

234− it "Servant.API.Raw on success" $ withServer $ \ host -> do

224+ it "Servant.API.Raw on success" $ do

235− res <- runEitherT (getRawSuccess methodGet host)

225+ res <- runEitherT (getRawSuccess methodGet)

236− case res of

237− Left e -> assertFailure $ show e

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

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

240− C.responseBody response `shouldBe` body

241− C.responseStatus response `shouldBe` ok200

242−

243− it "Servant.API.Raw on failure" $ withServer $ \ host -> do

244− res <- runEitherT (getRawFailure methodGet host)

245− case res of

246− Left e -> assertFailure $ show e

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

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

249− C.responseBody response `shouldBe` body

250− C.responseStatus response `shouldBe` badRequest400

251−

252− it "Returns headers appropriately" $ withServer $ \ host -> do

253− res <- runEitherT (getRespHeaders host)

254− case res of

255− Left e -> assertFailure $ show e

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

257−

258− modifyMaxSuccess (const 20) $ do

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

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

261− ioProperty $ do

262− withServer $ \ host -> do

263− result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)

264− return $

265− result === Right (cap, num, flag, body)

266−

267−

268− context "client correctly handles error status codes" $ do

269− let test :: (WrappedApi, String) -> Spec

270− test (WrappedApi api, desc) =

271− it desc $

272− withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $

273− \ host -> do

274− let getResponse :: BaseUrl -> EitherT ServantError IO ()

275− getResponse = client api

276− Left FailureResponse{..} <- runEitherT (getResponse host)

277− responseStatus `shouldBe` (Status 500 "error message")

278− mapM_ test $

279− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

280− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

281− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :

282− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :

283− []

284−

285− context "client returns errors appropriately" $ do

286− it "reports FailureResponse" $ withFailServer $ \ host -> do

287− Left res <- runEitherT (getDelete host)

288 case res of

226 case res of

289− FailureResponse (Status 404 "Not Found") _ _ -> return ()

227+ Left e -> assertFailure $ show e

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

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

291−

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

292− it "reports DecodeFailure" $ withFailServer $ \ host -> do

230+ C.responseBody response `shouldBe` body

293− Left res <- runEitherT (getCapture "foo" host)

231+ C.responseStatus response `shouldBe` ok200

232+

233+ it "Servant.API.Raw on failure" $ do

234+ res <- runEitherT (getRawFailure methodGet)

294 case res of

235 case res of

295− DecodeFailure _ ("application/json") _ -> return ()

236+ Left e -> assertFailure $ show e

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

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

297−

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

298− it "reports ConnectionError" $ do

239+ C.responseBody response `shouldBe` body

299− Right host <- return $ parseBaseUrl "127.0.0.1:987654"

240+ C.responseStatus response `shouldBe` badRequest400

241+

242+ it "Returns headers appropriately" $ withServer $ \ _ -> do

300− Left res <- runEitherT (getGet host)

243+ res <- runEitherT getRespHeaders

301 case res of

244 case res of

302− ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return ()

245+ Left e -> assertFailure $ show e

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

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

247+

248+ modifyMaxSuccess (const 20) $ do

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

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

251+ ioProperty $ do

252+ result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body)

253+ return $

254+ result === Right (cap, num, flag, body)

304

255

305− it "reports UnsupportedContentType" $ withFailServer $ \ host -> do

306− Left res <- runEitherT (getGet host)

307− case res of

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

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

310

256

311− it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do

257+ context "client correctly handles error status codes" $ do

258+ let test :: (WrappedApi, String) -> Spec

259+ test (WrappedApi api, desc) =

260+ it desc $

261+ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $

262+ \ host -> do

263+ let getResponse :: EitherT ServantError IO ()

264+ getResponse = client api host

265+ Left FailureResponse{..} <- runEitherT getResponse

266+ responseStatus `shouldBe` (Status 500 "error message")

267+ mapM_ test $

268+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

269+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

270+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :

271+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :

272+ []

273+

274+failSpec :: IO ()

275+failSpec = withFailServer $ \ baseUrl -> do

276+ let getGet :: EitherT ServantError IO Person

277+ getDelete :: EitherT ServantError IO ()

278+ getCapture :: String -> EitherT ServantError IO Person

279+ getBody :: Person -> EitherT ServantError IO Person

280+ ( getGet

281+ :<|> getDelete

282+ :<|> getCapture

283+ :<|> getBody

284+ :<|> _ )

285+ = client api baseUrl

286+ getGetWrongHost :: EitherT ServantError IO Person

287+ (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872)

288+

289+ hspec $ do

290+ context "client returns errors appropriately" $ do

291+ it "reports FailureResponse" $ do

292+ Left res <- runEitherT getDelete

293+ case res of

294+ FailureResponse (Status 404 "Not Found") _ _ -> return ()

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

296+

297+ it "reports DecodeFailure" $ do

298+ Left res <- runEitherT (getCapture "foo")

299+ case res of

300+ DecodeFailure _ ("application/json") _ -> return ()

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

302+

303+ it "reports ConnectionError" $ do

304+ Left res <- runEitherT getGetWrongHost

305+ case res of

306+ ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return ()

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

308+

309+ it "reports UnsupportedContentType" $ do

310+ Left res <- runEitherT getGet

311+ case res of

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

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

314+

315+ it "reports InvalidContentTypeHeader" $ do

312− Left res <- runEitherT (getBody alice host)

316+ Left res <- runEitherT (getBody alice)

313− case res of

317+ case res of

314− InvalidContentTypeHeader "fooooo" _ -> return ()

318+ InvalidContentTypeHeader "fooooo" _ -> return ()

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

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

316

320

317data WrappedApi where

321data WrappedApi where

318 WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,

322 WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,

319− HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>

323+ HasClient api, Client api ~ EitherT ServantError IO ()) =>

320 Proxy api -> WrappedApi

324 Proxy api -> WrappedApi

321

325

322

326

servant-client/test/Spec.hs+7−1

@@ -1 +1,7 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

1+import Servant.ClientSpec (spec, failSpec)

3+main :: IO ()

4+main = do

5+ spec

6+ failSpec

servant-examples/hackage/hackage.hs+8−11

@@ -54,29 +54,26 @@ instance FromJSON Package

54hackageAPI :: Proxy HackageAPI

55hackageAPI = Proxy

57−getUsers :: BaseUrl -> EitherT ServantError IO [UserSummary]

57+getUsers :: EitherT ServantError IO [UserSummary]

58−getUser :: Username -> BaseUrl -> EitherT ServantError IO UserDetailed

58+getUser :: Username -> EitherT ServantError IO UserDetailed

59−getPackages :: BaseUrl -> EitherT ServantError IO [Package]

59+getPackages :: EitherT ServantError IO [Package]

60−getUsers :<|> getUser :<|> getPackages = client hackageAPI

60+getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80

61−

62−run :: (BaseUrl -> r) -> r

63−run f = f (BaseUrl Http "hackage.haskell.org" 80)

65main :: IO ()

62main :: IO ()

66main = print =<< uselessNumbers

63main = print =<< uselessNumbers

68uselessNumbers :: IO (Either ServantError ())

65uselessNumbers :: IO (Either ServantError ())

69uselessNumbers = runEitherT $ do

66uselessNumbers = runEitherT $ do

70− users <- run getUsers

67+ users <- getUsers

71 liftIO . putStrLn $ show (length users) ++ " users"

68 liftIO . putStrLn $ show (length users) ++ " users"

73 user <- liftIO $ do

70 user <- liftIO $ do

74 putStrLn "Enter a valid hackage username"

71 putStrLn "Enter a valid hackage username"

75 T.getLine

72 T.getLine

76− userDetailed <- run (getUser user)

73+ userDetailed <- (getUser user)

77 liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"

74 liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"

78−

75+

79− packages <- run getPackages

76+ packages <- getPackages

80 let monadPackages = filter (isMonadPackage . packageName) packages

77 let monadPackages = filter (isMonadPackage . packageName) packages

81 liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"

78 liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"