01edb52 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Adding preliminary HTTP logic

01edb52Brendan Hay11 years ago

core/gogol-core.cabal+1−1

compare with develop

unifiedsplit

@@ -47,8 +47,8 @@ library

47 , base >= 4.7 && < 5

48 , bytestring >= 0.9

49 , conduit >= 1.1

50− , data-default-class >= 0.0.1

51 , dlist >= 0.7

50 , dlist >= 0.7

51+ , case-insensitive

52 , exceptions >= 0.6

53 , hashable >= 1.2

54 , http-client >= 0.4.4

core/src/Network/Google/Types.hs+161−127

@@ -27,12 +27,13 @@ import Control.Monad.Catch

27import Control.Monad.Trans.Resource

28import Data.Aeson

29import Data.ByteString (ByteString)

30+import qualified Data.ByteString.Char8 as BS8

30import qualified Data.ByteString.Lazy as LBS

31import qualified Data.ByteString.Lazy as LBS

32+import qualified Data.CaseInsensitive as CI

31import Data.Coerce

33import Data.Coerce

32import Data.Conduit

34import Data.Conduit

33import qualified Data.Conduit.List as CL

35import qualified Data.Conduit.List as CL

34import Data.Data

36import Data.Data

35−import Data.Default.Class (def)

36import Data.DList (DList)

37import Data.DList (DList)

37import qualified Data.DList as DList

38import qualified Data.DList as DList

38import Data.Foldable (foldMap, foldl')

39import Data.Foldable (foldMap, foldl')

@@ -42,12 +43,12 @@ import Data.Monoid

42import Data.Proxy

43import Data.Proxy

43import Data.Text (Text)

44import Data.Text (Text)

44import qualified Data.Text as Text

45import qualified Data.Text as Text

46+import qualified Data.Text.Encoding as Text

45import Data.Text.Lazy.Builder (Builder)

47import Data.Text.Lazy.Builder (Builder)

46import qualified Data.Text.Lazy.Builder as Build

48import qualified Data.Text.Lazy.Builder as Build

47import GHC.Generics

49import GHC.Generics

48import GHC.TypeLits

50import GHC.TypeLits

49import Network.HTTP.Client (HttpException, RequestBody (..))

51import Network.HTTP.Client (HttpException, RequestBody (..))

50−import qualified Network.HTTP.Client as Client

51import Network.HTTP.Media hiding (Accept)

52import Network.HTTP.Media hiding (Accept)

52import Network.HTTP.Types hiding (Header)

53import Network.HTTP.Types hiding (Header)

53import qualified Network.HTTP.Types as HTTP

54import qualified Network.HTTP.Types as HTTP

@@ -99,14 +100,11 @@ _Default = iso f Just

99 f (Just x) = x

100 f (Just x) = x

100 f Nothing = mempty

101 f Nothing = mempty

101

102

102−-- | A convenience alias to avoid type ambiguity.

103−type ClientRequest = Client.Request

104−

105−-- | A convenience alias encapsulating the common 'Response'.

106−type ClientResponse = Client.Response Stream

107−

108type Stream = ResumableSource (ResourceT IO) ByteString

103type Stream = ResumableSource (ResourceT IO) ByteString

109

104

105+newtype ServiceId = ServiceId Text

106+ deriving (Eq, Show, Data, Typeable)

107+

110data Error

108data Error

111 = TransportError HttpException

109 = TransportError HttpException

112 | SerializeError SerializeError

110 | SerializeError SerializeError

@@ -116,20 +114,20 @@ data Error

116instance Exception Error

114instance Exception Error

117

115

118data SerializeError = SerializeError'

116data SerializeError = SerializeError'

117+ { _serializeId :: !ServiceId

119− -- , _serializeHeaders :: [Header]

118+ , _serializeHeaders :: [HTTP.Header]

120− { -- _serializeAbbrev :: !Abbrev

121− -- , _serializeStatus :: !Status

119+ , _serializeStatus :: !Status

120+ , _serializeMedia :: !MediaType

122− -- , _serializeMessage :: String

121+ , _serializeMessage :: String

123 } deriving (Eq, Show, Typeable)

122 } deriving (Eq, Show, Typeable)

124

123

125−data ServiceError = ServiceError' !Status !MediaType [HTTP.Header] LBS.ByteString

124+data ServiceError = ServiceError'

126− -- _serviceAbbrev :: !Abbrev

125+ { _serviceId :: !ServiceId

127− -- , _serviceStatus :: !Status

126+ , _serviceStatus :: !Status

128− -- , _serviceHeaders :: [Header]

127+ , _serviceHeaders :: [HTTP.Header]

129− -- , _serviceCode :: !ErrorCode

128+ , _serviceMedia :: !MediaType

130− -- , _serviceMessage :: Maybe ErrorMessage

129+ , _serviceBody :: LBS.ByteString

131− -- , _serviceRequestId :: Maybe RequestId

132− deriving (Eq, Show, Typeable)

130+ } deriving (Eq, Show, Typeable)

133

131

134class AsError a where

132class AsError a where

135 -- | A general Amazonka error.

133 -- | A general Amazonka error.

@@ -164,91 +162,103 @@ instance AsError Error where

164 ServiceError e -> Right e

162 ServiceError e -> Right e

165 x -> Left x

163 x -> Left x

166

164

167−-- | An intermediary request builder.

165+data Service = Service

168−data RequestBuilder = RequestBuilder

166+ { _svcId :: !ServiceId

169− { _rqHost :: ByteString

170− , _rqBasePath :: ByteString

167+ , _svcHost :: !ByteString

171− , _rqPath :: Builder

168+ , _svcPath :: !Builder

172− , _rqQuery :: DList (Text, Maybe Text)

169+ , _svcPort :: !Int

173− , _rqHeaders :: DList (Text, Text)

170+ , _svcSecure :: !Bool

174− , _rqBody :: Maybe (MediaType, Stream)

171+ , _svcTimeout :: !(Maybe Seconds)

172+ , _svcCheck :: !(Status -> Bool)

173+ , _svcRetry :: !(ServiceError -> Bool)

175 }

174 }

176

175

177−-- | Construct a default request builder. Since the Google service descriptions

176+-- | An intermediary request builder.

178−-- have http/https in the host (rootUrl), the scheme is assumed.

177+data Request = Request

179−defaultRequest :: ByteString -- ^ Host. (rootUrl)

180− -> ByteString -- ^ Path. (servicePath)

181− -> RequestBuilder

182−defaultRequest h p = RequestBuilder

183− { _rqHost = h

184− , _rqBasePath = p

185− , _rqPath = mempty

178+ { _rqPath :: Builder

186− , _rqQuery = mempty

179+ , _rqQuery :: DList (ByteString, Maybe ByteString)

187− , _rqHeaders = mempty

180+ , _rqHeaders :: DList (HeaderName, ByteString)

188− , _rqBody = Nothing

181+ , _rqBody :: Maybe (MediaType, RequestBody)

189 }

182 }

190

183

191−appendPath :: RequestBuilder -> Builder -> RequestBuilder

184+appendPath :: Request -> Builder -> Request

192appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }

185appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }

