git.iko.soy/gogol
on develop help sign in
Adding HTTP status checks and serialisation errors
33c8c76Brendan Hay
core/src/Network/Google/Types.hs+8−12
compare with develop
unifiedsplit
@@ -76,10 +76,6 @@ newtype OAuthToken = OAuthToken Text
76instance ToText OAuthToken where
76instance ToText OAuthToken where
77 toText (OAuthToken t) = "Bearer " <> t
77 toText (OAuthToken t) = "Bearer " <> t
78
78
79−class GoogleAuth a where
80− _AuthKey :: Traversal' a AuthKey
81− _AuthToken :: Traversal' a OAuthToken
82−
83newtype MediaDownload a = MediaDownload a
79newtype MediaDownload a = MediaDownload a
84
80
85_MediaDownload :: Iso' (MediaDownload a) a
81_MediaDownload :: Iso' (MediaDownload a) a
@@ -117,7 +113,6 @@ data SerializeError = SerializeError'
117 { _serializeId :: !ServiceId
113 { _serializeId :: !ServiceId
118 , _serializeHeaders :: [HTTP.Header]
114 , _serializeHeaders :: [HTTP.Header]
119 , _serializeStatus :: !Status
115 , _serializeStatus :: !Status
120− , _serializeMedia :: !MediaType
121 , _serializeMessage :: String
116 , _serializeMessage :: String
122 } deriving (Eq, Show, Typeable)
117 } deriving (Eq, Show, Typeable)
123
118
@@ -125,8 +120,7 @@ data ServiceError = ServiceError'
125 { _serviceId :: !ServiceId
120 { _serviceId :: !ServiceId
126 , _serviceStatus :: !Status
121 , _serviceStatus :: !Status
127 , _serviceHeaders :: [HTTP.Header]
122 , _serviceHeaders :: [HTTP.Header]
128− , _serviceMedia :: !MediaType
129− , _serviceBody :: LBS.ByteString
123+ , _serviceBody :: Maybe LBS.ByteString
130 } deriving (Eq, Show, Typeable)
124 } deriving (Eq, Show, Typeable)
131
125
132class AsError a where
126class AsError a where
@@ -169,8 +163,6 @@ data Service = Service
169 , _svcPort :: !Int
163 , _svcPort :: !Int
170 , _svcSecure :: !Bool
164 , _svcSecure :: !Bool
171 , _svcTimeout :: !(Maybe Seconds)
165 , _svcTimeout :: !(Maybe Seconds)
172− , _svcCheck :: !(Status -> Bool)
173− , _svcRetry :: !(ServiceError -> Bool)
174 }
166 }
175
167
176-- | An intermediary request builder.
168-- | An intermediary request builder.
@@ -205,7 +197,7 @@ setBody rq c x = rq { _rqBody = Just (c, x) }
205data Client a = Client
197data Client a = Client
206 { _cliAccept :: Maybe MediaType
198 { _cliAccept :: Maybe MediaType
207 , _cliMethod :: Method
199 , _cliMethod :: Method
208− , _cliCheck :: Int -> Bool
200+ , _cliCheck :: Status -> Bool
209 , _cliService :: Service
201 , _cliService :: Service
210 , _cliRequest :: Request
202 , _cliRequest :: Request
211 , _cliResponse :: Stream -> ResourceT IO (Either SerializeError a)
203 , _cliResponse :: Stream -> ResourceT IO (Either SerializeError a)
@@ -237,7 +229,7 @@ client :: (Stream -> ResourceT IO (Either SerializeError a))
237client f cs m ns rq s = Client
229client f cs m ns rq s = Client
238 { _cliAccept = cs
230 { _cliAccept = cs
239 , _cliMethod = m
231 , _cliMethod = m
240− , _cliCheck = (`elem` ns)
232+ , _cliCheck = (`elem` ns) . fromEnum
241 , _cliService = s
233 , _cliService = s
242 , _cliRequest = rq
234 , _cliRequest = rq
243 , _cliResponse = f
235 , _cliResponse = f
@@ -275,7 +267,11 @@ instance FromJSON a => FromStream JSON a where
275 Left e -> undefined
267 Left e -> undefined
276 Right x -> pure (Right x)
268 Right x -> pure (Right x)
277
269
270+class GoogleAuth a where
271+ _AuthKey :: Traversal' a AuthKey
272+ _AuthToken :: Traversal' a OAuthToken
273+
278−class GoogleRequest a where
274+class GoogleAuth a => GoogleRequest a where
279 type Rs a :: *
275 type Rs a :: *
280
276
281 requestClient :: a -> Client (Rs a)
277 requestClient :: a -> Client (Rs a)
gogol/src/Network/Google/Env.hs+21−21
@@ -24,11 +24,11 @@ import Network.HTTP.Conduit
24
24
25-- | The environment containing the parameters required to make Google requests.
25-- | The environment containing the parameters required to make Google requests.
26data Env = Env
26data Env = Env
27− { _envRetryCheck :: !(Int -> HttpException -> Bool)
27+ -- { _envRetryCheck :: !(Int -> HttpException -> Bool)
28− , _envRetryPolicy :: !RetryPolicy
28+ -- , _envRetryPolicy :: !RetryPolicy
29− , _envTimeout :: !(Maybe Seconds)
29+ { _envTimeout :: !(Maybe Seconds)
30− , _envManager :: !Manager
30+ , _envManager :: !Manager
31− , _envAuth :: !Auth
31+ , _envAuth :: !Auth
32 }
32 }
33
33
34-- Note: The strictness annotations aobe are applied to ensure
34-- Note: The strictness annotations aobe are applied to ensure
@@ -38,11 +38,11 @@ class HasEnv a where
38 environment :: Lens' a Env
38 environment :: Lens' a Env
39 {-# MINIMAL environment #-}
39 {-# MINIMAL environment #-}
40
40
41− -- | The function used to determine if an 'HttpException' should be retried.
41+ -- -- | The function used to determine if an 'HttpException' should be retried.
42− envRetryCheck :: Lens' a (Int -> HttpException -> Bool)
42+ -- envRetryCheck :: Lens' a (Int -> HttpException -> Bool)
43
43
44− -- | TODO
44+ -- -- | TODO
45− envRetryPolicy :: Lens' a RetryPolicy
45+ -- envRetryPolicy :: Lens' a RetryPolicy
46
46
47 -- | TODO
47 -- | TODO
48 envTimeout :: Lens' a (Maybe Seconds)
48 envTimeout :: Lens' a (Maybe Seconds)
@@ -53,8 +53,8 @@ class HasEnv a where
53 -- | The credentials used to sign requests for authentication with Google.
53 -- | The credentials used to sign requests for authentication with Google.
54 envAuth :: Lens' a Auth
54 envAuth :: Lens' a Auth
55
55
56− envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })
56+ -- envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })
57− envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })
57+ -- envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })
58 envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })
58 envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })
59 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
59 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
60 envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
60 envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
@@ -62,14 +62,14 @@ class HasEnv a where
62instance HasEnv Env where
62instance HasEnv Env where
63 environment = id
63 environment = id
64
64
65−-- | Scope an action such that any retry logic for the 'Env' is
65+-- -- | Scope an action such that any retry logic for the 'Env' is
66−-- ignored and any requests will at most be sent once.
66+-- -- ignored and any requests will at most be sent once.
67−once :: (MonadReader r m, HasEnv r) => m a -> m a
67+-- once :: (MonadReader r m, HasEnv r) => m a -> m a
68−once = policy (limitRetries 0)
68+-- once = policy (limitRetries 0)
69
69
70−-- | TODO
70+-- -- | TODO
71−policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a
71+-- policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a
72−policy r = local (envRetryPolicy <>~ r)
72+-- policy r = local (envRetryPolicy <>~ r)
73
73
74-- | Scope an action such that any HTTP response will use this timeout value.
74-- | Scope an action such that any HTTP response will use this timeout value.
75--
75--
@@ -93,6 +93,6 @@ newEnv c = liftIO (newManager conduitManagerSettings) >>= newEnvWith c
93
93
94-- | /See:/ 'newEnv'
94-- | /See:/ 'newEnv'
95newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
95newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
96−newEnvWith c m = Env check mempty Nothing m <$> getAuth c
96+newEnvWith c m = Env Nothing m <$> getAuth c
97− where
97+ -- where
98− check _ _ = True
98+ -- check _ _ = True
gogol/src/Network/Google/Internal/HTTP.hs+14−5
@@ -30,7 +30,7 @@ import qualified Data.Text.Lazy as LText
30import qualified Data.Text.Lazy.Builder as Build
30import qualified Data.Text.Lazy.Builder as Build
31import GHC.Exts (toList)
31import GHC.Exts (toList)
32import Network.Google.Auth
32import Network.Google.Auth
33−import Network.Google.Env
33+import Network.Google.Env (Env (..))
34import Network.Google.Internal.Types
34import Network.Google.Internal.Types
35import Network.Google.Types
35import Network.Google.Types
36import Network.HTTP.Conduit
36import Network.HTTP.Conduit
@@ -39,7 +39,7 @@ import Network.HTTP.Media
39import Network.HTTP.Types
39import Network.HTTP.Types
40
40
41-- | The 'Service' is configured + unwrapped at this point.
41-- | The 'Service' is configured + unwrapped at this point.
42−perform :: (MonadCatch m, MonadBaseControl IO m, MonadResource m, GoogleRequest a)
42+perform :: (MonadCatch m, MonadResource m, GoogleRequest a)
43 => Env
43 => Env
44 -> a
44 -> a
45 -> m (Either Error (Rs a))
45 -> m (Either Error (Rs a))
@@ -53,9 +53,8 @@ perform Env{..} x = catches go handlers
53 { Client.host = _svcHost
53 { Client.host = _svcHost
54 , Client.port = _svcPort
54 , Client.port = _svcPort
55 , Client.secure = _svcSecure
55 , Client.secure = _svcSecure
56− , Client.checkStatus = \_ _ _ -> Nothing
56+ , Client.checkStatus = status
57− -- mix with Env timeout
57+ , Client.responseTimeout = timeout
58−-- , Client.responseTimeout = microseconds <$> _svcTimeout
59 , Client.method = _cliMethod
58 , Client.method = _cliMethod
60 , Client.path = path
59 , Client.path = path
61 , Client.queryString = renderQuery True (toList _rqQuery)
60 , Client.queryString = renderQuery True (toList _rqQuery)
@@ -78,6 +77,16 @@ perform Env{..} x = catches go handlers
78 . LText.toStrict
77 . LText.toStrict
79 $ Build.toLazyText (_svcPath <> _rqPath)
78 $ Build.toLazyText (_svcPath <> _rqPath)
80
79
80+ status s hs _
81+ | _cliCheck s = Nothing
82+ | otherwise = Just . toException . ServiceError $ ServiceError'
83+ { _serviceId = _svcId
84+ , _serviceStatus = s
85+ , _serviceHeaders = hs
86+ , _serviceBody = Nothing
87+ }
88+
89+ timeout = microseconds <$> (_envTimeout <|> _svcTimeout)
81
90
82 Request {..} = _cliRequest
91 Request {..} = _cliRequest
83 Service {..} = _cliService
92 Service {..} = _cliService