diff options
Diffstat (limited to 'Utility/Url.hs')
| -rw-r--r-- | Utility/Url.hs | 84 |
1 files changed, 42 insertions, 42 deletions
diff --git a/Utility/Url.hs b/Utility/Url.hs index e47cb9dee..67efdb558 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -29,10 +29,10 @@ type Headers = [String] - also checking that its size, if available, matches a specified size. -} check :: URLString -> Headers -> Maybe Integer -> IO Bool check url headers expected_size = handle <$> exists url headers - where - handle (False, _) = False - handle (True, Nothing) = True - handle (True, s) = expected_size == s + where + handle (False, _) = False + handle (True, Nothing) = True + handle (True, s) = expected_size == s {- Checks that an url exists and could be successfully downloaded, - also returning its size if available. -} @@ -50,8 +50,8 @@ exists url headers = case parseURI url of case rspCode r of (2,_,_) -> return (True, size r) _ -> return (False, Nothing) - where - size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders + where + size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders {- Used to download large files, such as the contents of keys. - @@ -66,17 +66,17 @@ download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool download url headers options file | "file://" `isPrefixOf` url = curl | otherwise = ifM (inPath "wget") (wget , curl) - where - headerparams = map (\h -> Param $ "--header=" ++ h) headers - wget = go "wget" $ headerparams ++ [Params "-c -O"] - {- Uses the -# progress display, because the normal - - one is very confusing when resuming, showing - - the remainder to download as the whole file, - - and not indicating how much percent was - - downloaded before the resume. -} - curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"] - go cmd opts = boolSystem cmd $ - options++opts++[File file, File url] + where + headerparams = map (\h -> Param $ "--header=" ++ h) headers + wget = go "wget" $ headerparams ++ [Params "-c -O"] + {- Uses the -# progress display, because the normal + - one is very confusing when resuming, showing + - the remainder to download as the whole file, + - and not indicating how much percent was + - downloaded before the resume. -} + curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"] + go cmd opts = boolSystem cmd $ + options++opts++[File file, File url] {- Downloads a small file. -} get :: URLString -> Headers -> IO String @@ -98,36 +98,36 @@ get url headers = -} 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 - 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 newURI_abs - where + 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 + 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 newURI_abs + where #if defined VERSION_network #if ! MIN_VERSION_network(2,4,0) #define WITH_OLD_URI #endif #endif #ifdef WITH_OLD_URI - newURI_abs = fromMaybe newURI (newURI `relativeTo` u) + newURI_abs = fromMaybe newURI (newURI `relativeTo` u) #else - newURI_abs = newURI `relativeTo` u + newURI_abs = newURI `relativeTo` u #endif - addheaders req = setHeaders req (rqHeaders req ++ userheaders) - userheaders = rights $ map parseHeader headers + addheaders req = setHeaders req (rqHeaders req ++ userheaders) + userheaders = rights $ map parseHeader headers |