Fall back to internal url downloader when built without curl.

This commit is contained in:
Joey Hess 2013-04-16 15:20:21 -04:00
parent a85c9ba561
commit 6490418a4e
4 changed files with 98 additions and 11 deletions

View file

@ -1,6 +1,6 @@
{- Url downloading.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
- Copyright 2011,2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -17,6 +17,11 @@ module Utility.Url (
import Common
import Network.URI
import qualified Network.Browser as Browser
import Network.HTTP
import Data.Either
import qualified Build.SysConfig
type URLString = String
@ -32,7 +37,13 @@ check url headers expected_size = handle <$> exists url headers
handle (True, s) = expected_size == s
{- Checks that an url exists and could be successfully downloaded,
- also returning its size if available. -}
- 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.
-}
exists :: URLString -> Headers -> IO (Bool, Maybe Integer)
exists url headers = case parseURIRelaxed url of
Just u
@ -41,11 +52,17 @@ exists url headers = case parseURIRelaxed url of
case s of
Just stat -> return (True, Just $ fromIntegral $ fileSize stat)
Nothing -> dne
| otherwise -> do
output <- readProcess "curl" curlparams
case lastMaybe (lines output) of
Just ('2':_:_) -> return (True, extractsize output)
_ -> dne
| otherwise -> if Build.SysConfig.curl
then do
output <- readProcess "curl" curlparams
case lastMaybe (lines output) of
Just ('2':_:_) -> return (True, extractsize output)
_ -> dne
else do
r <- request u headers HEAD
case rspCode r of
(2,_,_) -> return (True, size r)
_ -> return (False, Nothing)
Nothing -> dne
where
dne = return (False, Nothing)
@ -64,6 +81,8 @@ exists url headers = case parseURIRelaxed url of
_ -> Nothing
_ -> Nothing
size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
{- 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,
@ -94,10 +113,63 @@ download url headers options file =
go cmd opts = boolSystem cmd $
options++opts++[File file, File url]
{- Downloads a small file. -}
{- Downloads a small file.
-
- Uses curl if available since it handles HTTPS better than
- the Haskell libraries do. -}
get :: URLString -> Headers -> IO String
get url headers = readProcess "curl" $
["-s", "-L", url] ++ concatMap (\h -> ["-H", h]) headers
get url headers = if Build.SysConfig.curl
then readProcess "curl" $
["-s", "-L", url] ++ concatMap (\h -> ["-H", h]) headers
else case parseURI url of
Nothing -> error "url parse error"
Just u -> do
r <- request u headers GET
case rspCode r of
(2,_,_) -> return $ rspBody r
_ -> error $ rspReason r
{- 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.
-}
request :: URI -> Headers -> RequestMethod -> IO (Response String)
request url headers requesttype = go 5 url
where
go :: Int -> URI -> IO (Response String)
go 0 _ = error "Too many redirects "
go n u = do
rsp <- Browser.browse $ do
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 headers
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