33c8c76 · gogol · git.iko.soy

git.iko.soy/gogol

Adding HTTP status checks and serialisation errors

commit33c8c760f8bceaae494fcd6e0f08ee3f81af8d51 authorBrendan Hay <brendan.g.hay@gmail.com> dateMon 12 Oct 2015, 13:03 (11 years ago) parent01edb52

3 files changed+43−38

compare with develop

unifiedsplit

core/src/Network/Google/Types.hs+8−12 gogol/src/Network/Google/Env.hs+21−21 gogol/src/Network/Google/Internal/HTTP.hs+14−5

core/src/Network/Google/Types.hs+8−12

@@ -76,10 +76,6 @@ newtype OAuthToken = OAuthToken Text

7676instance ToText OAuthToken where

7777 toText (OAuthToken t) = "Bearer " <> t

7878

79−class GoogleAuth a where

80− _AuthKey :: Traversal' a AuthKey

81− _AuthToken :: Traversal' a OAuthToken

82−

8379newtype MediaDownload a = MediaDownload a

8480

8581_MediaDownload :: Iso' (MediaDownload a) a

@@ -117,7 +113,6 @@ data SerializeError = SerializeError'

117113 { _serializeId :: !ServiceId

118114 , _serializeHeaders :: [HTTP.Header]

119115 , _serializeStatus :: !Status

120− , _serializeMedia :: !MediaType

121116 , _serializeMessage :: String

122117 } deriving (Eq, Show, Typeable)

123118

@@ -125,8 +120,7 @@ data ServiceError = ServiceError'

125120 { _serviceId :: !ServiceId

126121 , _serviceStatus :: !Status

127122 , _serviceHeaders :: [HTTP.Header]

128− , _serviceMedia :: !MediaType

129− , _serviceBody :: LBS.ByteString

123+ , _serviceBody :: Maybe LBS.ByteString

130124 } deriving (Eq, Show, Typeable)

131125

132126class AsError a where

@@ -169,8 +163,6 @@ data Service = Service

169163 , _svcPort :: !Int

170164 , _svcSecure :: !Bool

171165 , _svcTimeout :: !(Maybe Seconds)

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

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

174166 }

175167

176168-- | An intermediary request builder.

@@ -205,7 +197,7 @@ setBody rq c x = rq { _rqBody = Just (c, x) }

205197data Client a = Client

206198 { _cliAccept :: Maybe MediaType

207199 , _cliMethod :: Method

208− , _cliCheck :: Int -> Bool

200+ , _cliCheck :: Status -> Bool

209201 , _cliService :: Service

210202 , _cliRequest :: Request

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

@@ -237,7 +229,7 @@ client :: (Stream -> ResourceT IO (Either SerializeError a))

237229client f cs m ns rq s = Client

238230 { _cliAccept = cs

239231 , _cliMethod = m

240− , _cliCheck = (`elem` ns)

232+ , _cliCheck = (`elem` ns) . fromEnum

241233 , _cliService = s

242234 , _cliRequest = rq

243235 , _cliResponse = f

@@ -275,7 +267,11 @@ instance FromJSON a => FromStream JSON a where

275267 Left e -> undefined

276268 Right x -> pure (Right x)

277269

278−class GoogleRequest a where

270+class GoogleAuth a where

271+ _AuthKey :: Traversal' a AuthKey

272+ _AuthToken :: Traversal' a OAuthToken

273+

274+class GoogleAuth a => GoogleRequest a where

279275 type Rs a :: *

280276

281277 requestClient :: a -> Client (Rs a)

gogol/src/Network/Google/Env.hs+21−21

@@ -24,11 +24,11 @@ import Network.HTTP.Conduit

2424

2525-- | The environment containing the parameters required to make Google requests.

2626data Env = Env

27− { _envRetryCheck :: !(Int -> HttpException -> Bool)

28− , _envRetryPolicy :: !RetryPolicy

29− , _envTimeout :: !(Maybe Seconds)

30− , _envManager :: !Manager

31− , _envAuth :: !Auth

27+ -- { _envRetryCheck :: !(Int -> HttpException -> Bool)

28+ -- , _envRetryPolicy :: !RetryPolicy

29+ { _envTimeout :: !(Maybe Seconds)

30+ , _envManager :: !Manager

31+ , _envAuth :: !Auth

3232 }

3333

3434-- Note: The strictness annotations aobe are applied to ensure

@@ -38,11 +38,11 @@ class HasEnv a where

3838 environment :: Lens' a Env

3939 {-# MINIMAL environment #-}

4040

41− -- | The function used to determine if an 'HttpException' should be retried.

42− envRetryCheck :: Lens' a (Int -> HttpException -> Bool)

41+ -- -- | The function used to determine if an 'HttpException' should be retried.

42+ -- envRetryCheck :: Lens' a (Int -> HttpException -> Bool)

4343

44− -- | TODO

45− envRetryPolicy :: Lens' a RetryPolicy

44+ -- -- | TODO

45+ -- envRetryPolicy :: Lens' a RetryPolicy

4646

4747 -- | TODO

4848 envTimeout :: Lens' a (Maybe Seconds)

@@ -53,8 +53,8 @@ class HasEnv a where

5353 -- | The credentials used to sign requests for authentication with Google.

5454 envAuth :: Lens' a Auth

5555

56− envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })

57− envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })

56+ -- envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })

