git.iko.soy/gogol
on develop help sign in
Adding serialisation errors
1535b35Brendan Hay
core/src/Network/Google/Types.hs+7−64
compare with develop
unifiedsplit
@@ -23,6 +23,7 @@
23module Network.Google.Types where
23module Network.Google.Types where
24
24
25import Control.Lens hiding (coerce)
25import Control.Lens hiding (coerce)
26+import Control.Monad
26import Control.Monad.Catch
27import Control.Monad.Catch
27import Control.Monad.Trans.Resource
28import Control.Monad.Trans.Resource
28import Data.Aeson
29import Data.Aeson
@@ -200,26 +201,16 @@ data Client a = Client
200 , _cliCheck :: Status -> Bool
201 , _cliCheck :: Status -> Bool
201 , _cliService :: Service
202 , _cliService :: Service
202 , _cliRequest :: Request
203 , _cliRequest :: Request
203− , _cliResponse :: Stream -> ResourceT IO (Either SerializeError a)
204+ , _cliResponse :: Stream -> ResourceT IO (Either String a)
204 }
205 }
205
206
206−mime :: FromStream c a
207+mime :: FromStream c a => Proxy c -> Method -> [Int] -> Request -> Service -> Client a
207− => Proxy c
208− -> Method
209− -> [Int]
210− -> Request
211− -> Service
212− -> Client a
213mime p = client (fromStream p) (Just (contentType p))
208mime p = client (fromStream p) (Just (contentType p))
214
209
215−discard :: Method
210+discard :: Method -> [Int] -> Request -> Service -> Client ()
216− -> [Int]
217− -> Request
218− -> Service
219− -> Client ()
220discard = client (\b -> closeResumableSource b >> pure (Right ())) Nothing
211discard = client (\b -> closeResumableSource b >> pure (Right ())) Nothing
221
212
222−client :: (Stream -> ResourceT IO (Either SerializeError a))
213+client :: (Stream -> ResourceT IO (Either String a))
223 -> Maybe MediaType
214 -> Maybe MediaType
224 -> Method
215 -> Method
225 -> [Int]
216 -> [Int]
@@ -253,19 +244,13 @@ instance ToBody JSON Value where
253 toBody Proxy = RequestBodyLBS . encode
244 toBody Proxy = RequestBodyLBS . encode
254
245
255class Accept c => FromStream c a where
246class Accept c => FromStream c a where
256− fromStream :: Proxy c
247+ fromStream :: Proxy c -> Stream -> ResourceT IO (Either String a)
257− -> Stream
258− -> ResourceT IO (Either SerializeError a)
259
248
260instance FromStream OctetStream Stream where
249instance FromStream OctetStream Stream where
261 fromStream Proxy = pure . Right
250 fromStream Proxy = pure . Right
262
251
263instance FromJSON a => FromStream JSON a where
252instance FromJSON a => FromStream JSON a where
264− fromStream Proxy b = do
253+ fromStream Proxy = sinkLBS >=> pure . eitherDecode
265− lbs <- sinkLBS b
266− case eitherDecode lbs of
267− Left e -> undefined
268− Right x -> pure (Right x)
269
254
270class GoogleAuth a where
255class GoogleAuth a where
271 _AuthKey :: Traversal' a AuthKey
256 _AuthKey :: Traversal' a AuthKey
@@ -496,48 +481,6 @@ instance {-# OVERLAPPING #-}
496
481
497 buildClient Proxy = discard methodDelete [204]
482 buildClient Proxy = discard methodDelete [204]
498
483
499−-- perform :: Accept
500−-- -> (Stream -> Client (Either SerializeError a))
501−-- -> Method
502−-- -> [Int]
503−-- -> Request
504−-- -> Client a
505−-- perform a meth ns f rq = undefined -- do
506− -- m <- ask
507− -- x <- lift . try $ Client.http m (client meth a rq)
508− -- either (failure . TransportError) success x
509− -- where
510− -- failure = pure . Left
511−
512− -- success rs = do
513− -- let s = Client.responseStatus rs
514− -- b = Client.responseBody rs
515− -- hs = Client.responseHeaders rs
516− -- case content hs of
517− -- unless (matches respCT (acceptCT)) $
518− -- left $ UnsupportedContentType respCT respBody
519−
520− -- Nothing -> failure (SerializeError' (SerializeError hs))
521−
522− -- Just _ | statusInvalid s -> do
523− -- lbs <- sinkLBS b
524− -- failure (ServiceError' (ServiceError s c hs lbs))
525−
526− -- Just c | contentInvalid c -> do
527− -- lbs <- sinkLBS b
528− -- failure (SerializeError' (SerializeError s c hs lbs))
529−
530−
531− -- Just c -> first SerializeError' <$> f b
532−
533− -- content :: [Header] -> Maybe c
534− -- content = parseAccept
535− -- . fromMaybe "application/octet-stream"
536− -- . lookup hContentType
537−
538− -- statusCheck s = fromEnum s `elem` ns
539− -- contentCheck = matches a
540−
541sinkLBS :: Stream -> ResourceT IO LBS.ByteString
484sinkLBS :: Stream -> ResourceT IO LBS.ByteString
542sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume)
485sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume)
543
486
gogol/src/Network/Google/Internal/HTTP.hs+38−1
@@ -47,7 +47,15 @@ perform Env{..} x = catches go handlers
47 where
47 where
48 go = liftResourceT $ do
48 go = liftResourceT $ do
49 rs <- http rq _envManager
49 rs <- http rq _envManager
50− first SerializeError <$> _cliResponse (responseBody rs)
50+ r <- _cliResponse (responseBody rs)
51+ pure $! case r of
52+ Right y -> Right y
53+ Left e -> Left . SerializeError $ SerializeError'
54+ { _serializeId = _svcId
55+ , _serializeHeaders = responseHeaders rs
56+ , _serializeStatus = responseStatus rs
57+ , _serializeMessage = e
58+ }
51
59
52 rq = def
60 rq = def
53 { Client.host = _svcHost
61 { Client.host = _svcHost
@@ -98,3 +106,32 @@ perform Env{..} x = catches go handlers
98 ]
106 ]
99 where
107 where
100 err e = return (Left e) -- logError _envLogger e >>
108 err e = return (Left e) -- logError _envLogger e >>
109+
110+ -- success rs = do
111+ -- let s = Client.responseStatus rs
112+ -- b = Client.responseBody rs
113+ -- hs = Client.responseHeaders rs
114+ -- case content hs of
115+ -- unless (matches respCT (acceptCT)) $
116+ -- left $ UnsupportedContentType respCT respBody
117+
118+ -- Nothing -> failure (SerializeError' (SerializeError hs))
119+
120+ -- Just _ | statusInvalid s -> do
121+ -- lbs <- sinkLBS b
122+ -- failure (ServiceError' (ServiceError s c hs lbs))
123+
124+ -- Just c | contentInvalid c -> do
125+ -- lbs <- sinkLBS b
126+ -- failure (SerializeError' (SerializeError s c hs lbs))
127+
128+
129+ -- Just c -> first SerializeError' <$> f b
130+
131+ -- content :: [Header] -> Maybe c
132+ -- content = parseAccept
133+ -- . fromMaybe "application/octet-stream"
134+ -- . lookup hContentType
135+
136+ -- statusCheck s = fromEnum s `elem` ns
137+ -- contentCheck = matches a