193

186

194−appendPaths :: ToText a => RequestBuilder -> [a] -> RequestBuilder

187+appendPaths :: ToText a => Request -> [a] -> Request

195appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)

188appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)

196

189

197−appendQuery :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder

190+appendQuery :: Request -> ByteString -> Maybe Text -> Request

191+appendQuery rq k v = rq

198−appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }

192+ { _rqQuery = DList.snoc (_rqQuery rq) (k, Text.encodeUtf8 <$> v)

193+ }

199

194

200−appendHeader :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder

195+appendHeader :: Request -> ByteString -> Maybe Text -> Request

201appendHeader rq _ Nothing = rq

196appendHeader rq _ Nothing = rq

197+appendHeader rq k (Just v) = rq

202−appendHeader rq k (Just v) = rq { _rqHeaders = DList.snoc (_rqHeaders rq) (k, v) }

198+ { _rqHeaders = DList.snoc (_rqHeaders rq) (CI.mk k, Text.encodeUtf8 v)

199+ }

203

200

204−setStream :: RequestBuilder -> MediaType -> Stream -> RequestBuilder

201+setBody :: Request -> MediaType -> RequestBody -> Request

205−setStream rq c x = rq { _rqBody = Just (c, x) }

202+setBody rq c x = rq { _rqBody = Just (c, x) }

206

203

207-- | A materialised 'http-client' request and associated response parser.

204-- | A materialised 'http-client' request and associated response parser.

208data Client a = Client

205data Client a = Client

