@@ -7,6 +7,7 @@
77{-# LANGUAGE LambdaCase #-}
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE RankNTypes #-}
1011{-# LANGUAGE RecordWildCards #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TypeFamilies #-}
@@ -23,7 +24,8 @@
2324--
2425module Network.Google.Client where
2526
26−import Control.Exception
27+import Control.Monad.Catch
28+-- import Control.Exception
2729import Control.Lens
2830import Control.Monad.Trans.Class
2931import Control.Monad.Trans.Reader
@@ -50,9 +52,8 @@ import GHC.Generics
5052import GHC.TypeLits
5153import Network.Google.Types
5254import Network.HTTP.Client (HttpException)
53−import Network.HTTP.Conduit (Manager)
54−import qualified Network.HTTP.Conduit as Client
55−import Network.HTTP.Media
55+import qualified Network.HTTP.Client as Client
56+import Network.HTTP.Media hiding (Accept)
5657import Network.HTTP.Types
5758import Servant.API hiding (Header)
5859
@@ -71,45 +72,6 @@ type ResponseBody = ResumableSource (ResourceT IO) ByteString
7172data Body = Body -- MediaType
7273 deriving (Eq, Show, Generic, Data, Typeable)
7374
74−data Request = Request
75− { _rqHost :: ByteString
76− , _rqPort :: Int
77− , _rqBasePath :: ByteString
78− , _rqPath :: Builder
79− , _rqQuery :: DList (Text, Maybe Text)
80− , _rqHeaders :: [Header]
81− , _rqBody :: Maybe (MediaType, LBS.ByteString)
82− }
83−
84−initialRequest :: ByteString -- ^ Host.
85− -> Int -- ^ Port.
86− -> ByteString -- ^ Base Path.
87− -> Request
88−initialRequest h n p = Request
89− { _rqHost = h
90− , _rqPort = n
91− , _rqBasePath = p
92− , _rqPath = mempty
93− , _rqQuery = mempty
94− , _rqHeaders = mempty
95− , _rqBody = Nothing
96− }
97−
98−appendPath :: Request -> Builder -> Request
99−appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
100−
101−appendPaths :: ToText a => Request -> [a] -> Request
102−appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
103−
104−appendQuery :: Request -> Text -> Maybe Text -> Request
105−appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
106−
107−setBody :: Request -> MediaType -> LBS.ByteString -> Request
108−setBody rq c x = rq { _rqBody = Just (c, x) }
109−
110−-- setAccept :: Reuqest -> [MediaType] -> Request
111−-- setAccept rq xs = rq { _rqAccept = xs }
112−
11375data Error
11476 = TransportError HttpException
11577 | SerializeError SerializeError
@@ -167,50 +129,142 @@ instance AsError Error where
167129 ServiceError e -> Right e
168130 x -> Left x
169131
132+-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.
170133data Captures (s :: Symbol) a
171134 deriving (Typeable)
172135
136+-- | Form a Google style sub-resource, such as @/<capture>:<mode>@.
173137data CaptureMode (s :: Symbol) (m :: Symbol) a
174138 deriving (Typeable)
175139
176140data MultipartRelated (cs :: [*]) m b
177141 deriving (Typeable)
178142
179−instance ( MimeRender c m
180− , GoogleClient fn
181− ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
182− type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
143+-- | An intermediary request builder.
144+data RequestBuilder = RequestBuilder
145+ { _rqHost :: ByteString
146+ , _rqBasePath :: ByteString
147+ , _rqPath :: Builder
148+ , _rqQuery :: DList (Text, Maybe Text)
149+ , _rqBody :: Maybe (MediaType, LBS.ByteString)
150+ }
183151
184− -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
185− -- mimeRender p m
186− -- mimeRender (Proxy :: Proxy OctetStream) b
187− -- where
188− -- p = Proxy :: Proxy c
152+-- | Construct a default request builder. Since the Google service descriptions
153+-- have http/https in the host (rootUrl), the scheme is assumed.
154+defaultRequest :: ByteString -- ^ Host. (rootUrl)
155+ -> ByteString -- ^ Path. (servicePath)
156+ -> RequestBuilder
157+defaultRequest h p = RequestBuilder
158+ { _rqHost = h
159+ , _rqBasePath = p
160+ , _rqPath = mempty
161+ , _rqQuery = mempty
162+ , _rqBody = Nothing
163+ }
164+
165+appendPath :: RequestBuilder -> Builder -> RequestBuilder
166+appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
189167
168+appendPaths :: ToText a => RequestBuilder -> [a] -> RequestBuilder
169+appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
170+
171+appendQuery :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder
172+appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
173+
174+setBody :: RequestBuilder -> MediaType -> LBS.ByteString -> RequestBuilder
175+setBody rq c x = rq { _rqBody = Just (c, x) }
176+
177+-- | A materialised 'http-client' request and associated response parser.
178+data Client a = Client
179+ { _clientAccept :: Maybe MediaType
180+ , _clientCheck :: Int -> Bool
181+ , _clientResponse :: ResponseBody -> ResourceT IO (Either SerializeError a)
182+ , _clientRequest :: ClientRequest
183+ }
184+
185+client :: (ResponseBody -> ResourceT IO (Either SerializeError a))
186+ -> Maybe MediaType
187+ -> Method
188+ -> [Int]
189+ -> RequestBuilder
190+ -> Client a
191+client f cs m ns rq = Client
192+ { _clientAccept = cs
193+ , _clientCheck = (`elem` ns)
194+ , _clientResponse = f
195+ , _clientRequest = clientRequest cs m rq
196+ }
197+
198+clientRequest :: Maybe MediaType -> Method -> RequestBuilder -> ClientRequest
199+clientRequest cs m RequestBuilder {..} = def
200+ { Client.method = m
201+ , Client.checkStatus = \_ _ _ -> Nothing
202+ }
203+
204+clientMime :: MimeUnrender c a
205+ => Proxy c
206+ -> Method
207+ -> [Int]
208+ -> RequestBuilder
209+ -> Client a
210+clientMime p = client go (Just (contentType p))
211+ where
212+ go b = do
213+ lbs <- sinkLBS b
214+ case mimeUnrender p lbs of
215+ Left e -> undefined
216+ Right x -> pure (Right x)
217+
218+clientStream :: Accept c
219+ => Proxy c
220+ -> Method
221+ -> [Int]
222+ -> RequestBuilder
223+ -> Client ResponseBody
224+clientStream p = client (pure . Right) (Just (contentType p))
225+
226+clientEmpty :: Method -> [Int] -> RequestBuilder -> Client ()
227+clientEmpty = client go Nothing
228+ where
229+ go b = closeResumableSource b >> pure (Right ())
230+
231+-- sinkLBS :: ResponseBody -> Client LBS.ByteString
232+sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume)
190233
191234class GoogleRequest a where
192235 type Rs a :: *
193236
194− request :: a -> IO (Either Error (Rs a))
195− requestWith :: Request -> a -> IO (Either Error (Rs a))
237+ request :: a -> Client (Rs a)
238+ requestWith :: RequestBuilder -> a -> Client (Rs a)
196239
197240class GoogleClient fn where
198241 type Fn fn :: *
199242
200− requestBuild :: Proxy fn -> Request -> Fn fn
243+ clientBuild :: Proxy fn -> RequestBuilder -> Fn fn
244+
245+instance ( MimeRender c m
246+ , GoogleClient fn
247+ ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
248+ type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
249+
250+ -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
251+ -- mimeRender p m
252+ -- mimeRender (Proxy :: Proxy OctetStream) b
253+ -- where
254+ -- p = Proxy :: Proxy c
201255
202256instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where
203257 type Fn (s :> fn) = Fn fn
204258
205− requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn) $
259+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) $
206260 appendPath rq (buildSymbol (Proxy :: Proxy s))
207261
208262instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where
209263 type Fn (a :<|> b) = Fn a :<|> Fn b
210264
211− requestBuild Proxy rq =
212− requestBuild (Proxy :: Proxy a) rq
213− :<|> requestBuild (Proxy :: Proxy b) rq
265+ clientBuild Proxy rq =
266+ clientBuild (Proxy :: Proxy a) rq
267+ :<|> clientBuild (Proxy :: Proxy b) rq
214268
215269instance ( KnownSymbol s
216270 , ToText a
@@ -218,7 +272,7 @@ instance ( KnownSymbol s
218272 ) => GoogleClient (Capture s a :> fn) where
219273 type Fn (Capture s a :> fn) = a -> Fn fn
220274
221− requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
275+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
222276 . appendPath rq
223277 . buildText
224278
@@ -228,7 +282,7 @@ instance ( KnownSymbol s
228282 ) => GoogleClient (Captures s a :> fn) where
229283 type Fn (Captures s a :> fn) = [a] -> Fn fn
230284
231− requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
285+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
232286 . appendPaths rq
233287
234288instance ( KnownSymbol s
@@ -238,7 +292,7 @@ instance ( KnownSymbol s
238292 ) => GoogleClient (CaptureMode s m a :> fn) where
239293 type Fn (CaptureMode s m a :> fn) = a -> Fn fn
240294
241− requestBuild Proxy rq x = requestBuild (Proxy :: Proxy fn)
295+ clientBuild Proxy rq x = clientBuild (Proxy :: Proxy fn)
242296 . appendPath rq
243297 $ buildText x <> buildSymbol (Proxy :: Proxy m)
244298
@@ -248,7 +302,7 @@ instance ( KnownSymbol s
248302 ) => GoogleClient (QueryParam s a :> fn) where
249303 type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn
250304
251− requestBuild Proxy rq mx = requestBuild (Proxy :: Proxy fn) $
305+ clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $
252306 case mx of
253307 Nothing -> rq
254308 Just x -> appendQuery rq k v
@@ -262,7 +316,7 @@ instance ( KnownSymbol s
262316 ) => GoogleClient (QueryParams s a :> fn) where
263317 type Fn (QueryParams s a :> fn) = [a] -> Fn fn
264318
265− requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn) . foldl' go rq
319+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) . foldl' go rq
266320 where
267321 go r = appendQuery r k . Just . toText
268322
@@ -273,7 +327,7 @@ instance ( MimeRender c a
273327 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where
274328 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn
275329
276− requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
330+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
277331 . setBody rq (contentType p)
278332 . mimeRender p
279333 where
@@ -284,128 +338,89 @@ instance ( MimeRender c a
284338instance MimeUnrender c a => GoogleClient (Get (c ': cs) a) where
285339 type Fn (Get (c ': cs) a) = Client a
286340
287− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodGet [200, 203]
341+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodGet [200, 203]
288342
289−instance GoogleClient (Get (c ': cs) ResponseBody) where
343+instance Accept c => GoogleClient (Get (c ': cs) ResponseBody) where
290344 type Fn (Get (c ': cs) ResponseBody) = Client ResponseBody
291345
292− requestBuild Proxy = requestBody (Proxy :: Proxy c) methodGet [200, 203]
346+ clientBuild Proxy = clientStream (Proxy :: Proxy c) methodGet [200, 203]
293347
294348instance GoogleClient (Get (c ': cs) ()) where
295349 type Fn (Get (c ': cs) ()) = Client ()
296350
297− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodGet [204]
351+ clientBuild Proxy = clientEmpty methodGet [204]
298352
299353instance MimeUnrender c a => GoogleClient (Post (c ': cs) a) where
300354 type Fn (Post (c ': cs) a) = Client a
301355
302− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPost [200, 201]
356+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPost [200, 201]
303357
304358instance GoogleClient (Post (c ': cs) ()) where
305359 type Fn (Post (c ': cs) ()) = Client ()
306360
307− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPost [204]
361+ clientBuild Proxy = clientEmpty methodPost [204]
308362
309363instance MimeUnrender c a => GoogleClient (Put (c ': cs) a) where
310364 type Fn (Put (c ': cs) a) = Client a
311365
312− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPut [200, 201]
366+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPut [200, 201]
313367
314368instance GoogleClient (Put (c ': cs) ()) where
315369 type Fn (Put (c ': cs) ()) = Client ()
316370
317− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPut [204]
371+ clientBuild Proxy = clientEmpty methodPut [204]
318372
319373instance MimeUnrender c a => GoogleClient (Patch (c ': cs) a) where
320374 type Fn (Patch (c ': cs) a) = Client a
321375
322− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPatch [200, 201]
376+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPatch [200, 201]
323377
324378instance GoogleClient (Patch (c ': cs) ()) where
325379 type Fn (Patch (c ': cs) ()) = Client ()
326380
327− requestBuild Proxy = requestMime (Proxy :: Proxy c) methodPatch [204]
328−
329−type Client a = ReaderT Manager IO (Either Error a)
330−
331−requestMime :: MimeUnrender c a
332− => Proxy c
333− -> Method
334− -> [Int]
335− -> Request
336− -> Client a
337−requestMime p = perform c go
338− where
339− c = contentType p
340−
341− go b = do
342− lbs <- sinkLBS b
343− case mimeUnrender c lbs of
344− Left e -> SerializeError
345− Right x -> undefined
346−
347−requestbody :: Accept c
348− => Proxy c
349− -> Method
350− -> [Int]
351− -> Request
352− -> Client ResponseBody
353−requestBody p = perform c (pure . Right)
354− where
355− c = contentType p
356−
357−-- performNoBody = httpNoBody
358−
359−perform :: Accept
360− -> (ResponseBody -> Client (Either SerializeError a))
361− -> Method
362− -> [Int]
363− -> Request
364− -> Client a
365−perform a meth ns f rq = do
366− m <- ask
367− x <- lift . try $ Client.http m (clientRequest meth a rq)
368− either (failure . TransportError) success x
369− where
370− failure = pure . Left
371−
372− success rs = do
373− let s = Client.responseStatus rs
374− b = Client.responseBody rs
375− hs = Client.responseHeaders rs
376− case content hs of
377− unless (matches respCT (acceptCT)) $
378− left $ UnsupportedContentType respCT respBody
379−
380− Nothing -> failure (SerializeError' (SerializeError hs))
381−
382− Just _ | statusInvalid s -> do
383− lbs <- sinkLBS b
384− failure (ServiceError' (ServiceError s c hs lbs))
385−
386− Just c | contentInvalid c -> do
387− lbs <- sinkLBS b
388− failure (SerializeError' (SerializeError s c hs lbs))
389−
390−
391− Just c -> first SerializeError' <$> f b
392−
393− content :: [Header] -> Maybe c
394− content = parseAccept
395− . fromMaybe "application/octet-stream"
396− . lookup hContentType
397−
398− statusCheck s = fromEnum s `elem` ns
399− contentCheck = matches a
400−
401−clientRequest :: Method -> MediaType -> Request -> ClientRequest
402−clientRequest m c Request {..} = def
403− { Client.method = m
404− , Client.checkStatus = \_ _ _ -> Nothing
405− }
406−
407−sinkLBS :: ResponseBody -> Client LBS.ByteString
408−sinkLBS = fmap LBS.fromChunks . ($$+- CL.consme)
381+ clientBuild Proxy = clientEmpty methodPatch [204]
382+
383+-- perform :: Accept
384+-- -> (ResponseBody -> Client (Either SerializeError a))
385+-- -> Method
386+-- -> [Int]
387+-- -> RequestBuilder
388+-- -> Client a
389+-- perform a meth ns f rq = undefined -- do
390+ -- m <- ask
391+ -- x <- lift . try $ Client.http m (clientRequest meth a rq)
392+ -- either (failure . TransportError) success x
393+ -- where
394+ -- failure = pure . Left
395+
396+ -- success rs = do
397+ -- let s = Client.responseStatus rs
398+ -- b = Client.responseBody rs
399+ -- hs = Client.responseHeaders rs
400+ -- case content hs of
401+ -- unless (matches respCT (acceptCT)) $
402+ -- left $ UnsupportedContentType respCT respBody
403+
404+ -- Nothing -> failure (SerializeError' (SerializeError hs))
405+
406+ -- Just _ | statusInvalid s -> do
407+ -- lbs <- sinkLBS b
408+ -- failure (ServiceError' (ServiceError s c hs lbs))
409+
410+ -- Just c | contentInvalid c -> do
411+ -- lbs <- sinkLBS b
412+ -- failure (SerializeError' (SerializeError s c hs lbs))
413+
414+
415+ -- Just c -> first SerializeError' <$> f b
416+
417+ -- content :: [Header] -> Maybe c
418+ -- content = parseAccept
419+ -- . fromMaybe "application/octet-stream"
420+ -- . lookup hContentType
421+
422+ -- statusCheck s = fromEnum s `elem` ns
423+ -- contentCheck = matches a
409424
410425buildText :: ToText a => a -> Builder
411426buildText = Build.fromText . toText