Switched from the old haskell HTTP library to http-conduit.
The hoary old HTTP library was only used when checking if an url exists, when curl was not available. It had many problems, including not supporting https at all. Now, this is done using http-conduit for all urls that it supports. Falls back to curl for any url that http-conduit doesn't like (probably ftp etc, but could also be an url that its parser chokes on for whatever reason). This adds a new dependency on http-conduit, but webdav support already indirectly depended on that, and the s3-aws branch also uses it.
This commit is contained in:
Joey Hess
parent
f93a631f51
commit
edac4afc53
4 changed files with 57 additions and 80 deletions
125
Utility/Url.hs
125
Utility/Url.hs
|
|
@ -1,6 +1,6 @@
|
|||
{- Url downloading.
|
||||
-
|
||||
- Copyright 2011,2013 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
@ -21,10 +21,11 @@ module Utility.Url (
|
|||
|
||||
import Common
|
||||
import Network.URI
|
||||
import qualified Network.Browser as Browser
|
||||
import Network.HTTP
|
||||
import Data.Either
|
||||
import Network.HTTP.Conduit
|
||||
import Network.HTTP.Types
|
||||
import Data.Default
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.ByteString.UTF8 as B8
|
||||
|
||||
import qualified Build.SysConfig
|
||||
|
||||
|
|
@ -60,33 +61,26 @@ check url expected_size = go <$$> exists url
|
|||
Nothing -> (True, True)
|
||||
|
||||
{- Checks that an url exists and could be successfully downloaded,
|
||||
- also returning its size if available.
|
||||
-
|
||||
- For a file: url, check it directly.
|
||||
-
|
||||
- Uses curl otherwise, when available, since curl handles https better
|
||||
- than does Haskell's Network.Browser.
|
||||
-}
|
||||
- also returning its size if available. -}
|
||||
exists :: URLString -> UrlOptions -> IO (Bool, Maybe Integer)
|
||||
exists url uo = case parseURIRelaxed url of
|
||||
Just u
|
||||
| uriScheme u == "file:" -> do
|
||||
s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u)
|
||||
case s of
|
||||
Just stat -> return (True, Just $ fromIntegral $ fileSize stat)
|
||||
Nothing -> dne
|
||||
| otherwise -> if Build.SysConfig.curl
|
||||
then do
|
||||
Just u -> case parseUrl (show u) of
|
||||
Just req -> existsconduit req `catchNonAsync` const dne
|
||||
-- http-conduit does not support file:, ftp:, etc urls,
|
||||
-- so fall back to reading files and using curl.
|
||||
Nothing
|
||||
| uriScheme u == "file:" -> do
|
||||
s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u)
|
||||
case s of
|
||||
Just stat -> return (True, Just $ fromIntegral $ fileSize stat)
|
||||
Nothing -> dne
|
||||
| Build.SysConfig.curl -> do
|
||||
output <- catchDefaultIO "" $
|
||||
readProcess "curl" $ toCommand curlparams
|
||||
case lastMaybe (lines output) of
|
||||
Just ('2':_:_) -> return (True, extractsize output)
|
||||
Just ('2':_:_) -> return (True, extractlencurl output)
|
||||
_ -> dne
|
||||
else do
|
||||
r <- request u HEAD uo
|
||||
case rspCode r of
|
||||
(2,_,_) -> return (True, size r)
|
||||
_ -> return (False, Nothing)
|
||||
| otherwise -> dne
|
||||
Nothing -> dne
|
||||
where
|
||||
dne = return (False, Nothing)
|
||||
|
|
@ -98,13 +92,28 @@ exists url uo = case parseURIRelaxed url of
|
|||
, Param "-w", Param "%{http_code}"
|
||||
] ++ concatMap (\h -> [Param "-H", Param h]) (reqHeaders uo) ++ (reqParams uo)
|
||||
|
||||
extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of
|
||||
extractlencurl s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of
|
||||
Just l -> case lastMaybe $ words l of
|
||||
Just sz -> readish sz
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
|
||||
|
||||
extractlen resp = readish . B8.toString =<< headMaybe lenheaders
|
||||
where
|
||||
lenheaders = map snd $
|
||||
filter (\(h, _) -> h == hContentLength)
|
||||
(responseHeaders resp)
|
||||
|
||||
existsconduit req = withManager $ \mgr -> do
|
||||
let req' = (addUrlOptions uo req) { method = methodHead }
|
||||
resp <- http req' mgr
|
||||
-- forces processing the response before the
|
||||
-- manager is closed
|
||||
ret <- if responseStatus resp == ok200
|
||||
then return (True, extractlen resp)
|
||||
else liftIO dne
|
||||
liftIO $ closeManager mgr
|
||||
return ret
|
||||
|
||||
-- works for both wget and curl commands
|
||||
addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam]
|
||||
|
|
@ -112,6 +121,20 @@ addUserAgent uo ps = case userAgent uo of
|
|||
Nothing -> ps
|
||||
Just ua -> ps ++ [Param "--user-agent", Param ua]
|
||||
|
||||
addUrlOptions :: UrlOptions -> Request -> Request
|
||||
addUrlOptions uo r = r { requestHeaders = requestHeaders r ++ uaheader ++ otherheaders}
|
||||
where
|
||||
uaheader = case userAgent uo of
|
||||
Nothing -> []
|
||||
Just ua -> [(hUserAgent, B8.fromString ua)]
|
||||
otherheaders = map toheader (reqHeaders uo)
|
||||
toheader s =
|
||||
let (h, v) = separate (== ':') s
|
||||
h' = CI.mk (B8.fromString h)
|
||||
in case v of
|
||||
(' ':v') -> (h', B8.fromString v')
|
||||
_ -> (h', B8.fromString v)
|
||||
|
||||
{- Used to download large files, such as the contents of keys.
|
||||
-
|
||||
- Uses wget or curl program for its progress bar. (Wget has a better one,
|
||||
|
|
@ -161,52 +184,6 @@ download' quiet url file uo =
|
|||
| quiet = [Param s]
|
||||
| otherwise = []
|
||||
|
||||
{- Uses Network.Browser to make a http request of an url.
|
||||
- For example, HEAD can be used to check if the url exists,
|
||||
- or GET used to get the url content (best for small urls).
|
||||
-
|
||||
- This does its own redirect following because Browser's is buggy for HEAD
|
||||
- requests.
|
||||
-
|
||||
- Unfortunately, does not handle https, so should only be used
|
||||
- when curl is not available.
|
||||
-}
|
||||
request :: URI -> RequestMethod -> UrlOptions -> IO (Response String)
|
||||
request url requesttype uo = go 5 url
|
||||
where
|
||||
go :: Int -> URI -> IO (Response String)
|
||||
go 0 _ = error "Too many redirects "
|
||||
go n u = do
|
||||
rsp <- Browser.browse $ do
|
||||
maybe noop Browser.setUserAgent (userAgent uo)
|
||||
Browser.setErrHandler ignore
|
||||
Browser.setOutHandler ignore
|
||||
Browser.setAllowRedirects False
|
||||
let req = mkRequest requesttype u :: Request_String
|
||||
snd <$> Browser.request (addheaders req)
|
||||
case rspCode rsp of
|
||||
(3,0,x) | x /= 5 -> redir (n - 1) u rsp
|
||||
_ -> return rsp
|
||||
addheaders req = setHeaders req (rqHeaders req ++ userheaders)
|
||||
userheaders = rights $ map parseHeader (reqHeaders uo)
|
||||
ignore = const noop
|
||||
redir n u rsp = case retrieveHeaders HdrLocation rsp of
|
||||
[] -> return rsp
|
||||
(Header _ newu:_) ->
|
||||
case parseURIReference newu of
|
||||
Nothing -> return rsp
|
||||
Just newURI -> go n $
|
||||
#if defined VERSION_network
|
||||
#if ! MIN_VERSION_network(2,4,0)
|
||||
#define WITH_OLD_URI
|
||||
#endif
|
||||
#endif
|
||||
#ifdef WITH_OLD_URI
|
||||
fromMaybe newURI (newURI `relativeTo` u)
|
||||
#else
|
||||
newURI `relativeTo` u
|
||||
#endif
|
||||
|
||||
{- Allows for spaces and other stuff in urls, properly escaping them. -}
|
||||
parseURIRelaxed :: URLString -> Maybe URI
|
||||
parseURIRelaxed = parseURI . escapeURIString isAllowedInURI
|
||||
|
|
|
|||
1
debian/changelog
vendored
1
debian/changelog
vendored
|
|
@ -39,6 +39,7 @@ git-annex (5.20140718) UNRELEASED; urgency=medium
|
|||
* git-annex-shell sendkey: Don't fail if a remote asks for a key to be sent
|
||||
that already has a transfer lock file indicating it's being sent to that
|
||||
remote. The remote may have moved between networks, or reconnected.
|
||||
* Switched from the old haskell HTTP library to http-conduit.
|
||||
|
||||
-- Joey Hess <joeyh@debian.org> Mon, 21 Jul 2014 14:41:26 -0400
|
||||
|
||||
|
|
|
|||
2
debian/control
vendored
2
debian/control
vendored
|
|
@ -46,6 +46,7 @@ Build-Depends:
|
|||
libghc-dns-dev,
|
||||
libghc-case-insensitive-dev,
|
||||
libghc-http-types-dev,
|
||||
libghc-http-conduit-dev,
|
||||
libghc-blaze-builder-dev,
|
||||
libghc-crypto-api-dev,
|
||||
libghc-network-multicast-dev,
|
||||
|
|
@ -55,7 +56,6 @@ Build-Depends:
|
|||
libghc-gnutls-dev (>= 0.1.4),
|
||||
libghc-xml-types-dev,
|
||||
libghc-async-dev,
|
||||
libghc-http-dev,
|
||||
libghc-feed-dev (>= 0.3.9.2),
|
||||
libghc-regex-tdfa-dev [!mipsel !s390],
|
||||
libghc-regex-compat-dev [mipsel s390],
|
||||
|
|
|
|||
|
|
@ -96,11 +96,11 @@ Executable git-annex
|
|||
Main-Is: git-annex.hs
|
||||
Build-Depends: MissingH, hslogger, directory, filepath,
|
||||
containers, utf8-string, network (>= 2.0), mtl (>= 2),
|
||||
bytestring, old-locale, time, HTTP, dataenc, SHA, process, json,
|
||||
bytestring, old-locale, time, dataenc, SHA, process, json,
|
||||
base (>= 4.5 && < 4.9), monad-control, exceptions (>= 0.5), transformers,
|
||||
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,
|
||||
SafeSemaphore, uuid, random, dlist, unix-compat, async, stm (>= 2.3),
|
||||
data-default, case-insensitive
|
||||
data-default, case-insensitive, http-conduit, http-types
|
||||
CC-Options: -Wall
|
||||
GHC-Options: -Wall
|
||||
Extensions: PackageImports
|
||||
|
|
@ -141,8 +141,7 @@ Executable git-annex
|
|||
CPP-Options: -DWITH_S3
|
||||
|
||||
if flag(WebDAV)
|
||||
Build-Depends: DAV (>= 1.0),
|
||||
http-client, http-types
|
||||
Build-Depends: DAV (>= 1.0), http-client
|
||||
CPP-Options: -DWITH_WEBDAV
|
||||
|
||||
if flag(Assistant) && ! os(solaris)
|
||||
|
|
@ -188,7 +187,7 @@ Executable git-annex
|
|||
if flag(Webapp)
|
||||
Build-Depends:
|
||||
yesod, yesod-default, yesod-static, yesod-form, yesod-core,
|
||||
http-types, wai, wai-extra, warp, warp-tls,
|
||||
wai, wai-extra, warp, warp-tls,
|
||||
blaze-builder, crypto-api, hamlet, clientsession,
|
||||
template-haskell, data-default, aeson, path-pieces,
|
||||
shakespeare
|
||||
|
|
|
|||
Loading…
Reference in a new issue