diff --git a/Network/HTTP/Conduit/Downloader.hs b/Network/HTTP/Conduit/Downloader.hs --- a/Network/HTTP/Conduit/Downloader.hs +++ b/Network/HTTP/Conduit/Downloader.hs @@ -95,10 +95,8 @@ import Network.URI -- import ADNS.Cache import Data.Time.Format -import System.Locale import Data.Time.Clock import Data.Time.Clock.POSIX -import System.IO -- | Result of 'download' operation. data DownloadResult @@ -150,7 +148,7 @@ { dsUserAgent = "Mozilla/5.0 (compatible; HttpConduitDownloader/1.0; +http://hackage.haskell.org/package/http-conduit-downloader)" , dsTimeout = 30 , dsManagerSettings = - C.conduitManagerSettings + C.tlsManagerSettings { C.managerTlsConnection = -- IO (Maybe HostAddress -> String -> Int -> IO Connection) getOpenSSLConnection @@ -173,11 +171,16 @@ -> IO Connection) getOpenSSLConnection = 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 @@ -188,7 +191,7 @@ -- 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.sClose sock `E.catch` \(_ :: E.IOException) -> return ()) + (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 @@ -238,16 +241,18 @@ , NS.addrAddress = NS.SockAddrInet (toEnum port) ha , NS.addrCanonName = Nothing } +openSocket' :: NS.AddrInfo -> IO NS.Socket openSocket' addr = do E.bracketOnError (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr)) - (NS.sClose) + (NS.close) (\sock -> do NS.setSocketOption sock NS.NoDelay 1 NS.connect sock (NS.addrAddress addr) return sock) +openSocketByName :: Show a => NS.HostName -> a -> IO NS.Socket openSocketByName host port = do let hints = NS.defaultHints { NS.addrFlags = []-- [NS.AI_ADDRCONFIG, NS.AI_NUMERICSERV] @@ -280,12 +285,10 @@ -- | Create a new 'Downloader' with provided settings, -- use it in the provided function, and then release it. withDownloaderSettings :: DownloaderSettings -> (Downloader -> IO a) -> IO a -withDownloaderSettings s f = SSL.withOpenSSL $ C.runResourceT $ do - (_, m) <- C.allocate (C.newManager $ dsManagerSettings s) C.closeManager - liftIO $ f (Downloader m s) +withDownloaderSettings s f = f =<< newDownloader s parseUrl :: String -> Either E.SomeException C.Request -parseUrl = C.parseUrl . takeWhile (/= '#') +parseUrl = C.parseRequest . takeWhile (/= '#') -- | Perform download download :: Downloader @@ -339,24 +342,6 @@ maybe (return $ DRError $ show e) (httpExceptionToDR url) (E.fromException e) Right rq -> do - let rq1 = rq { C.requestHeaders = - [("Accept", "*/*") - ,("User-Agent", dsUserAgent settings) - ] - ++ map toHeader opts - ++ C.requestHeaders rq - , C.redirectCount = 0 - , C.responseTimeout = Nothing - -- We have timeout for connect and downloading - -- while http-conduit timeouts only when waits for - -- headers. - , C.hostAddress = hostAddress - , C.checkStatus = \ _ _ _ -> Nothing - } - disableCompression rq = - rq { C.requestHeaders = - ("Accept-Encoding", "") : C.requestHeaders rq } - req <- C.runResourceT $ f rq1 let dl req firstTime = do r <- C.runResourceT (timeout (dsTimeout settings * 1000000) $ do r <- C.http req manager @@ -405,16 +390,28 @@ dl (disableCompression req) False _ -> return $ fromMaybe (DRError "Timeout", Nothing) r + disableCompression req = + req { C.requestHeaders = + ("Accept-Encoding", "") : C.requestHeaders req } + rq1 = rq { C.requestHeaders = + [("Accept", "*/*") + ,("User-Agent", dsUserAgent settings) + ] + ++ map toHeader opts + ++ C.requestHeaders rq + , C.redirectCount = 0 + , C.responseTimeout = C.responseTimeoutNone + -- We have timeout for connect and downloading + -- while http-conduit timeouts only when waits for + -- headers. + , C.hostAddress = hostAddress + , C.checkResponse = \ _ _ -> return () + } + req <- C.runResourceT $ f rq1 dl req True where toHeader :: String -> N.Header toHeader h = let (a,b) = break (== ':') h in (fromString a, fromString (tail b)) --- handshakeFailed (TLS.Terminated _ e tlsError) = --- DRError $ "SSL terminated:\n" ++ show tlsError --- handshakeFailed (TLS.HandshakeFailed tlsError) = --- DRError $ "SSL handshake failed:\n" ++ show tlsError --- handshakeFailed TLS.ConnectionNotEstablished = --- DRError $ "SSL connection not established" someException :: E.SomeException -> DownloadResult someException e = case show e of "<>" -> DRError "Timeout" @@ -425,40 +422,45 @@ = BL.toStrict $ Deflate.decompress $ BL.fromStrict b | otherwise = b - - httpExceptionToDR :: Monad m => String -> C.HttpException -> m DownloadResult httpExceptionToDR url exn = return $ case exn of - C.StatusCodeException c h _ -> -- trace "exception" $ - makeDownloadResultC - (posixSecondsToUTCTime 0) url c h "" + C.HttpExceptionRequest _ ec -> httpExceptionContentToDR url ec C.InvalidUrlException _ e -> DRError $ "Invalid URL: " ++ e + +httpExceptionContentToDR :: String -> C.HttpExceptionContent -> DownloadResult +httpExceptionContentToDR url ec = case ec of + C.StatusCodeException r b -> + makeDownloadResultC (posixSecondsToUTCTime 0) url + (C.responseStatus r) (C.responseHeaders r) b C.TooManyRedirects _ -> DRError "Too many redirects" - C.UnparseableRedirect _ -> DRError "Unparseable redirect" - C.TooManyRetries -> DRError "Too many retries" - C.HttpParserException e -> DRError $ "HTTP parser error: " ++ e - C.HandshakeFailed -> DRError "Handshake failed" C.OverlongHeaders -> DRError "Overlong HTTP headers" C.ResponseTimeout -> DRError "Timeout" - C.FailedConnectionException _host _port -> DRError "Connection failed" - C.FailedConnectionException2 _ _ _ exn -> DRError $ "Connection failed: " ++ show exn - C.InvalidDestinationHost _ -> DRError "Invalid destination host" - C.HttpZlibException e -> DRError $ show e - C.ExpectedBlankAfter100Continue -> DRError "Expected blank after 100 (Continue)" + 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.NoResponseDataReceived -> DRError "No response data received" - C.TlsException e -> DRError $ "TLS exception:\n" ++ show e C.InvalidHeader h -> DRError $ "Invalid HTTP header:\n" ++ B.unpack h - C.InternalIOException e -> + C.InternalException e -> case show e of "<>" -> DRError "Timeout" s -> DRError s - C.ProxyConnectException {..} -> DRError "Can't connect to proxy" - C.ResponseBodyTooShort _ _ -> DRError "Response body too short" - C.InvalidChunkHeaders -> DRError "Invalid chunk headers" + C.ProxyConnectException _ _ _ -> DRError "Can't connect to proxy" + C.NoResponseDataReceived -> DRError "No response data received" C.TlsNotSupported -> DRError "TLS not supported" + C.WrongRequestBodyStreamSize e a -> + DRError $ "The request body provided did not match the expected size " + ++ ea e a + C.ResponseBodyTooShort e a -> DRError $ "Response body too short " ++ ea e a + C.InvalidChunkHeaders -> DRError "Invalid chunk headers" C.IncompleteHeaders -> DRError "Incomplete headers" - C.InvalidProxyEnvironmentVariable n v -> DRError $ "Invalid proxy environment variable " ++ show n ++ "=" ++ show v + C.InvalidDestinationHost _ -> DRError "Invalid destination host" + C.HttpZlibException e -> DRError $ show e + C.InvalidProxyEnvironmentVariable n v -> + DRError $ "Invalid proxy environment variable " + ++ show n ++ "=" ++ show v + C.ConnectionClosed -> DRError "Connection closed" + where ea expected actual = + "(expected " ++ show expected ++ " bytes, actual is " + ++ show actual ++ " bytes)" bufSize :: Int bufSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. @@ -554,7 +556,8 @@ redownloadOpts (("If-Modified-Since: " ++ B.unpack time) : acc) xs redownloadOpts acc (_:xs) = redownloadOpts acc xs fixNonAscii = - escapeURIString (\ c -> ord c <= 0x7f && c `notElem` " []{}|\"") . + escapeURIString + (\ x -> ord x <= 0x7f && x `notElem` (" []{}|\"" :: String)) . trimString relUri (fixNonAscii -> r) = fromMaybe r $ @@ -568,8 +571,10 @@ tryParseTime :: [String] -> String -> Maybe UTCTime tryParseTime formats string = foldr mplus Nothing $ - map (\ fmt -> parseTime defaultTimeLocale fmt (trimString string)) formats + map (\ fmt -> parseTimeM True defaultTimeLocale fmt (trimString string)) + formats +trimString :: String -> String trimString = reverse . dropWhile isSpace . reverse . dropWhile isSpace parseHttpTime :: String -> Maybe UTCTime diff --git a/http-conduit-downloader.cabal b/http-conduit-downloader.cabal --- a/http-conduit-downloader.cabal +++ b/http-conduit-downloader.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.6 name: http-conduit-downloader -version: 1.0.25 +version: 1.0.30 author: Vladimir Shabanov maintainer: Vladimir Shabanov homepage: https://github.com/bazqux/http-conduit-downloader @@ -41,9 +41,9 @@ library build-depends: - base == 4.*, http-conduit >= 2.1.5, http-client >= 0.4.7, connection, zlib, lifted-base, + base == 4.*, http-conduit >= 2.2.0, http-client >= 0.5.0, connection, zlib, lifted-base, conduit, resourcet, http-types, data-default, bytestring, mtl, - time, old-locale, HsOpenSSL, network-uri >= 2.6, network >= 2.6 + time >= 1.5.0, HsOpenSSL >= 0.11.2, network-uri >= 2.6, network >= 2.6 exposed-modules: Network.HTTP.Conduit.Downloader