http-conduit-downloader 1.1.2 → 1.1.3
raw patch · 2 files changed
+29/−132 lines, 2 filesdep +http-client-openssldep ~HsOpenSSLdep ~http-clientPVP ok
version bump matches the API change (PVP)
Dependencies added: http-client-openssl
Dependency ranges changed: HsOpenSSL, http-client
API changes (from Hackage documentation)
Files
Network/HTTP/Conduit/Downloader.hs view
@@ -81,13 +81,13 @@ import Data.List import Foreign import qualified Network.Socket as NS-import qualified Network.Socket.ByteString as NS+ import qualified OpenSSL as SSL import qualified OpenSSL.Session as SSL import qualified Network.HTTP.Types as N import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client.Internal as C-import System.Timeout+import qualified Network.HTTP.Client.OpenSSL as C import Codec.Compression.Zlib.Raw as Deflate import Network.URI import System.IO.Unsafe@@ -145,10 +145,8 @@ { dsUserAgent = "Mozilla/5.0 (compatible; HttpConduitDownloader/1.0; +http://hackage.haskell.org/package/http-conduit-downloader)" , dsTimeout = 30 , dsManagerSettings =- C.defaultManagerSettings- { C.managerTlsConnection = getOpenSSLConnection- , C.managerTlsProxyConnection = getOpenSSLProxyConnection- , C.managerProxyInsecure = C.proxyFromRequest+ (C.opensslManagerSettings $ return globalSSLContext)+ { C.managerProxyInsecure = C.proxyFromRequest , C.managerProxySecure = C.proxyFromRequest } , dsMaxDownloadSize = 10*1024*1024@@ -156,34 +154,9 @@ -- tls package doesn't handle some sites: -- https://github.com/vincenthz/hs-tls/issues/53+-- plus tls is about 2 times slower than HsOpenSSL -- using OpenSSL instead------ Network.HTTP.Client.TLS.getTlsConnection with ability to use HostAddress--- since Network.Connection.connectTo uses Network.connectTo that uses--- getHostByName (passed HostAddress is ignored)-getOpenSSLConnection :: IO (Maybe NS.HostAddress -> String -> Int- -> IO C.Connection)-getOpenSSLConnection =- return $ \ mbha host port -> do- let c sock = makeSSLConnection sock host- case mbha of- Nothing -> openSocketByName host port c- Just ha -> openSocket ha port c -getOpenSSLProxyConnection :: IO (B.ByteString -> (C.Connection -> IO ()) -> String -> Maybe NS.HostAddress -> String -> Int -> IO C.Connection)-getOpenSSLProxyConnection =- return $ \ connstr checkConn serverName _mbha host port -> do- openSocketByName host port $ \ sock -> do- sc <- C.makeConnection- (NS.recv sock 8129)- (NS.sendAll sock)- (return ())- -- No NS.close since C.makeConnection creates finalizer which- -- calls it prematurely since sc is never used after checkConn.- C.connectionWrite sc connstr- checkConn sc- makeSSLConnection sock serverName- globalSSLContext :: SSL.SSLContext globalSSLContext = unsafePerformIO $ do ctx <- SSL.context@@ -194,63 +167,6 @@ return ctx {-# NOINLINE globalSSLContext #-} -makeSSLConnection :: NS.Socket -> String -> IO C.Connection-makeSSLConnection sock host = do- ssl <- SSL.connection globalSSLContext sock- SSL.setTlsextHostName ssl host- SSL.connect ssl- C.makeConnection- (SSL.read ssl bufSize- `E.catch`- \ (_ :: SSL.ConnectionAbruptlyTerminated) -> return ""- )- (SSL.write ssl)- -- Closing an SSL connection gracefully involves writing/reading- -- on the socket. But when this is called the socket might be- -- already closed, and we get a @ResourceVanished@.- (NS.close sock `E.catch` \(_ :: E.IOException) -> return ())--- ((SSL.shutdown ssl SSL.Bidirectional >> return ()) `E.catch` \(_ :: E.IOException) -> return ())--- segmentation fault in GHCi with SSL.shutdown / tryShutdown SSL.Unidirectional--- hang with SSL.Bidirectional---- slightly modified Network.HTTP.Client.Connection.openSocketConnection-openSocket :: NS.HostAddress- -> Int -- ^ port- -> (NS.Socket -> IO a)- -> IO a-openSocket ha port act =- openSocket'- NS.AddrInfo- { NS.addrFlags = []- , NS.addrFamily = NS.AF_INET- , NS.addrSocketType = NS.Stream- , NS.addrProtocol = 6 -- tcp- , NS.addrAddress = NS.SockAddrInet (toEnum port) ha- , NS.addrCanonName = Nothing- }- act-openSocket' :: NS.AddrInfo -> (NS.Socket -> IO a) -> IO a-openSocket' addr act = do- E.bracketOnError- (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)- (NS.addrProtocol addr))- (NS.close)- (\sock -> do- NS.setSocketOption sock NS.NoDelay 1- NS.connect sock (NS.addrAddress addr)- act sock)--openSocketByName :: NS.HostName -> Int -> (NS.Socket -> IO a) -> IO a-openSocketByName host port act = do- let hints = NS.defaultHints- { NS.addrFlags = []-- [NS.AI_ADDRCONFIG, NS.AI_NUMERICSERV]- , NS.addrFamily = NS.AF_INET- , NS.addrSocketType = NS.Stream- , NS.addrProtocol = 6 -- tcp- }- (addrInfo:_) <- NS.getAddrInfo (Just hints) (Just host) (Just $ show port)- openSocket' addrInfo act- -- | Keeps http-client 'Manager' and 'DownloaderSettings'. data Downloader = Downloader@@ -329,7 +245,8 @@ (E.fromException e) Right rq -> do let dl req firstTime = do- r <- (timeout (dsTimeout settings * 1000000) $ C.withResponse req manager $ \ r -> do+ r <- E.handle (fmap (, Nothing) . httpExceptionToDR url) $+ C.withResponse req manager $ \ r -> do let s = C.responseStatus r h = C.responseHeaders r rdr d =@@ -353,7 +270,6 @@ _ -> sinkByteString (C.brRead $ C.responseBody r) (dsMaxDownloadSize settings)--- liftIO $ print ("sink", mbb) case mbb of Just b -> do let d = tryDeflate h b@@ -362,33 +278,15 @@ (makeDownloadResultC curTime url s h d , Just $ rdr d) Nothing ->- return (DRError "Too much data", Just $ rdr ""))- `E.catch`- (fmap (Just . (, Nothing)) . httpExceptionToDR url)--- `E.catch`--- (return . Just . handshakeFailed)- `E.catch`- (return . (Just . (, Nothing)) . someException)+ return (DRError "Too much data", Just $ rdr "") case r of- Just (DRError e, _)- | ("EOF reached" `isSuffixOf` e- || e == "Invalid HTTP status line:\n"- || e == "Incomplete headers"- ) && firstTime ->- dl req False- -- "EOF reached" or empty HTTP status line- -- can happen on servers that fails to- -- implement HTTP/1.1 persistent connections.- -- Try again- -- https://github.com/snoyberg/http-conduit/issues/89- -- Fixed in- -- https://github.com/snoyberg/http-conduit/issues/117+ (DRError e, _) | "ZlibException" `isPrefixOf` e && firstTime -> -- some sites return junk instead of gzip data. -- retrying without compression dl (disableCompression req) False _ ->- return $ fromMaybe (DRError "Timeout", Nothing) r+ return r disableCompression req = req { C.requestHeaders = ("Accept-Encoding", "") : C.requestHeaders req }@@ -399,10 +297,8 @@ ++ map toHeader opts ++ C.requestHeaders rq , C.redirectCount = 0- , C.responseTimeout = C.responseTimeoutNone- -- We have timeout for connect and downloading- -- while http-client timeouts only when waits for- -- headers.+ , C.responseTimeout =+ C.responseTimeoutMicro $ dsTimeout settings * 1000000 , C.hostAddress = hostAddress , C.checkResponse = \ _ _ -> return () }@@ -411,10 +307,6 @@ where toHeader :: String -> N.Header toHeader h = let (a,b) = break (== ':') h in (fromString a, fromString (tail b))- someException :: E.SomeException -> DownloadResult- someException e = case show e of- "<<timeout>>" -> DRError "Timeout"- s -> DRError s tryDeflate headers b | Just d <- lookup "Content-Encoding" headers , B.map toLower d == "deflate"@@ -435,17 +327,20 @@ (C.responseStatus r) (C.responseHeaders r) b C.TooManyRedirects _ -> DRError "Too many redirects" C.OverlongHeaders -> DRError "Overlong HTTP headers"- C.ResponseTimeout -> DRError "Timeout"+ C.ResponseTimeout -> DRError "Response timeout" C.ConnectionTimeout -> DRError "Connection timeout" C.ConnectionFailure e -> DRError $ "Connection failed: " ++ show e C.InvalidStatusLine l -> DRError $ "Invalid HTTP status line:\n" ++ B.unpack l C.InvalidHeader h -> DRError $ "Invalid HTTP header:\n" ++ B.unpack h C.InvalidRequestHeader h -> DRError $ "Invalid HTTP request header:\n" ++ B.unpack h- C.InternalException e ->- case show e of- "<<timeout>>" -> DRError "Timeout"- s -> DRError s- C.ProxyConnectException _ _ _ -> DRError "Can't connect to proxy"+ C.InternalException e+ | Just (_ :: SSL.ConnectionAbruptlyTerminated) <- E.fromException e ->+ DRError "Connection abruptly terminated"+ | Just (SSL.ProtocolError pe) <- E.fromException e ->+ DRError $ "SSL protocol error: " <> pe+ | otherwise -> DRError $ show e+ C.ProxyConnectException _ _ s ->+ DRError $ "Proxy CONNECT failed: " ++ httpStatusString s C.NoResponseDataReceived -> DRError "No response data received" C.TlsNotSupported -> DRError "TLS not supported" C.WrongRequestBodyStreamSize e a ->@@ -531,8 +426,7 @@ ++ B.unpack (N.statusMessage c) ++ "\n" ++ unlines (map show headers) else if N.statusCode c >= 300 then- DRError $ "HTTP " ++ show (N.statusCode c) ++ " "- ++ B.unpack (N.statusMessage c)+ DRError $ httpStatusString c else DROK b (redownloadOpts [] headers) where redirect r@@ -569,7 +463,9 @@ (parseURIReference r) (parseURI $ fixNonAscii url) --- fmap utcTimeToPOSIXSeconds $+httpStatusString :: N.Status -> [Char]+httpStatusString c =+ "HTTP " ++ show (N.statusCode c) ++ " " ++ B.unpack (N.statusMessage c) tryParseTime :: [String] -> String -> Maybe UTCTime tryParseTime formats string =
http-conduit-downloader.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: http-conduit-downloader-version: 1.1.2+version: 1.1.3 author: Vladimir Shabanov <dev@vshabanov.com> maintainer: Vladimir Shabanov <dev@vshabanov.com> homepage: https://github.com/bazqux/http-conduit-downloader@@ -47,10 +47,11 @@ default-language: Haskell2010 build-depends: base == 4.*,- http-client >= 0.7.0 && < 0.8.0,+ http-client == 0.7.3.*,+ http-client-openssl == 0.3.3.*, zlib, http-types, data-default, bytestring, text,- time >= 1.5.0, HsOpenSSL >= 0.11.2, network-uri >= 2.6, network >= 2.6+ time >= 1.5.0, HsOpenSSL >= 0.11.5, network-uri >= 2.6, network >= 2.6 exposed-modules: Network.HTTP.Conduit.Downloader