209− { _clientAccept :: Maybe MediaType

206+ { _cliAccept :: Maybe MediaType

207+ , _cliMethod :: Method

210− , _clientCheck :: Int -> Bool

208+ , _cliCheck :: Int -> Bool

209+ , _cliService :: Service

210+ , _cliRequest :: Request

211− , _clientResponse :: Stream -> ResourceT IO (Either SerializeError a)

211+ , _cliResponse :: Stream -> ResourceT IO (Either SerializeError a)

212− , _clientRequest :: ClientRequest

213 }

212 }

214

213

214+mime :: FromStream c a

215+ => Proxy c

216+ -> Method

217+ -> [Int]

218+ -> Request

219+ -> Service

220+ -> Client a

221+mime p = client (fromStream p) (Just (contentType p))

222+

223+discard :: Method

224+ -> [Int]

225+ -> Request

226+ -> Service

227+ -> Client ()

228+discard = client (\b -> closeResumableSource b >> pure (Right ())) Nothing

229+

215−clientRequest :: (Stream -> ResourceT IO (Either SerializeError a))

230+client :: (Stream -> ResourceT IO (Either SerializeError a))

216− -> Maybe MediaType

231+ -> Maybe MediaType

217− -> Method

232+ -> Method

218− -> [Int]

233+ -> [Int]

219− -> RequestBuilder

234+ -> Request

235+ -> Service

220− -> Client a

236+ -> Client a

221−clientRequest f cs m ns rq = Client

237+client f cs m ns rq s = Client

222− { _clientAccept = cs

238+ { _cliAccept = cs

223− , _clientCheck = (`elem` ns)

239+ , _cliMethod = m

224− , _clientResponse = f

240+ , _cliCheck = (`elem` ns)

225− , _clientRequest = def

241+ , _cliService = s

226− { Client.method = m

242+ , _cliRequest = rq

227− , Client.checkStatus = \_ _ _ -> Nothing

243+ , _cliResponse = f

228− }

229 }

244 }

230

245

231−clientMime :: FromStream c a

246+class Accept c => ToBody c a where

232− => Proxy c

247+ toBody :: Proxy c -> a -> RequestBody

233− -> Method

234− -> [Int]

235− -> RequestBuilder

236− -> Client a

237−clientMime p = clientRequest (fromStream p) (Just (contentType p))

238

248

239−clientEmpty :: Method -> [Int] -> RequestBuilder -> Client ()

249+instance ToBody OctetStream RequestBody where

240−clientEmpty = clientRequest go Nothing

250+ toBody Proxy = id

241− where

242− go b = closeResumableSource b >> pure (Right ())

243

251

244−class Accept c => ToStream c a where

252+instance ToBody OctetStream ByteString where toBody Proxy = RequestBodyBS

245− toStream :: Proxy c -> a -> Stream

253+instance ToBody OctetStream LBS.ByteString where toBody Proxy = RequestBodyLBS

254+instance ToBody PlainText ByteString where toBody Proxy = RequestBodyBS

255+instance ToBody PlainText LBS.ByteString where toBody Proxy = RequestBodyLBS

246

256

247−instance ToStream OctetStream Stream where

257+instance ToJSON a => ToBody JSON a where

248− toStream Proxy = id

258+ toBody Proxy = RequestBodyLBS . encode

249

259

250−instance ToJSON a => ToStream JSON a where

260+instance ToBody JSON Value where

251− toStream Proxy = newResumableSource . CL.sourceList . LBS.toChunks . encode

261+ toBody Proxy = RequestBodyLBS . encode

252

262

253class Accept c => FromStream c a where

263class Accept c => FromStream c a where

254 fromStream :: Proxy c

264 fromStream :: Proxy c

@@ -268,13 +278,12 @@ instance FromJSON a => FromStream JSON a where

268class GoogleRequest a where

278class GoogleRequest a where

269 type Rs a :: *

279 type Rs a :: *

270

280

271− request :: a -> Client (Rs a)

281+ requestClient :: a -> Client (Rs a)

272− requestWith :: RequestBuilder -> a -> Client (Rs a)

273

282

274class GoogleClient fn where

283class GoogleClient fn where

275 type Fn fn :: *

284 type Fn fn :: *

276

285

277− clientBuild :: Proxy fn -> RequestBuilder -> Fn fn

286+ buildClient :: Proxy fn -> Request -> Fn fn

278

287

279-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.

288-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.

280data Captures (s :: Symbol) a

289data Captures (s :: Symbol) a

