Make annex.web-options be used in several places that call curl.

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, options) <- getHttpHeadersOptions
-		headers <- getHttpHeaders
+		anyM (\u -> Url.withUserAgent $ Url.download u headers options file) urls
-		anyM (\u -> Url.withUserAgent $ Url.download u headers opts file) urls
 	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
 	downloadcmd basecmd url =
 		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]

Assistant/Restart.hs

@@ -81,7 +81,7 @@ newAssistantUrl repo = do
 				( return url
 				, delayed $ waiturl urlfile
 				)
-	listening url = catchBoolIO $ fst <$> exists url [] Nothing
+	listening url = catchBoolIO $ fst <$> exists url [] [] Nothing
 	delayed a = do
 		threadDelay 100000 -- 1/10th of a second
 		a

Assistant/WebApp/Configurators/IA.hs

@@ -191,7 +191,7 @@ escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
 getRepoInfo :: RemoteConfig -> Widget
 getRepoInfo c = do
 	ua <- liftAnnex Url.getUserAgent
-	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url [] ua
+	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url [] [] ua
 	[whamlet|
 <a href="#{url}">
   Internet Archive item

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
+			(headers, options) <- getHttpHeadersOptions
-			(exists, samesize) <- Url.withUserAgent $ Url.check url headers $ keySize key
+			(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
+	(headers, options) <- getHttpHeadersOptions
-	size <- snd <$> Url.withUserAgent (Url.exists url headers)
+	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

Config.hs

@@ -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. -}
+{- Gets the http headers to use, and any configured command-line options. -}
-getHttpHeaders :: Annex [String]
+getHttpHeadersOptions :: Annex ([String], [CommandParam])
-getHttpHeaders = do
+getHttpHeadersOptions = (,) <$> headers <*> options
-	v <- annexHttpHeadersCommand <$> Annex.getGitConfig
+  where
-	case v of
+	headers = do
-		Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
+		v <- annexHttpHeadersCommand <$> Annex.getGitConfig
-		Nothing -> annexHttpHeaders <$> Annex.getGitConfig
+		case v of
+			Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
+			Nothing -> annexHttpHeaders <$> Annex.getGitConfig
+	options = map Param . annexWebOptions <$> Annex.getGitConfig

Remote/Git.hs

@@ -158,9 +158,7 @@ tryGitConfigRead r
 				| haveconfig r' -> return r'
 				| otherwise -> configlist_failed
 			Left _ -> configlist_failed
-	| Git.repoIsHttp r = do
+	| Git.repoIsHttp r = store geturlconfig
-		headers <- getHttpHeaders
-		store $ geturlconfig headers
 	| 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"
 			)

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

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 :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO Bool
-checkBoth url headers expected_size ua = do
+checkBoth url headers options expected_size ua = do
-	v <- check url headers expected_size ua
+	v <- check url headers options expected_size ua
 	return (fst v && snd v)
-check :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool)
+check :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool)
-check url headers expected_size = handle <$$> exists url headers
+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 :: URLString -> Headers -> [CommandParam] -> Maybe UserAgent -> IO (Bool, Maybe Integer)
-exists url headers ua = case parseURIRelaxed url of
+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

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