57+ -- envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })

5858 envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })

5959 envManager = environment . lens _envManager (\s a -> s { _envManager = a })

6060 envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })

@@ -62,14 +62,14 @@ class HasEnv a where

6262instance HasEnv Env where

6363 environment = id

6464

65−-- | Scope an action such that any retry logic for the 'Env' is

66−-- ignored and any requests will at most be sent once.

67−once :: (MonadReader r m, HasEnv r) => m a -> m a

68−once = policy (limitRetries 0)

65+-- -- | Scope an action such that any retry logic for the 'Env' is

66+-- -- ignored and any requests will at most be sent once.

67+-- once :: (MonadReader r m, HasEnv r) => m a -> m a

68+-- once = policy (limitRetries 0)

6969

70−-- | TODO

71−policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a

72−policy r = local (envRetryPolicy <>~ r)

70+-- -- | TODO

71+-- policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a

72+-- policy r = local (envRetryPolicy <>~ r)

7373

7474-- | Scope an action such that any HTTP response will use this timeout value.

7575--

@@ -93,6 +93,6 @@ newEnv c = liftIO (newManager conduitManagerSettings) >>= newEnvWith c

9393

9494-- | /See:/ 'newEnv'

9595newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env

96−newEnvWith c m = Env check mempty Nothing m <$> getAuth c

97− where

98− check _ _ = True

96+newEnvWith c m = Env Nothing m <$> getAuth c

97+ -- where

98+ -- check _ _ = True

gogol/src/Network/Google/Internal/HTTP.hs+14−5

@@ -30,7 +30,7 @@ import qualified Data.Text.Lazy as LText

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

3131import GHC.Exts (toList)

3232import Network.Google.Auth

33−import Network.Google.Env

33+import Network.Google.Env (Env (..))

3434import Network.Google.Internal.Types

3535import Network.Google.Types

3636import Network.HTTP.Conduit

@@ -39,7 +39,7 @@ import Network.HTTP.Media

3939import Network.HTTP.Types

4040

4141-- | 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)

4343 => Env

4444 -> a

4545 -> m (Either Error (Rs a))

@@ -53,9 +53,8 @@ perform Env{..} x = catches go handlers

5353 { Client.host = _svcHost

5454 , Client.port = _svcPort

5555 , Client.secure = _svcSecure

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

57− -- mix with Env timeout

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

56+ , Client.checkStatus = status

57+ , Client.responseTimeout = timeout

5958 , Client.method = _cliMethod

6059 , Client.path = path

6160 , Client.queryString = renderQuery True (toList _rqQuery)

@@ -78,6 +77,16 @@ perform Env{..} x = catches go handlers

7877 . LText.toStrict

7978 $ Build.toLazyText (_svcPath <> _rqPath)

8079

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)

8190

8291 Request {..} = _cliRequest

8392 Service {..} = _cliService