@@ -340,15 +349,15 @@ instance ( MimeRender c m

340instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where

349instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where

341 type Fn (s :> fn) = Fn fn

350 type Fn (s :> fn) = Fn fn

342

351

343− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) $

352+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn) $

344 appendPath rq (buildSymbol (Proxy :: Proxy s))

353 appendPath rq (buildSymbol (Proxy :: Proxy s))

345

354

346instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where

355instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where

347 type Fn (a :<|> b) = Fn a :<|> Fn b

356 type Fn (a :<|> b) = Fn a :<|> Fn b

348

357

349− clientBuild Proxy rq =

358+ buildClient Proxy rq =

350− clientBuild (Proxy :: Proxy a) rq

359+ buildClient (Proxy :: Proxy a) rq

351− :<|> clientBuild (Proxy :: Proxy b) rq

360+ :<|> buildClient (Proxy :: Proxy b) rq

352

361

353instance ( KnownSymbol s

362instance ( KnownSymbol s

354 , ToText a

363 , ToText a

@@ -356,7 +365,7 @@ instance ( KnownSymbol s

356 ) => GoogleClient (Capture s a :> fn) where

365 ) => GoogleClient (Capture s a :> fn) where

357 type Fn (Capture s a :> fn) = a -> Fn fn

366 type Fn (Capture s a :> fn) = a -> Fn fn

358

367

359− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)

368+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)

360 . appendPath rq

369 . appendPath rq

361 . buildText

370 . buildText

362

371

@@ -366,7 +375,7 @@ instance ( KnownSymbol s

366 ) => GoogleClient (Captures s a :> fn) where

375 ) => GoogleClient (Captures s a :> fn) where

367 type Fn (Captures s a :> fn) = [a] -> Fn fn

376 type Fn (Captures s a :> fn) = [a] -> Fn fn

368

377

369− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)

378+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)

370 . appendPaths rq

379 . appendPaths rq

371

380

372instance ( KnownSymbol s

381instance ( KnownSymbol s

@@ -376,7 +385,7 @@ instance ( KnownSymbol s

376 ) => GoogleClient (CaptureMode s m a :> fn) where

385 ) => GoogleClient (CaptureMode s m a :> fn) where

377 type Fn (CaptureMode s m a :> fn) = a -> Fn fn

386 type Fn (CaptureMode s m a :> fn) = a -> Fn fn

378

387

379− clientBuild Proxy rq x = clientBuild (Proxy :: Proxy fn)

388+ buildClient Proxy rq x = buildClient (Proxy :: Proxy fn)

380 . appendPath rq

389 . appendPath rq

381 $ buildText x <> buildSymbol (Proxy :: Proxy m)

390 $ buildText x <> buildSymbol (Proxy :: Proxy m)

382

391

@@ -386,12 +395,12 @@ instance ( KnownSymbol s

386 ) => GoogleClient (QueryParam s a :> fn) where

395 ) => GoogleClient (QueryParam s a :> fn) where

387 type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn

396 type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn

388

397

389− clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $

398+ buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $

390 case mx of

399 case mx of

391 Nothing -> rq

400 Nothing -> rq

392 Just x -> appendQuery rq k v

401 Just x -> appendQuery rq k v

393 where

402 where

394− k = textSymbol (Proxy :: Proxy s)

403+ k = byteSymbol (Proxy :: Proxy s)

395 v = Just (toText x)

404 v = Just (toText x)

396

405

397instance ( KnownSymbol s

406instance ( KnownSymbol s

@@ -400,11 +409,11 @@ instance ( KnownSymbol s

400 ) => GoogleClient (QueryParams s a :> fn) where

409 ) => GoogleClient (QueryParams s a :> fn) where

401 type Fn (QueryParams s a :> fn) = [a] -> Fn fn

410 type Fn (QueryParams s a :> fn) = [a] -> Fn fn

402

411

403− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) . foldl' go rq

412+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn) . foldl' go rq

404 where

413 where

405 go r = appendQuery r k . Just . toText

414 go r = appendQuery r k . Just . toText

406

415

407− k = textSymbol (Proxy :: Proxy s)

416+ k = byteSymbol (Proxy :: Proxy s)

408

417

