diff options
| -rw-r--r-- | Annex/Content.hs | 5 | ||||
| -rw-r--r-- | Command/AddUrl.hs | 12 | ||||
| -rw-r--r-- | Config.hs | 17 | ||||
| -rw-r--r-- | Remote/Git.hs | 16 | ||||
| -rw-r--r-- | Remote/Web.hs | 4 | ||||
| -rw-r--r-- | Utility/Url.hs | 16 | ||||
| -rw-r--r-- | debian/changelog | 1 |
7 files changed, 37 insertions, 34 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index bffef19f4..60edb4975 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -515,9 +515,8 @@ downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig where go Nothing = do - opts <- map Param . annexWebOptions <$> Annex.getGitConfig - headers <- getHttpHeaders - anyM (\u -> Url.withUserAgent $ Url.download u headers opts file) urls + (headers, options) <- getHttpHeadersOptions + anyM (\u -> Url.withUserAgent $ Url.download u headers options file) urls go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls downloadcmd basecmd url = boolSystem "sh" [Param "-c", Param $ gencmd url basecmd] diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 82b04f07b..da4da414f 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -134,8 +134,8 @@ perform relaxed url file = ifAnnexed file addurl geturl setUrlPresent key url next $ return True | otherwise = do - headers <- getHttpHeaders - (exists, samesize) <- Url.withUserAgent $ Url.check url headers $ keySize key + (headers, options) <- getHttpHeadersOptions + (exists, samesize) <- Url.withUserAgent $ Url.check url headers options (keySize key) if exists && samesize then do setUrlPresent key url @@ -192,8 +192,8 @@ download url file = do -} addSizeUrlKey :: URLString -> Key -> Annex Key addSizeUrlKey url key = do - headers <- getHttpHeaders - size <- snd <$> Url.withUserAgent (Url.exists url headers) + (headers, options) <- getHttpHeadersOptions + size <- snd <$> Url.withUserAgent (Url.exists url headers options) return $ key { keySize = size } cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool @@ -212,10 +212,10 @@ cleanup url file key mtmp = do nodownload :: Bool -> URLString -> FilePath -> Annex Bool nodownload relaxed url file = do - headers <- getHttpHeaders + (headers, options) <- getHttpHeadersOptions (exists, size) <- if relaxed then pure (True, Nothing) - else Url.withUserAgent $ Url.exists url headers + else Url.withUserAgent $ Url.exists url headers options if exists then do key <- Backend.URL.fromUrl url size @@ -80,10 +80,13 @@ setCrippledFileSystem b = do setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b } -{- Gets the http headers to use. -} -getHttpHeaders :: Annex [String] -getHttpHeaders = do - v <- annexHttpHeadersCommand <$> Annex.getGitConfig - case v of - Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) - Nothing -> annexHttpHeaders <$> Annex.getGitConfig +{- Gets the http headers to use, and any configured command-line options. -} +getHttpHeadersOptions :: Annex ([String], [CommandParam]) +getHttpHeadersOptions = (,) <$> headers <*> options + where + headers = do + v <- annexHttpHeadersCommand <$> Annex.getGitConfig + case v of + Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) + Nothing -> annexHttpHeaders <$> Annex.getGitConfig + options = map Param . annexWebOptions <$> Annex.getGitConfig diff --git a/Remote/Git.hs b/Remote/Git.hs index d714cfec5..f3aa2b7f1 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -158,9 +158,7 @@ tryGitConfigRead r | haveconfig r' -> return r' | otherwise -> configlist_failed Left _ -> configlist_failed - | Git.repoIsHttp r = do - headers <- getHttpHeaders - store $ geturlconfig headers + | Git.repoIsHttp r = store geturlconfig | Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteConfig r "uuid") | Git.repoIsUrl r = return r | otherwise = store $ safely $ onLocal r $ do @@ -185,11 +183,12 @@ tryGitConfigRead r return $ Right r' Left l -> return $ Left l - geturlconfig headers = do + geturlconfig = do + (headers, options) <- getHttpHeadersOptions ua <- Url.getUserAgent v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do hClose h - ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile ua) + ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers options tmpfile ua) ( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return $ Left undefined ) @@ -255,14 +254,15 @@ tryGitConfigRead r -} inAnnex :: Remote -> Key -> Annex (Either String Bool) inAnnex rmt key - | Git.repoIsHttp r = checkhttp =<< getHttpHeaders + | Git.repoIsHttp r = checkhttp | Git.repoIsUrl r = checkremote | otherwise = checklocal where r = repo rmt - checkhttp headers = do + checkhttp = do showChecking r - ifM (anyM (\u -> Url.withUserAgent $ Url.checkBoth u headers (keySize key)) (keyUrls rmt key)) + (headers, options) <- getHttpHeadersOptions + ifM (anyM (\u -> Url.withUserAgent $ Url.checkBoth u headers options (keySize key)) (keyUrls rmt key)) ( return $ Right True , return $ Left "not found" ) diff --git a/Remote/Web.hs b/Remote/Web.hs index 2863d9d5e..d41b12b6a 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -117,9 +117,9 @@ checkKey' key us = firsthit us (Right False) $ \u -> do return $ Left "quvi support needed for this url" #endif DefaultDownloader -> do - headers <- getHttpHeaders + (headers, options) <- getHttpHeadersOptions Url.withUserAgent $ catchMsgIO . - Url.checkBoth u' headers (keySize key) + Url.checkBoth u' headers options (keySize key) where firsthit [] miss _ = return miss firsthit (u:rest) _ a = do diff --git a/Utility/Url.hs b/Utility/Url.hs index 2cbab77c8..49f25c371 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -34,12 +34,12 @@ type UserAgent = String {- Checks that an url exists and could be successfully downloaded, - also checking that its size, if available, matches a specified size. -} -checkBoth :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO Bool -checkBoth url headers expected_size ua = do - v <- check url headers expected_size ua +checkBoth :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO Bool +checkBoth url headers options expected_size ua = do + v <- check url headers options expected_size ua return (fst v && snd v) -check :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool) -check url headers expected_size = handle <$$> exists url headers +check :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool) +check url headers options expected_size = handle <$$> exists url headers options where handle (False, _) = (False, False) handle (True, Nothing) = (True, True) @@ -55,8 +55,8 @@ check url headers expected_size = handle <$$> exists url headers - Uses curl otherwise, when available, since curl handles https better - than does Haskell's Network.Browser. -} -exists :: URLString -> Headers -> Maybe UserAgent -> IO (Bool, Maybe Integer) -exists url headers ua = case parseURIRelaxed url of +exists :: URLString -> Headers -> [CommandParam] -> Maybe UserAgent -> IO (Bool, Maybe Integer) +exists url headers options ua = case parseURIRelaxed url of Just u | uriScheme u == "file:" -> do s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u) @@ -83,7 +83,7 @@ exists url headers ua = case parseURIRelaxed url of , Param "--head" , Param "-L", Param url , Param "-w", Param "%{http_code}" - ] ++ concatMap (\h -> [Param "-H", Param h]) headers + ] ++ concatMap (\h -> [Param "-H", Param h]) headers ++ options extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of Just l -> case lastMaybe $ words l of diff --git a/debian/changelog b/debian/changelog index 7d0a186fd..1e260a424 100644 --- a/debian/changelog +++ b/debian/changelog @@ -22,6 +22,7 @@ git-annex (5.20140222) UNRELEASED; urgency=medium does not work on Box.com. * repair: Optimise unpacking of pack files, and avoid repeated error messages about corrupt pack files. + * Make annex.web-options be used in several places that call curl. -- Joey Hess <joeyh@debian.org> Fri, 21 Feb 2014 13:03:04 -0400 |