diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +0.8.4 +===== + + * Supported http-client >= 0.5 + 0.8.3 ===== diff --git a/libjenkins.cabal b/libjenkins.cabal --- a/libjenkins.cabal +++ b/libjenkins.cabal @@ -1,5 +1,5 @@ name: libjenkins -version: 0.8.3 +version: 0.8.4 synopsis: Jenkins API interface description: Jenkins API interface. It supports REST and Discovery APIs license: BSD2 @@ -27,7 +27,7 @@ source-repository this type: git location: https://github.com/supki/libjenkins - tag: 0.8.3 + tag: 0.8.4 library default-language: @@ -41,7 +41,7 @@ , containers , free >= 4.10 , http-conduit >= 2.1.8 - , http-client >= 0.4.19 + , http-client >= 0.5.5 , http-types >= 0.8 , monad-control >= 0.3 , profunctors >= 4.2 diff --git a/src/Jenkins/Rest/Internal.hs b/src/Jenkins/Rest/Internal.hs --- a/src/Jenkins/Rest/Internal.hs +++ b/src/Jenkins/Rest/Internal.hs @@ -39,14 +39,17 @@ import Control.Monad.Trans.Free.Church (FT, iterTM) import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Writer (MonadWriter(..)) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString as Strict +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Conduit (ResumableSource) import Data.Text (Text) import qualified Data.Text.Encoding as Text import Data.Typeable (Typeable) import Network.HTTP.Conduit (Request, HttpException) import qualified Network.HTTP.Conduit as Http +import qualified Network.HTTP.Client as Http (brReadSome) +import qualified Network.HTTP.Client.Internal as Http (throwHttp) import Network.HTTP.Types (Status(..)) import Jenkins.Rest.Method.Internal (Method, Type(..), render, slash) @@ -93,9 +96,9 @@ data JF :: (* -> *) -> * -> * where - Get :: Method 'Complete f -> (ByteString -> a) -> JF m a - Stream :: MonadResource m => Method 'Complete f -> (ResumableSource m Strict.ByteString -> a) -> JF m a - Post :: (forall f. Method 'Complete f) -> ByteString -> (ByteString -> a) -> JF m a + Get :: Method 'Complete f -> (Lazy.ByteString -> a) -> JF m a + Stream :: MonadResource m => Method 'Complete f -> (ResumableSource m ByteString -> a) -> JF m a + Post :: (forall f. Method 'Complete f) -> Lazy.ByteString -> (Lazy.ByteString -> a) -> JF m a Conc :: JenkinsT m a -> JenkinsT m b -> (a -> b -> c) -> JF m c Or :: JenkinsT m a -> (JenkinsException -> JenkinsT m a) -> JF m a With :: (Request -> Request) -> JenkinsT m b -> (b -> a) -> JF m a @@ -126,7 +129,7 @@ :: (MonadIO m, MonadBaseControl IO m) => String -> Text -> Text -> JenkinsT m a -> m a runInternal h user token jenk = do - url <- liftIO (wrapException (Http.parseUrl h)) + url <- liftIO (wrapException (Http.parseUrlThrow h)) man <- liftIO (Http.newManager Http.tlsManagerSettings) runInterpT (iterInterpT man jenk) (Http.applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token) url) @@ -182,13 +185,15 @@ res <- runInterpT (iterInterpT man jenk) (f req) runInterpT (next res) req -oneshotReq :: MonadIO m => Request -> Http.Manager -> m ByteString -oneshotReq req = liftIO . wrapException . liftM Http.responseBody . Http.httpLbs req +oneshotReq :: MonadIO m => Request -> Http.Manager -> m Lazy.ByteString +oneshotReq req = + liftIO . wrapException . fmap Http.responseBody . Http.httpLbs req streamReq :: (MonadBaseControl IO m, MonadResource m) - => Request -> Http.Manager -> m (ResumableSource m Strict.ByteString) -streamReq req = wrapException . liftM Http.responseBody . Http.http req + => Request -> Http.Manager -> m (ResumableSource m ByteString) +streamReq req = + wrapException . fmap Http.responseBody . Http.http req intoM :: forall m a. (MonadIO m, MonadBaseControl IO m) @@ -203,17 +208,21 @@ , Http.path = Http.path r `slash` render m } -preparePost :: Method 'Complete f -> ByteString -> Request -> Request +preparePost :: Method 'Complete f -> Lazy.ByteString -> Request -> Request preparePost m body r = r - { Http.checkStatus = statusCheck + { Http.checkResponse = statusCheck , Http.redirectCount = 0 , Http.requestBody = Http.RequestBodyLBS body , Http.method = "POST" , Http.path = Http.path r `slash` render m } where - statusCheck s@(Status st _) hs cookie_jar = - if 200 <= st && st < 400 then Nothing else Just . toException $ Http.StatusCodeException s hs cookie_jar + statusCheck _req res = + unless (200 <= st && st < 400) $ do + chunk <- Http.brReadSome (Http.responseBody res) 1024 + Http.throwHttp (Http.StatusCodeException (() <$ res) (ByteString.Lazy.toStrict chunk)) + where + Status st _ = Http.responseStatus res wrapException :: (MonadBaseControl IO m, MonadIO m) => m a -> m a wrapException m = m `catch` (liftIO . throwIO . JenkinsHttpException) diff --git a/src/Network/HTTP/Client/Lens.hs b/src/Network/HTTP/Client/Lens.hs --- a/src/Network/HTTP/Client/Lens.hs +++ b/src/Network/HTTP/Client/Lens.hs @@ -16,39 +16,16 @@ , rawBody , decompress , redirectCount - , checkStatus + , checkResponse , responseTimeout , cookieJar - , getConnectionWrapper - -- * 'HttpException' prisms - , AsHttpException(..) - , _StatusCodeException - , _InvalidUrlException - , _TooManyRedirects - , _UnparseableRedirect - , _TooManyRetries - , _HttpParserException - , _HandshakeFailed - , _OverlongHeaders - , _ResponseTimeout - , _FailedConnectionException - , _ExpectedBlankAfter100Continue - , _InvalidStatusLine - , _InvalidHeader - , _InternalIOException - , _ProxyConnectException - , _NoResponseDataReceived - , _TlsException - , _TlsNotSupported - , _ResponseBodyTooShort - , _InvalidChunkHeaders - , _IncompleteHeaders + , requestVersion + , onRequestBodyException + , requestManagerOverride ) where -import Control.Exception (SomeException, IOException) +import Control.Exception (SomeException) import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as Lazy -import Data.Word (Word64) import qualified Network.HTTP.Client as H import qualified Network.HTTP.Client.Internal as H import qualified Network.HTTP.Types as H @@ -87,16 +64,16 @@ queryString f req = f (H.queryString req) <&> \qs' -> req { H.queryString = qs' } {-# INLINE queryString #-} --- | 'H.requestBody' lens -requestBody :: Lens' H.Request H.RequestBody -requestBody f req = f (H.requestBody req) <&> \rb' -> req { H.requestBody = rb' } -{-# INLINE requestBody #-} - -- | 'H.requestHeaders' lens requestHeaders :: Lens' H.Request H.RequestHeaders requestHeaders f req = f (H.requestHeaders req) <&> \rh' -> req { H.requestHeaders = rh' } {-# INLINE requestHeaders #-} +-- | 'H.requestBody' lens +requestBody :: Lens' H.Request H.RequestBody +requestBody f req = f (H.requestBody req) <&> \rb' -> req { H.requestBody = rb' } +{-# INLINE requestBody #-} + -- | 'H.proxy' proxy :: Lens' H.Request (Maybe H.Proxy) proxy f req = f (H.proxy req) <&> \mp' -> req { H.proxy = mp' } @@ -122,13 +99,13 @@ redirectCount f req = f (H.redirectCount req) <&> \rc' -> req { H.redirectCount = rc' } {-# INLINE redirectCount #-} --- | 'H.checkStatus' lens -checkStatus :: Lens' H.Request (H.Status -> H.ResponseHeaders -> H.CookieJar -> Maybe SomeException) -checkStatus f req = f (H.checkStatus req) <&> \cs' -> req { H.checkStatus = cs' } -{-# INLINE checkStatus #-} +-- | 'H.checkResponse' lens +checkResponse :: Lens' H.Request (H.Request -> H.Response H.BodyReader -> IO ()) +checkResponse f req = f (H.checkResponse req) <&> \cr' -> req { H.checkResponse = cr' } +{-# INLINE checkResponse #-} -- | 'H.responseTimeout' lens -responseTimeout :: Lens' H.Request (Maybe Int) +responseTimeout :: Lens' H.Request H.ResponseTimeout responseTimeout f req = f (H.responseTimeout req) <&> \rt' -> req { H.responseTimeout = rt' } {-# INLINE responseTimeout #-} @@ -137,180 +114,17 @@ cookieJar f req = f (H.cookieJar req) <&> \mcj' -> req { H.cookieJar = mcj' } {-# INLINE cookieJar #-} --- | 'H.getConnectionWrapper' -getConnectionWrapper - :: Lens' H.Request - ( Maybe Int - -> H.HttpException - -> IO (H.ConnRelease, H.Connection, H.ManagedConn) - -> IO (Maybe Int, (H.ConnRelease, H.Connection, H.ManagedConn)) - ) -getConnectionWrapper f req = - f (H.getConnectionWrapper req) <&> \wat' -> req { H.getConnectionWrapper = wat' } -{-# INLINE getConnectionWrapper #-} - - --- | @http-conduit@ exceptions -class AsHttpException t where - -- | @http-conduit@ exceptions overloading - _HttpException :: Prism' t H.HttpException - -instance AsHttpException H.HttpException where - _HttpException = id - {-# INLINE _HttpException #-} - -instance AsHttpException SomeException where - _HttpException = exception - {-# INLINE _HttpException #-} - --- | 'H.StatusCodeException' exception -_StatusCodeException :: AsHttpException t => Prism' t (H.Status, H.ResponseHeaders, H.CookieJar) -_StatusCodeException = _HttpException . prism' (uncurry3 H.StatusCodeException) go where - go (H.StatusCodeException s rh cj) = Just (s, rh, cj) - go _ = Nothing -{-# INLINE _StatusCodeException #-} - --- | 'H.InvalidUrlException' exception -_InvalidUrlException :: AsHttpException t => Prism' t (String, String) -_InvalidUrlException = _HttpException . prism' (uncurry H.InvalidUrlException) go where - go (H.InvalidUrlException s s') = Just (s, s') - go _ = Nothing -{-# INLINE _InvalidUrlException #-} - --- | 'H.TooManyRedirects' exception -_TooManyRedirects :: AsHttpException t => Prism' t [H.Response Lazy.ByteString] -_TooManyRedirects = _HttpException . prism' H.TooManyRedirects go where - go (H.TooManyRedirects rs) = Just rs - go _ = Nothing -{-# INLINE _TooManyRedirects #-} - --- | 'H.UnparseableRedirect' exception -_UnparseableRedirect :: AsHttpException t => Prism' t (H.Response Lazy.ByteString) -_UnparseableRedirect = _HttpException . prism' H.UnparseableRedirect go where - go (H.UnparseableRedirect r) = Just r - go _ = Nothing -{-# INLINE _UnparseableRedirect #-} - --- | 'H.TooManyRetries' exception -_TooManyRetries :: AsHttpException t => Prism' t () -_TooManyRetries = _HttpException . prism' (const H.TooManyRetries) go where - go H.TooManyRetries = Just () - go _ = Nothing -{-# INLINE _TooManyRetries #-} - --- | 'H.HttpParserException' exception -_HttpParserException :: AsHttpException t => Prism' t String -_HttpParserException = _HttpException . prism' H.HttpParserException go where - go (H.HttpParserException s) = Just s - go _ = Nothing -{-# INLINE _HttpParserException #-} - --- | 'H.HandshakeFailed' exception -_HandshakeFailed :: AsHttpException t => Prism' t () -_HandshakeFailed = _HttpException . prism' (const H.HandshakeFailed) go where - go H.HandshakeFailed = Just () - go _ = Nothing -{-# INLINE _HandshakeFailed #-} - --- | 'H.OverlongHeaders' exception -_OverlongHeaders :: AsHttpException t => Prism' t () -_OverlongHeaders = _HttpException . prism' (const H.OverlongHeaders) go where - go H.OverlongHeaders = Just () - go _ = Nothing -{-# INLINE _OverlongHeaders #-} - --- | 'H.ResponseTimeout' exception -_ResponseTimeout :: AsHttpException t => Prism' t () -_ResponseTimeout = _HttpException . prism' (const H.ResponseTimeout) go where - go H.ResponseTimeout = Just () - go _ = Nothing -{-# INLINE _ResponseTimeout #-} - --- | 'H.FailedConnectionException' exception -_FailedConnectionException :: AsHttpException t => Prism' t (String, Int) -_FailedConnectionException = _HttpException . prism' (uncurry H.FailedConnectionException) go where - go (H.FailedConnectionException s i) = Just (s, i) - go _ = Nothing -{-# INLINE _FailedConnectionException #-} - --- | 'H.ExpectedBlankAfter100Continue' exception -_ExpectedBlankAfter100Continue :: AsHttpException t => Prism' t () -_ExpectedBlankAfter100Continue = - _HttpException . prism' (const H.ExpectedBlankAfter100Continue) go where - go H.ExpectedBlankAfter100Continue = Just () - go _ = Nothing -{-# INLINE _ExpectedBlankAfter100Continue #-} - --- | 'H.InvalidStatusLine' exception -_InvalidStatusLine :: AsHttpException t => Prism' t ByteString -_InvalidStatusLine = _HttpException . prism' H.InvalidStatusLine go where - go (H.InvalidStatusLine b) = Just b - go _ = Nothing -{-# INLINE _InvalidStatusLine #-} - --- | 'H.InvalidHeader' exception -_InvalidHeader :: AsHttpException t => Prism' t ByteString -_InvalidHeader = _HttpException . prism' H.InvalidHeader go where - go (H.InvalidHeader b) = Just b - go _ = Nothing -{-# INLINE _InvalidHeader #-} - --- | 'H.InternalIOException' exception -_InternalIOException :: AsHttpException t => Prism' t IOException -_InternalIOException = _HttpException . prism' H.InternalIOException go where - go (H.InternalIOException ioe) = Just ioe - go _ = Nothing -{-# INLINE _InternalIOException #-} - --- | 'H.ProxyConnectException' exception -_ProxyConnectException :: AsHttpException t => Prism' t (ByteString, Int, Either ByteString H.HttpException) -_ProxyConnectException = _HttpException . prism' (uncurry3 H.ProxyConnectException) go where - go (H.ProxyConnectException b i ebhe) = Just (b, i, ebhe) - go _ = Nothing -{-# INLINE _ProxyConnectException #-} - --- | 'H.NoResponseDataReceived' exception -_NoResponseDataReceived :: AsHttpException t => Prism' t () -_NoResponseDataReceived = _HttpException . prism' (const H.NoResponseDataReceived) go where - go H.NoResponseDataReceived = Just () - go _ = Nothing -{-# INLINE _NoResponseDataReceived #-} - --- | 'H.TlsException' exception -_TlsException :: AsHttpException t => Prism' t SomeException -_TlsException = _HttpException . prism' H.TlsException go where - go (H.TlsException se) = Just se - go _ = Nothing -{-# INLINE _TlsException #-} - --- | 'H.TlsNotSupported' exception -_TlsNotSupported :: AsHttpException t => Prism' t () -_TlsNotSupported = _HttpException . prism' (const H.TlsNotSupported) go where - go H.TlsNotSupported = Just () - go _ = Nothing -{-# INLINE _TlsNotSupported #-} - --- | 'H.ResponseBodyTooShort' exception -_ResponseBodyTooShort :: AsHttpException t => Prism' t (Word64, Word64) -_ResponseBodyTooShort = _HttpException . prism' (uncurry H.ResponseBodyTooShort) go where - go (H.ResponseBodyTooShort w w') = Just (w, w') - go _ = Nothing -{-# INLINE _ResponseBodyTooShort #-} - --- | 'H.InvalidChunkHeaders' exception -_InvalidChunkHeaders :: AsHttpException t => Prism' t () -_InvalidChunkHeaders = _HttpException . prism' (const H.InvalidChunkHeaders) go where - go H.InvalidChunkHeaders = Just () - go _ = Nothing -{-# INLINE _InvalidChunkHeaders #-} +-- | 'H.requestVersion' lens +requestVersion :: Lens' H.Request H.HttpVersion +requestVersion f req = f (H.requestVersion req) <&> \rv' -> req { H.requestVersion = rv' } +{-# INLINE requestVersion #-} --- | 'H.IncompleteHeaders' exception -_IncompleteHeaders :: AsHttpException t => Prism' t () -_IncompleteHeaders = _HttpException . prism' (const H.IncompleteHeaders) go where - go H.IncompleteHeaders = Just () - go _ = Nothing -{-# INLINE _IncompleteHeaders #-} +-- | 'H.onRequestBodyException' lens +onRequestBodyException :: Lens' H.Request (SomeException -> IO ()) +onRequestBodyException f req = f (H.onRequestBodyException req) <&> \cb -> req { H.onRequestBodyException = cb } +{-# INLINE onRequestBodyException #-} -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c -{-# INLINE uncurry3 #-} +-- | 'H.requestManagerOverride' lens +requestManagerOverride :: Lens' H.Request (Maybe H.Manager) +requestManagerOverride f req = f (H.requestManagerOverride req) <&> \m' -> req { H.requestManagerOverride = m' } +{-# INLINE requestManagerOverride #-} diff --git a/test/Jenkins/Rest/InternalSpec.hs b/test/Jenkins/Rest/InternalSpec.hs --- a/test/Jenkins/Rest/InternalSpec.hs +++ b/test/Jenkins/Rest/InternalSpec.hs @@ -2,10 +2,9 @@ module Jenkins.Rest.InternalSpec (spec) where import Control.Lens -import Control.Exception (throwIO) -import Control.Exception.Lens (throwingM, _IOException) -import Network.HTTP.Client (HttpException) -import Network.HTTP.Types (Status(..)) +import Control.Exception (SomeException, throwIO) +import Control.Exception.Lens (_IOException) +import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) import Test.Hspec.Lens import System.IO.Error import System.IO.Error.Lens (errorType, _NoSuchThing) @@ -13,7 +12,6 @@ import Jenkins.Rest (Jenkins, liftIO) import qualified Jenkins.Rest as Jenkins import Jenkins.Rest.Internal -import Network.HTTP.Client.Lens (_StatusCodeException, _InvalidUrlException, _TooManyRetries) _JenkinsException :: Iso' JenkinsException HttpException _JenkinsException = iso (\(JenkinsHttpException e) -> e) JenkinsHttpException @@ -21,7 +19,7 @@ spec :: Spec spec = do let raiseHttp, raiseIO :: Jenkins a - raiseHttp = liftIO (throwingM _TooManyRetries ()) + raiseHttp = liftIO (throwIO (HttpExceptionRequest "http://example.com" OverlongHeaders)) raiseIO = liftIO (throwIO (mkIOError doesNotExistErrorType "foo" Nothing Nothing)) master = Jenkins.Master { Jenkins.url = "http://example.com/jenkins" @@ -32,11 +30,11 @@ describe "runJenkins" $ do it "wraps uncatched 'HttpException' exceptions from the queries in 'Error'" $ do r <- Jenkins.run master (Jenkins.get Jenkins.plain "hi") - r `shouldPreview` Status 404 "" `through` _Left._JenkinsException._StatusCodeException._1 + r `shouldHave` _Left._JenkinsException it "wraps uncatched 'HttpException' exceptions from the URL parsing in 'Error'" $ do r <- Jenkins.run (master { Jenkins.url = "foo" }) (Jenkins.get Jenkins.plain "hi") - r `shouldPreview` ("foo", "Invalid URL") `through` _Left._JenkinsException._InvalidUrlException + r `shouldHave` _Left._JenkinsException it "can catch 'HttpException' exceptions related from the queries" $ do r <- Jenkins.run master @@ -44,7 +42,7 @@ r `shouldPreview` (7 :: Integer) `through` _Right it "does not catch (and wrap) 'HttpException's not from the queries" $ - Jenkins.run master raiseHttp `shouldThrow` _TooManyRetries + Jenkins.run master raiseHttp `shouldThrow` (id :: Prism' SomeException SomeException) it "does not catch (and wrap) 'IOException's" $ Jenkins.run master raiseIO `shouldThrow` _IOException.errorType._NoSuchThing