@@ -27,12 +27,13 @@ import Control.Monad.Catch
2727import Control.Monad.Trans.Resource
2828import Data.Aeson
2929import Data.ByteString (ByteString)
30+import qualified Data.ByteString.Char8 as BS8
3031import qualified Data.ByteString.Lazy as LBS
32+import qualified Data.CaseInsensitive as CI
3133import Data.Coerce
3234import Data.Conduit
3335import qualified Data.Conduit.List as CL
3436import Data.Data
35−import Data.Default.Class (def)
3637import Data.DList (DList)
3738import qualified Data.DList as DList
3839import Data.Foldable (foldMap, foldl')
@@ -42,12 +43,12 @@ import Data.Monoid
4243import Data.Proxy
4344import Data.Text (Text)
4445import qualified Data.Text as Text
46+import qualified Data.Text.Encoding as Text
4547import Data.Text.Lazy.Builder (Builder)
4648import qualified Data.Text.Lazy.Builder as Build
4749import GHC.Generics
4850import GHC.TypeLits
4951import Network.HTTP.Client (HttpException, RequestBody (..))
50−import qualified Network.HTTP.Client as Client
5152import Network.HTTP.Media hiding (Accept)
5253import Network.HTTP.Types hiding (Header)
5354import qualified Network.HTTP.Types as HTTP
@@ -99,14 +100,11 @@ _Default = iso f Just
99100 f (Just x) = x
100101 f Nothing = mempty
101102
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−
108103type Stream = ResumableSource (ResourceT IO) ByteString
109104
105+newtype ServiceId = ServiceId Text
106+ deriving (Eq, Show, Data, Typeable)
107+
110108data Error
111109 = TransportError HttpException
112110 | SerializeError SerializeError
@@ -116,20 +114,20 @@ data Error
116114instance Exception Error
117115
118116data SerializeError = SerializeError'
119− -- , _serializeHeaders :: [Header]
120− { -- _serializeAbbrev :: !Abbrev
121− -- , _serializeStatus :: !Status
122− -- , _serializeMessage :: String
117+ { _serializeId :: !ServiceId
118+ , _serializeHeaders :: [HTTP.Header]
119+ , _serializeStatus :: !Status
120+ , _serializeMedia :: !MediaType
121+ , _serializeMessage :: String
123122 } deriving (Eq, Show, Typeable)
124123
125−data ServiceError = ServiceError' !Status !MediaType [HTTP.Header] LBS.ByteString
126− -- _serviceAbbrev :: !Abbrev
127− -- , _serviceStatus :: !Status
128− -- , _serviceHeaders :: [Header]
129− -- , _serviceCode :: !ErrorCode
130− -- , _serviceMessage :: Maybe ErrorMessage
131− -- , _serviceRequestId :: Maybe RequestId
132− deriving (Eq, Show, Typeable)
124+data ServiceError = ServiceError'
125+ { _serviceId :: !ServiceId
126+ , _serviceStatus :: !Status
127+ , _serviceHeaders :: [HTTP.Header]
128+ , _serviceMedia :: !MediaType
129+ , _serviceBody :: LBS.ByteString
130+ } deriving (Eq, Show, Typeable)
133131
134132class AsError a where
135133 -- | A general Amazonka error.
@@ -164,91 +162,103 @@ instance AsError Error where
164162 ServiceError e -> Right e
165163 x -> Left x
166164
167−-- | An intermediary request builder.
168−data RequestBuilder = RequestBuilder
169− { _rqHost :: ByteString
170− , _rqBasePath :: ByteString
171− , _rqPath :: Builder
172− , _rqQuery :: DList (Text, Maybe Text)
173− , _rqHeaders :: DList (Text, Text)
174− , _rqBody :: Maybe (MediaType, Stream)
165+data Service = Service
166+ { _svcId :: !ServiceId
167+ , _svcHost :: !ByteString
168+ , _svcPath :: !Builder
169+ , _svcPort :: !Int
170+ , _svcSecure :: !Bool
171+ , _svcTimeout :: !(Maybe Seconds)
172+ , _svcCheck :: !(Status -> Bool)
173+ , _svcRetry :: !(ServiceError -> Bool)
175174 }
176175
177−-- | Construct a default request builder. Since the Google service descriptions
178−-- have http/https in the host (rootUrl), the scheme is assumed.
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
186− , _rqQuery = mempty
187− , _rqHeaders = mempty
188− , _rqBody = Nothing
176+-- | An intermediary request builder.
177+data Request = Request
178+ { _rqPath :: Builder
179+ , _rqQuery :: DList (ByteString, Maybe ByteString)
180+ , _rqHeaders :: DList (HeaderName, ByteString)
181+ , _rqBody :: Maybe (MediaType, RequestBody)
189182 }
190183
191−appendPath :: RequestBuilder -> Builder -> RequestBuilder
184+appendPath :: Request -> Builder -> Request
192185appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
193186
194−appendPaths :: ToText a => RequestBuilder -> [a] -> RequestBuilder
187+appendPaths :: ToText a => Request -> [a] -> Request
195188appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
196189
197−appendQuery :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder
198−appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
190+appendQuery :: Request -> ByteString -> Maybe Text -> Request
191+appendQuery rq k v = rq
192+ { _rqQuery = DList.snoc (_rqQuery rq) (k, Text.encodeUtf8 <$> v)
193+ }
199194
200−appendHeader :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder
195+appendHeader :: Request -> ByteString -> Maybe Text -> Request
201196appendHeader rq _ Nothing = rq
202−appendHeader rq k (Just v) = rq { _rqHeaders = DList.snoc (_rqHeaders rq) (k, v) }
197+appendHeader rq k (Just v) = rq
198+ { _rqHeaders = DList.snoc (_rqHeaders rq) (CI.mk k, Text.encodeUtf8 v)
199+ }
203200
204−setStream :: RequestBuilder -> MediaType -> Stream -> RequestBuilder
205−setStream rq c x = rq { _rqBody = Just (c, x) }
201+setBody :: Request -> MediaType -> RequestBody -> Request
202+setBody rq c x = rq { _rqBody = Just (c, x) }
206203
207204-- | A materialised 'http-client' request and associated response parser.
208205data Client a = Client
209− { _clientAccept :: Maybe MediaType
210− , _clientCheck :: Int -> Bool
211− , _clientResponse :: Stream -> ResourceT IO (Either SerializeError a)
212− , _clientRequest :: ClientRequest
206+ { _cliAccept :: Maybe MediaType
207+ , _cliMethod :: Method
208+ , _cliCheck :: Int -> Bool
209+ , _cliService :: Service
210+ , _cliRequest :: Request
211+ , _cliResponse :: Stream -> ResourceT IO (Either SerializeError a)
213212 }
214213
215−clientRequest :: (Stream -> ResourceT IO (Either SerializeError a))
216− -> Maybe MediaType
217− -> Method
218− -> [Int]
219− -> RequestBuilder
220− -> Client a
221−clientRequest f cs m ns rq = Client
222− { _clientAccept = cs
223− , _clientCheck = (`elem` ns)
224− , _clientResponse = f
225− , _clientRequest = def
226− { Client.method = m
227− , Client.checkStatus = \_ _ _ -> Nothing
228− }
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+
230+client :: (Stream -> ResourceT IO (Either SerializeError a))
231+ -> Maybe MediaType
232+ -> Method
233+ -> [Int]
234+ -> Request
235+ -> Service
236+ -> Client a
237+client f cs m ns rq s = Client
238+ { _cliAccept = cs
239+ , _cliMethod = m
240+ , _cliCheck = (`elem` ns)
241+ , _cliService = s
242+ , _cliRequest = rq
243+ , _cliResponse = f
229244 }
230245
231−clientMime :: FromStream c a
232− => Proxy c
233− -> Method
234− -> [Int]
235− -> RequestBuilder
236− -> Client a
237−clientMime p = clientRequest (fromStream p) (Just (contentType p))
246+class Accept c => ToBody c a where
247+ toBody :: Proxy c -> a -> RequestBody
238248
239−clientEmpty :: Method -> [Int] -> RequestBuilder -> Client ()
240−clientEmpty = clientRequest go Nothing
241− where
242− go b = closeResumableSource b >> pure (Right ())
249+instance ToBody OctetStream RequestBody where
250+ toBody Proxy = id
243251
244−class Accept c => ToStream c a where
245− toStream :: Proxy c -> a -> Stream
252+instance ToBody OctetStream ByteString where toBody Proxy = RequestBodyBS
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
246256
247−instance ToStream OctetStream Stream where
248− toStream Proxy = id
257+instance ToJSON a => ToBody JSON a where
258+ toBody Proxy = RequestBodyLBS . encode
249259
250−instance ToJSON a => ToStream JSON a where
251− toStream Proxy = newResumableSource . CL.sourceList . LBS.toChunks . encode
260+instance ToBody JSON Value where
261+ toBody Proxy = RequestBodyLBS . encode
252262
253263class Accept c => FromStream c a where
254264 fromStream :: Proxy c
@@ -268,13 +278,12 @@ instance FromJSON a => FromStream JSON a where
268278class GoogleRequest a where
269279 type Rs a :: *
270280
271− request :: a -> Client (Rs a)
272− requestWith :: RequestBuilder -> a -> Client (Rs a)
281+ requestClient :: a -> Client (Rs a)
273282
274283class GoogleClient fn where
275284 type Fn fn :: *
276285
277− clientBuild :: Proxy fn -> RequestBuilder -> Fn fn
286+ buildClient :: Proxy fn -> Request -> Fn fn
278287
279288-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.
280289data Captures (s :: Symbol) a
@@ -340,15 +349,15 @@ instance ( MimeRender c m
340349instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where
341350 type Fn (s :> fn) = Fn fn
342351
343− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) $
352+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn) $
344353 appendPath rq (buildSymbol (Proxy :: Proxy s))
345354
346355instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where
347356 type Fn (a :<|> b) = Fn a :<|> Fn b
348357
349− clientBuild Proxy rq =
350− clientBuild (Proxy :: Proxy a) rq
351− :<|> clientBuild (Proxy :: Proxy b) rq
358+ buildClient Proxy rq =
359+ buildClient (Proxy :: Proxy a) rq
360+ :<|> buildClient (Proxy :: Proxy b) rq
352361
353362instance ( KnownSymbol s
354363 , ToText a
@@ -356,7 +365,7 @@ instance ( KnownSymbol s
356365 ) => GoogleClient (Capture s a :> fn) where
357366 type Fn (Capture s a :> fn) = a -> Fn fn
358367
359− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
368+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)
360369 . appendPath rq
361370 . buildText
362371
@@ -366,7 +375,7 @@ instance ( KnownSymbol s
366375 ) => GoogleClient (Captures s a :> fn) where
367376 type Fn (Captures s a :> fn) = [a] -> Fn fn
368377
369− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
378+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)
370379 . appendPaths rq
371380
372381instance ( KnownSymbol s
@@ -376,7 +385,7 @@ instance ( KnownSymbol s
376385 ) => GoogleClient (CaptureMode s m a :> fn) where
377386 type Fn (CaptureMode s m a :> fn) = a -> Fn fn
378387
379− clientBuild Proxy rq x = clientBuild (Proxy :: Proxy fn)
388+ buildClient Proxy rq x = buildClient (Proxy :: Proxy fn)
380389 . appendPath rq
381390 $ buildText x <> buildSymbol (Proxy :: Proxy m)
382391
@@ -386,12 +395,12 @@ instance ( KnownSymbol s
386395 ) => GoogleClient (QueryParam s a :> fn) where
387396 type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn
388397
389− clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $
398+ buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $
390399 case mx of
391400 Nothing -> rq
392401 Just x -> appendQuery rq k v
393402 where
394− k = textSymbol (Proxy :: Proxy s)
403+ k = byteSymbol (Proxy :: Proxy s)
395404 v = Just (toText x)
396405
397406instance ( KnownSymbol s
@@ -400,11 +409,11 @@ instance ( KnownSymbol s
400409 ) => GoogleClient (QueryParams s a :> fn) where
401410 type Fn (QueryParams s a :> fn) = [a] -> Fn fn
402411
403− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) . foldl' go rq
412+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn) . foldl' go rq
404413 where
405414 go r = appendQuery r k . Just . toText
406415
407− k = textSymbol (Proxy :: Proxy s)
416+ k = byteSymbol (Proxy :: Proxy s)
408417
409418instance ( KnownSymbol s
410419 , ToText a
@@ -412,94 +421,94 @@ instance ( KnownSymbol s
412421 ) => GoogleClient (Header s a :> fn) where
413422 type Fn (Header s a :> fn) = Maybe a -> Fn fn
414423
415− clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $
424+ buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $
416425 case mx of
417426 Nothing -> rq
418427 Just x -> appendHeader rq k v
419428 where
420− k = textSymbol (Proxy :: Proxy s)
429+ k = byteSymbol (Proxy :: Proxy s)
421430 v = Just (toText x)
422431
423−instance ( ToStream c a
432+instance ( ToBody c a
424433 , GoogleClient fn
425434 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where
426435 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn
427436
428− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
429− . setStream rq (contentType p)
430− . toStream p
437+ buildClient Proxy rq = buildClient (Proxy :: Proxy fn)
438+ . setBody rq (contentType p)
439+ . toBody p
431440 where
432441 p = Proxy :: Proxy c
433442
434443instance {-# OVERLAPPABLE #-}
435444 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
437446
438− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodGet [200, 203]
447+ buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203]
439448
440449instance {-# OVERLAPPING #-}
441450 GoogleClient (Get (c ': cs) ()) where
442− type Fn (Get (c ': cs) ()) = Client ()
451+ type Fn (Get (c ': cs) ()) = Service -> Client ()
443452
444− clientBuild Proxy = clientEmpty methodGet [204]
453+ buildClient Proxy = discard methodGet [204]
445454
446455instance {-# OVERLAPPABLE #-}
447456 (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
449458
450− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPost [200, 201]
459+ buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201]
451460
452461instance {-# OVERLAPPING #-}
453462 GoogleClient (Post cs ()) where
454− type Fn (Post cs ()) = Client ()
463+ type Fn (Post cs ()) = Service -> Client ()
455464
456− clientBuild Proxy = clientEmpty methodPost [204]
465+ buildClient Proxy = discard methodPost [204]
457466
458467instance {-# OVERLAPPABLE #-}
459468 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
461470
462− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPut [200, 201]
471+ buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201]
463472
464473instance {-# OVERLAPPING #-}
465474 GoogleClient (Put (c ': cs) ()) where
466− type Fn (Put (c ': cs) ()) = Client ()
475+ type Fn (Put (c ': cs) ()) = Service -> Client ()
467476
468− clientBuild Proxy = clientEmpty methodPut [204]
477+ buildClient Proxy = discard methodPut [204]
469478
470479instance {-# OVERLAPPABLE #-}
471480 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
473482
474− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPatch [200, 201]
483+ buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201]
475484
476485instance {-# OVERLAPPING #-}
477486 GoogleClient (Patch (c ': cs) ()) where
478− type Fn (Patch (c ': cs) ()) = Client ()
487+ type Fn (Patch (c ': cs) ()) = Service -> Client ()
479488
480− clientBuild Proxy = clientEmpty methodPatch [204]
489+ buildClient Proxy = discard methodPatch [204]
481490
482491instance {-# OVERLAPPABLE #-}
483492 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
485494
486− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodDelete [200, 202]
495+ buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202]
487496
488497instance {-# OVERLAPPING #-}
489498 GoogleClient (Delete (c ': cs) ()) where
490− type Fn (Delete (c ': cs) ()) = Client ()
499+ type Fn (Delete (c ': cs) ()) = Service -> Client ()
491500
492− clientBuild Proxy = clientEmpty methodDelete [204]
501+ buildClient Proxy = discard methodDelete [204]
493502
494503-- perform :: Accept
495504-- -> (Stream -> Client (Either SerializeError a))
496505-- -> Method
497506-- -> [Int]
498−-- -> RequestBuilder
507+-- -> Request
499508-- -> Client a
500509-- perform a meth ns f rq = undefined -- do
501510 -- m <- ask
502− -- x <- lift . try $ Client.http m (clientRequest meth a rq)
511+ -- x <- lift . try $ Client.http m (client meth a rq)
503512 -- either (failure . TransportError) success x
504513 -- where
505514 -- failure = pure . Left
@@ -542,5 +551,30 @@ buildText = Build.fromText . toText
542551buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
543552buildSymbol = Build.fromString . symbolVal
544553
545−textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
546−textSymbol = Text.pack . symbolVal
554+byteSymbol :: forall n proxy. KnownSymbol n => proxy n -> ByteString
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