409instance ( KnownSymbol s

418instance ( KnownSymbol s

410 , ToText a

419 , ToText a

@@ -412,94 +421,94 @@ instance ( KnownSymbol s

412 ) => GoogleClient (Header s a :> fn) where

421 ) => GoogleClient (Header s a :> fn) where

413 type Fn (Header s a :> fn) = Maybe a -> Fn fn

422 type Fn (Header s a :> fn) = Maybe a -> Fn fn

414

423

415− clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $

424+ buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $

416 case mx of

425 case mx of

417 Nothing -> rq

426 Nothing -> rq

418 Just x -> appendHeader rq k v

427 Just x -> appendHeader rq k v

419 where

428 where

420− k = textSymbol (Proxy :: Proxy s)

429+ k = byteSymbol (Proxy :: Proxy s)

421 v = Just (toText x)

430 v = Just (toText x)

422

431

423−instance ( ToStream c a

432+instance ( ToBody c a

424 , GoogleClient fn

433 , GoogleClient fn

425 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where

434 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where

426 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn

435 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn

427

436

428− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)

437+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)

429− . setStream rq (contentType p)

438+ . setBody rq (contentType p)

430− . toStream p

439+ . toBody p

431 where

440 where

432 p = Proxy :: Proxy c

441 p = Proxy :: Proxy c

433

442

434instance {-# OVERLAPPABLE #-}

443instance {-# OVERLAPPABLE #-}

435 FromStream c a => GoogleClient (Get (c ': cs) a) where

444 FromStream c a => GoogleClient (Get (c ': cs) a) where

436− type Fn (Get (c ': cs) a) = Client a

445+ type Fn (Get (c ': cs) a) = Service -> Client a

437

446

438− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodGet [200, 203]

447+ buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203]

439

448

440instance {-# OVERLAPPING #-}

449instance {-# OVERLAPPING #-}

441 GoogleClient (Get (c ': cs) ()) where

450 GoogleClient (Get (c ': cs) ()) where

442− type Fn (Get (c ': cs) ()) = Client ()

451+ type Fn (Get (c ': cs) ()) = Service -> Client ()

443

452

444− clientBuild Proxy = clientEmpty methodGet [204]

453+ buildClient Proxy = discard methodGet [204]

445

454

446instance {-# OVERLAPPABLE #-}

455instance {-# OVERLAPPABLE #-}

447 (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where

456 (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where

448− type Fn (Post cs' a) = Client a

457+ type Fn (Post cs' a) = Service -> Client a

449

458

450− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPost [200, 201]

459+ buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201]

451

460

452instance {-# OVERLAPPING #-}

461instance {-# OVERLAPPING #-}

453 GoogleClient (Post cs ()) where

462 GoogleClient (Post cs ()) where

454− type Fn (Post cs ()) = Client ()

463+ type Fn (Post cs ()) = Service -> Client ()

455

464

456− clientBuild Proxy = clientEmpty methodPost [204]

465+ buildClient Proxy = discard methodPost [204]

457

466

458instance {-# OVERLAPPABLE #-}

467instance {-# OVERLAPPABLE #-}

459 FromStream c a => GoogleClient (Put (c ': cs) a) where

468 FromStream c a => GoogleClient (Put (c ': cs) a) where

460− type Fn (Put (c ': cs) a) = Client a

469+ type Fn (Put (c ': cs) a) = Service -> Client a

461

470

462− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPut [200, 201]

471+ buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201]

463

472

464instance {-# OVERLAPPING #-}

473instance {-# OVERLAPPING #-}

465 GoogleClient (Put (c ': cs) ()) where

474 GoogleClient (Put (c ': cs) ()) where

466− type Fn (Put (c ': cs) ()) = Client ()

475+ type Fn (Put (c ': cs) ()) = Service -> Client ()

467

476

468− clientBuild Proxy = clientEmpty methodPut [204]

477+ buildClient Proxy = discard methodPut [204]

469

478

470instance {-# OVERLAPPABLE #-}

479instance {-# OVERLAPPABLE #-}

471 FromStream c a => GoogleClient (Patch (c ': cs) a) where

480 FromStream c a => GoogleClient (Patch (c ': cs) a) where

472− type Fn (Patch (c ': cs) a) = Client a

481+ type Fn (Patch (c ': cs) a) = Service -> Client a

473

482

474− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPatch [200, 201]

483+ buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201]

475

484

476instance {-# OVERLAPPING #-}

485instance {-# OVERLAPPING #-}

477 GoogleClient (Patch (c ': cs) ()) where

486 GoogleClient (Patch (c ': cs) ()) where

478− type Fn (Patch (c ': cs) ()) = Client ()

487+ type Fn (Patch (c ': cs) ()) = Service -> Client ()

479

488

480− clientBuild Proxy = clientEmpty methodPatch [204]

489+ buildClient Proxy = discard methodPatch [204]

481

490

482instance {-# OVERLAPPABLE #-}

491instance {-# OVERLAPPABLE #-}

483 FromStream c a => GoogleClient (Delete (c ': cs) a) where

492 FromStream c a => GoogleClient (Delete (c ': cs) a) where

484− type Fn (Delete (c ': cs) a) = Client a

493+ type Fn (Delete (c ': cs) a) = Service -> Client a

485

494

486− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodDelete [200, 202]

495+ buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202]

487

496

488instance {-# OVERLAPPING #-}

497instance {-# OVERLAPPING #-}

489 GoogleClient (Delete (c ': cs) ()) where

498 GoogleClient (Delete (c ': cs) ()) where

490− type Fn (Delete (c ': cs) ()) = Client ()

499+ type Fn (Delete (c ': cs) ()) = Service -> Client ()

491

500

492− clientBuild Proxy = clientEmpty methodDelete [204]

501+ buildClient Proxy = discard methodDelete [204]

493

502

494-- perform :: Accept

503-- perform :: Accept

495-- -> (Stream -> Client (Either SerializeError a))

504-- -> (Stream -> Client (Either SerializeError a))

496-- -> Method

505-- -> Method

497-- -> [Int]

506-- -> [Int]

498−-- -> RequestBuilder

507+-- -> Request

499-- -> Client a

508-- -> Client a

500-- perform a meth ns f rq = undefined -- do

509-- perform a meth ns f rq = undefined -- do

501 -- m <- ask

510 -- m <- ask

502− -- x <- lift . try $ Client.http m (clientRequest meth a rq)

511+ -- x <- lift . try $ Client.http m (client meth a rq)

503 -- either (failure . TransportError) success x

512 -- either (failure . TransportError) success x

504 -- where

513 -- where

505 -- failure = pure . Left

514 -- failure = pure . Left

@@ -542,5 +551,30 @@ buildText = Build.fromText . toText

542buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder

551buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder

543buildSymbol = Build.fromString . symbolVal

552buildSymbol = Build.fromString . symbolVal

544

553

545−textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text

554+byteSymbol :: forall n proxy. KnownSymbol n => proxy n -> ByteString

546−textSymbol = Text.pack . symbolVal

555+byteSymbol = BS8.pack . symbolVal

556+

557+-- | An integral value representing seconds.

558+newtype Seconds = Seconds Int

559+ deriving

560+ ( Eq

561+ , Ord

562+ , Read

563+ , Show

564+ , Enum

565+ , Num

566+ , Bounded

567+ , Integral

568+ , Real

569+ , Data

570+ , Typeable

571+ , Generic

572+ )

573+

574+seconds :: Seconds -> Int

575+seconds (Seconds n)

576+ | n < 0 = 0

577+ | otherwise = n

578+

579+microseconds :: Seconds -> Int

580+microseconds = (1000000 *) . seconds

gen/src/Gen/Syntax.hs+1−1

@@ -115,7 +115,7 @@ verbAlias n m

115 [TyApp (TyApp (TyCon "ReqBody") json) (tycon (ref b))]

116

117 | _mSupportsMediaUpload m =

118− [TyApp (TyApp (TyCon "ReqBody") octet) (TyCon "Stream")]

118+ [TyApp (TyApp (TyCon "ReqBody") octet) (TyCon "RequestBody")]

119

120 | otherwise = []

121

gogol/gogol.cabal+10−2

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

32 Network.Google.Env

34 other-modules:

35− Network.Google.Internal.Types

35+ Network.Google.Internal.HTTP

36+ , Network.Google.Internal.Types

37 build-depends:

38 build-depends:

38 base >= 4.7 && < 5

39 base >= 4.7 && < 5

@@ -46,4 +47,11 @@ library

46 , retry

47 , retry

47 , time

48 , time

48 , transformers

49 , transformers

50+ , data-default-class >= 0.0.1

49− , transformers-base

51+ , transformers-base

52+ , http-types

53+ , http-media

54+ , text

55+ , mmorph

56+ , conduit

57+ , bifunctors

gogol/src/Network/Google.hs+2−2

@@ -100,5 +100,5 @@ runGoogle e m = liftResourceT $ runReaderT (unGoogle m) e -- (e ^. environment)

100send :: GoogleRequest a => a -> m (Rs a)

101send = undefined

102

103−download :: GoogleRequest (MediaDownload a) => a -> m (Rs (MediaDownload a))

103+-- download :: GoogleRequest (MediaDownload a) => a -> m (Rs (MediaDownload a))

104−download = send . MediaDownload

104+-- download = send . MediaDownload

gogol/src/Network/Google/Internal/HTTP.hsnew file+91

@@ -0,0 +1,91 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards #-}

4+-- |

5+-- Module : Network.Google.Internal.HTTP

7+-- License : Mozilla Public License, v. 2.0.

8+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>

9+-- Stability : provisional

10+-- Portability : non-portable (GHC extensions)

11+--

12+module Network.Google.Internal.HTTP where

13+

14+import Control.Applicative

15+import Control.Lens

16+import Control.Monad

17+import Control.Monad.Catch

18+import Control.Monad.IO.Class

19+import Control.Monad.Morph

20+import Data.Bifunctor

21+-- import Control.Monad.State.Lazy

22+import Control.Monad.Trans.Resource

23+import Control.Retry

24+import Data.Conduit

25+import Data.Default.Class

26+import Data.Monoid

27+import qualified Data.Text as Text

28+import qualified Data.Text.Encoding as Text

29+import qualified Data.Text.Lazy as LText

30+import qualified Data.Text.Lazy.Builder as Build

31+import GHC.Exts (toList)

32+import Network.Google.Auth

33+import Network.Google.Env

34+import Network.Google.Internal.Types

35+import Network.Google.Types

36+import Network.HTTP.Conduit

37+import qualified Network.HTTP.Conduit as Client

38+import Network.HTTP.Media

39+import Network.HTTP.Types

40+

41+-- | The 'Service' is configured + unwrapped at this point.

42+perform :: (MonadCatch m, MonadBaseControl IO m, MonadResource m, GoogleRequest a)

43+ => Env

44+ -> a

45+ -> m (Either Error (Rs a))

46+perform Env{..} x = catches go handlers

47+ where

48+ go = liftResourceT $ do

49+ rs <- http rq _envManager

50+ first SerializeError <$> _cliResponse (responseBody rs)

51+

52+ rq = def

53+ { Client.host = _svcHost

54+ , Client.port = _svcPort

55+ , Client.secure = _svcSecure

56+ , Client.checkStatus = \_ _ _ -> Nothing

57+ -- mix with Env timeout

58+-- , Client.responseTimeout = microseconds <$> _svcTimeout

59+ , Client.method = _cliMethod

60+ , Client.path = path

61+ , Client.queryString = renderQuery True (toList _rqQuery)

62+ , Client.requestHeaders = accept (content (toList _rqHeaders))

63+ , Client.requestBody = body

64+ }

65+

66+ accept

67+ | Just t <- _cliAccept = ((hAccept, renderHeader t) :)

68+ | otherwise = id

69+

70+ content

71+ | Just (t, _) <- _rqBody = ((hContentType, renderHeader t) :)

72+ | otherwise = id

73+

74+ body | Just (_, b) <- _rqBody = b

75+ | otherwise = mempty

76+

77+ path = Text.encodeUtf8

78+ . LText.toStrict

79+ $ Build.toLazyText (_svcPath <> _rqPath)

80+

81+

82+ Request {..} = _cliRequest

83+ Service {..} = _cliService

84+ Client {..} = requestClient x

85+

86+ handlers =

87+ [ Handler $ err

88+ , Handler $ err . TransportError

89+ ]

90+ where

91+ err e = return (Left e) -- logError _envLogger e >>

gogol/src/Network/Google/Internal/Types.hs−25

@@ -14,28 +14,3 @@ module Network.Google.Internal.Types where

15import Data.Data

16import GHC.Generics

17−

18−-- | An integral value representing seconds.

19−newtype Seconds = Seconds Int

20− deriving

21− ( Eq

22− , Ord

23− , Read

24− , Show

25− , Enum

26− , Num

27− , Bounded

28− , Integral

29− , Real

30− , Data

31− , Typeable

32− , Generic

33− )

34−

35−seconds :: Seconds -> Int

36−seconds (Seconds n)

37− | n < 0 = 0

38− | otherwise = n

39−

40−microseconds :: Seconds -> Int

41−microseconds = (1000000 *) . seconds