http-conduit-downloader 1.0.33 → 1.1.0

raw patch · 3 files changed

+120/−132 lines, 3 filesdep −conduitdep −connectiondep −http-conduitdep ~http-clientPVP ok

version bump matches the API change (PVP)

Dependencies removed: conduit, connection, http-conduit, mtl, resourcet

Dependency ranges changed: http-client

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Network/HTTP/Conduit/Downloader.hs +103/−122
• http-conduit-downloader.cabal +16/−9

@@ -1,4 +1,4 @@-Copyright Vladimir Shabanov 2011-2012.+Copyright Vladimir Shabanov 2011-2020. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,16 +1,16 @@ {-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards, ViewPatterns,              DoAndIfThenElse, PatternGuards, ScopedTypeVariables,              TupleSections #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-} -- | HTTP downloader tailored for web-crawler needs. -----  * Handles all possible http-conduit exceptions and returns+--  * Handles all possible http-client exceptions and returns --    human readable error messages. -- --  * Handles some web server bugs (returning @deflate@ data instead of @gzip@, --    invalid @gzip@ encoding). -----  * Uses OpenSSL instead of @tls@ package (since @tls@ doesn't handle all sites).+--  * Uses OpenSSL instead of @tls@ package (since @tls@ doesn't handle all sites and works slower than OpenSSL). -- --  * Ignores invalid SSL sertificates. --@@ -26,7 +26,7 @@ -- --  * Can be used with external DNS resolver (hsdns-cache for example). -----  * Keep-alive connections pool (thanks to http-conduit).+--  * Keep-alive connections pool (thanks to http-client). -- --  Typical workflow in crawler: --@@ -50,7 +50,7 @@ -- It's highly recommended to use -- <http://hackage.haskell.org/package/concurrent-dns-cache> -- (preferably with single resolver pointing to locally running BIND)--- for DNS resolution since @getAddrInfo@ used in @http-conduit@ can be+-- for DNS resolution since @getAddrInfo@ used in @http-client@ can be -- buggy and ineffective when it needs to resolve many hosts per second for -- a long time. --@@ -65,10 +65,9 @@     , Downloader, withDownloader, withDownloaderSettings, newDownloader        -- * Utils-    , postRequest, sinkByteString+    , postRequest     ) where -import Control.Monad.Trans import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as B@@ -82,19 +81,15 @@ import Data.List import Foreign import qualified Network.Socket as NS--- import qualified Network.TLS as TLS--- import qualified Network.Connection as NC import qualified OpenSSL as SSL import qualified OpenSSL.Session as SSL import qualified Network.HTTP.Types as N-import qualified Network.HTTP.Conduit as C-import Network.HTTP.Client.Internal (makeConnection, Connection)-import qualified Control.Monad.Trans.Resource as C-import qualified Data.Conduit as C+import qualified Network.HTTP.Client as C+import qualified Network.HTTP.Client.Internal as C import System.Timeout import Codec.Compression.Zlib.Raw as Deflate import Network.URI--- import ADNS.Cache+import System.IO.Unsafe import Data.Time.Format import Data.Time.Clock import Data.Time.Clock.POSIX@@ -120,7 +115,7 @@       , rdrBody :: B.ByteString       , rdrCookieJar :: C.CookieJar       }-    deriving (Show, Eq)+    deriving Show  -- | @If-None-Match@ and/or @If-Modified-Since@ headers. type DownloadOptions = [String]@@ -149,91 +144,76 @@         { dsUserAgent = "Mozilla/5.0 (compatible; HttpConduitDownloader/1.0; +http://hackage.haskell.org/package/http-conduit-downloader)"         , dsTimeout = 30         , dsManagerSettings =-            C.tlsManagerSettings-            { C.managerTlsConnection =-              -- IO (Maybe HostAddress -> String -> Int -> IO Connection)-              getOpenSSLConnection+            C.defaultManagerSettings+            { C.managerTlsConnection = getOpenSSLConnection+            , C.managerTlsProxyConnection = getOpenSSLProxyConnection+            , C.managerProxyInsecure = C.proxyFromRequest+            , C.managerProxySecure = C.proxyFromRequest             }---             (C.mkManagerSettings tls Nothing)---             { C.managerTlsConnection =---               -- IO (Maybe HostAddress -> String -> Int -> IO Connection)---               getTlsConnection (Just tls)---             }---             C.def { C.managerCheckCerts =---                         \ _ _ _ -> return TLS.CertificateUsageAccept }         , dsMaxDownloadSize = 10*1024*1024         }---        where tls = NC.TLSSettingsSimple True False False  -- tls package doesn't handle some sites: -- https://github.com/vincenthz/hs-tls/issues/53 -- 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 Connection)-getOpenSSLConnection = do+                            -> 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.socketConnection sock 8192+            C.connectionWrite sc connstr+            checkConn sc+            makeSSLConnection sock serverName++globalSSLContext :: SSL.SSLContext+globalSSLContext = unsafePerformIO $ do     ctx <- SSL.context --     SSL.contextSetCiphers ctx "DEFAULT" --     SSL.contextSetVerificationMode ctx SSL.VerifyNone --     SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 --     SSL.contextAddOption ctx SSL.SSL_OP_ALL-    return $ \ mbha host port -> do-        sock <- case mbha of-            Nothing -> openSocketByName host port-            Just ha -> openSocket ha port-        ssl <- SSL.connection ctx sock-        SSL.setTlsextHostName ssl host-        SSL.connect ssl-        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 ())+    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 --- Network.HTTP.Client.TLS.getTlsConnection with ability to use HostAddress--- since Network.Connection.connectTo uses Network.connectTo that uses--- getHostByName (passed HostAddress is ignored)--- getTlsConnection :: Maybe NC.TLSSettings--- --                 -> Maybe NC.SockSettings---                  -> IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)--- getTlsConnection tls = do---     context <- NC.initConnectionContext---     return $ \ mbha host port -> do---         cf <- case mbha of---             Nothing -> return $ NC.connectTo context---             Just ha -> do---                 sock <- openSocket ha port---                 handle <- NS.socketToHandle sock ReadWriteMode---                 return $ NC.connectFromHandle context handle---         conn <- cf $ NC.ConnectionParams---             { NC.connectionHostname = host---             , NC.connectionPort = fromIntegral port---             , NC.connectionUseSecure = tls---             , NC.connectionUseSocks = Nothing -- sock---             }---         convertConnection conn---   where---     convertConnection conn = makeConnection---         (NC.connectionGetChunk conn)---         (NC.connectionPut conn)---         -- 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@.---         (NC.connectionClose conn `E.catch` \(_ :: E.IOException) -> return ())- -- slightly modified Network.HTTP.Client.Connection.openSocketConnection openSocket :: NS.HostAddress            -> Int -- ^ port-           -> IO NS.Socket-openSocket ha port =-    openSocket' $+           -> (NS.Socket -> IO a)+           -> IO a+openSocket ha port act =+    openSocket'         NS.AddrInfo         { NS.addrFlags = []         , NS.addrFamily = NS.AF_INET@@ -242,8 +222,9 @@         , NS.addrAddress = NS.SockAddrInet (toEnum port) ha         , NS.addrCanonName = Nothing         }-openSocket' :: NS.AddrInfo -> IO NS.Socket-openSocket' addr = do+        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))@@ -251,10 +232,10 @@         (\sock -> do             NS.setSocketOption sock NS.NoDelay 1             NS.connect sock (NS.addrAddress addr)-            return sock)+            act sock) -openSocketByName :: Show a => NS.HostName -> a -> IO NS.Socket-openSocketByName host port = do+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@@ -262,9 +243,9 @@                 , NS.addrProtocol = 6 -- tcp                 }     (addrInfo:_) <- NS.getAddrInfo (Just hints) (Just host) (Just $ show port)-    openSocket' addrInfo+    openSocket' addrInfo act --- | Keeps http-conduit 'Manager' and 'DownloaderSettings'.+-- | Keeps http-client 'Manager' and 'DownloaderSettings'. data Downloader     = Downloader       { manager :: C.Manager@@ -312,9 +293,8 @@        , C.requestBody = C.RequestBodyBS dat }  -- | Generic version of 'download'--- with ability to modify http-conduit 'Request'.-downloadG :: -- m ~ C.ResourceT IO-                (C.Request -> C.ResourceT IO C.Request)+-- with ability to modify http-client 'Request'.+downloadG ::    (C.Request -> IO C.Request)                 -- ^ Function to modify 'Request'                 -- (e.g. sign or make 'postRequest')              -> Downloader@@ -327,8 +307,7 @@ -- | Even more generic version of 'download', which returns 'RawDownloadResult'. -- 'RawDownloadResult' is optional since it can not be determined on timeouts -- and connection errors.-rawDownload :: -- m ~ C.ResourceT IO-                (C.Request -> C.ResourceT IO C.Request)+rawDownload ::  (C.Request -> IO C.Request)                 -- ^ Function to modify 'Request'                 -- (e.g. sign or make 'postRequest')              -> Downloader@@ -344,19 +323,18 @@               (E.fromException e)     Right rq -> do         let dl req firstTime = do-                r <- (timeout (dsTimeout settings * 1000000) $ C.runResourceT $ do-                    r <- C.http req manager-                    let c = C.responseStatus r+                r <- (timeout (dsTimeout settings * 1000000) $ C.withResponse req manager $ \ r -> do+                    let s = C.responseStatus r                         h = C.responseHeaders r                         rdr d =                             RawDownloadResult-                            { rdrStatus = c+                            { rdrStatus = s                             , rdrHttpVersion = C.responseVersion r                             , rdrHeaders = h                             , rdrBody = d                             , rdrCookieJar = C.responseCookieJar r                             }-                        readLen = B.foldl' (\ r d -> r * 10 + ord d - ord '0') 0+                        readLen = B.foldl' (\ a d -> a * 10 + ord d - ord '0') 0                     mbb <- case lookup "Content-Length" h of                         Just l                             | B.all (\ c -> c >= '0' && c <= '9') l@@ -367,15 +345,15 @@                                return Nothing                                -- no reason to download body                         _ ->-                            C.sealConduitT (C.responseBody r) C.$$+--                                sinkByteString (dsMaxDownloadSize settings)+                            sinkByteString (C.brRead $ C.responseBody r)+                                (dsMaxDownloadSize settings) --                    liftIO $ print ("sink", mbb)                     case mbb of                         Just b -> do                             let d = tryDeflate h b-                            curTime <- liftIO $ getCurrentTime+                            curTime <- getCurrentTime                             return-                                (makeDownloadResultC curTime url c h d+                                (makeDownloadResultC curTime url s h d                                 , Just $ rdr d)                         Nothing ->                             return (DRError "Too much data", Just $ rdr ""))@@ -417,12 +395,12 @@                      , C.redirectCount = 0                      , C.responseTimeout = C.responseTimeoutNone                        -- We have timeout for connect and downloading-                       -- while http-conduit timeouts only when waits for+                       -- while http-client timeouts only when waits for                        -- headers.                      , C.hostAddress = hostAddress                      , C.checkResponse = \ _ _ -> return ()                      }-        req <- C.runResourceT $ f rq1+        req <- f rq1         dl req True     where toHeader :: String -> N.Header           toHeader h = let (a,b) = break (== ':') h in@@ -508,22 +486,21 @@  -- | Sink data using 32k buffers to reduce memory fragmentation. -- Returns 'Nothing' if downloaded too much data.-sinkByteString :: MonadIO m => Int -> C.ConduitT B.ByteString C.Void m (Maybe B.ByteString)-sinkByteString limit = do-    buf <- liftIO $ newBuf+sinkByteString :: IO B.ByteString -> Int -> IO (Maybe B.ByteString)+sinkByteString readChunk limit = do+    buf <- newBuf     go 0 [] buf     where go len acc buf = do-              mbinp <- C.await-              case mbinp of-                  Just inp -> do-                      (acc', buf') <- liftIO $ addBs acc buf inp-                      let len' = len + B.length inp-                      if len' > limit then-                          return Nothing-                      else-                          go len' acc' buf'-                  Nothing -> do-                      return $ Just $ B.concat $ reverse (buf:acc)+              inp <- readChunk+              if B.null inp then+                  return $ Just $ B.concat $ reverse (buf:acc)+              else do+                  (acc', buf') <- addBs acc buf inp+                  let len' = len + B.length inp+                  if len' > limit then+                      return Nothing+                  else+                      go len' acc' buf'  makeDownloadResultC :: UTCTime -> String -> N.Status -> N.ResponseHeaders                     -> B.ByteString -> DownloadResult@@ -604,11 +581,15 @@     ,"%a %b %e %k:%M:%S %Y"     -- Sun Nov  6 08:49:37 1994     ] +globalDownloader :: Downloader+globalDownloader = unsafePerformIO $ newDownloader def+{-# NOINLINE globalDownloader #-}+ -- | Download single URL with default 'DownloaderSettings'. -- Fails if result is not 'DROK'. urlGetContents :: String -> IO B.ByteString-urlGetContents url = withDownloader $ \ d -> do-    r <- download d url Nothing []+urlGetContents url = do+    r <- download globalDownloader url Nothing []     case r of         DROK c _ -> return c         e -> fail $ "urlGetContents " ++ show url ++ ": " ++ show e@@ -616,8 +597,8 @@ -- | Post data and download single URL with default 'DownloaderSettings'. -- Fails if result is not 'DROK'. urlGetContentsPost :: String -> B.ByteString -> IO B.ByteString-urlGetContentsPost url dat = withDownloader $ \ d -> do-    r <- post d url Nothing dat+urlGetContentsPost url dat = do+    r <- post globalDownloader url Nothing dat     case r of         DROK c _ -> return c         e -> fail $ "urlGetContentsPost " ++ show url ++ ": " ++ show e

@@ -1,25 +1,29 @@-cabal-version:  >= 1.6+cabal-version:  2.4 name:           http-conduit-downloader-version:        1.0.33+version:        1.1.0 author:         Vladimir Shabanov <vshabanoff@gmail.com> maintainer:     Vladimir Shabanov <vshabanoff@gmail.com> homepage:       https://github.com/bazqux/http-conduit-downloader-license:        BSD3+license:        BSD-3-Clause category:       Web license-file:   LICENSE build-type:     Simple synopsis:       HTTP downloader tailored for web-crawler needs. description:-    HTTP/HTTPS downloader built on top of @http-conduit@+    HTTP/HTTPS downloader built on top of @http-client@     and used in <https://bazqux.com> crawler.     .-     * Handles all possible http-conduit exceptions and returns+    Previously it was based on @http-conduit@ (hence the name) but since+    all the necessary parts are in @http-client@ now @http-conduit@ is no+    longer used.+    .+     * Handles all possible http-client exceptions and returns        human readable error messages.     .      * Handles some web server bugs (returning 'deflate' data instead of 'gzip',        invalid 'gzip' encoding).     .-     * Uses OpenSSL instead of 'tls' package (since 'tls' doesn't handle all sites).+     * Uses OpenSSL instead of 'tls' package (since 'tls' doesn't handle all sites and works slower than OpenSSL).     .      * Ignores invalid SSL sertificates.     .@@ -33,16 +37,19 @@      * Returns HTTP headers for subsequent redownloads and handles        'Not modified' results.     .-     * Can be used with external DNS resolver (e.g. concurrent-dns-cache).+     * Can be used with external DNS resolver (e.g. @concurrent-dns-cache@).  source-repository head     type:     git     location: https://github.com/bazqux/http-conduit-downloader  library+    default-language: Haskell2010     build-depends:-        base == 4.*, http-conduit >= 2.3.4, http-client >= 0.6.1, connection, zlib,-        conduit, resourcet, http-types, data-default, bytestring, text, mtl,+        base == 4.*,+        http-client >= 0.7.0 && < 0.8.0,+        zlib,+        http-types, data-default, bytestring, text,         time >= 1.5.0, HsOpenSSL >= 0.11.2, network-uri >= 2.6, network >= 2.6      exposed-modules: