Avoid running annex.http-headers-command more than once.

Annex.hs

@@ -144,6 +144,7 @@ data AnnexState = AnnexState
 	, keysdbhandle :: Maybe Keys.DbHandle
 	, cachedcurrentbranch :: Maybe Git.Branch
 	, cachedgitenv :: Maybe [(String, String)]
+	, urloptions :: Maybe UrlOptions
 	}
 
 newState :: GitConfig -> Git.Repo -> IO AnnexState
@@ -200,6 +201,7 @@ newState c r = do
 		, keysdbhandle = Nothing
 		, cachedcurrentbranch = Nothing
 		, cachedgitenv = Nothing
+		, urloptions = Nothing
 		}
 
 {- Makes an Annex state object for the specified git repo.

Annex/Url.hs

@@ -1,7 +1,7 @@
 {- Url downloading, with git-annex user agent and configured http
  - headers and wget/curl options.
  -
- - Copyright 2013-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,7 +9,6 @@
 module Annex.Url (
 	module U,
 	withUrlOptions,
-	getUrlOptions,
 	getUserAgent,
 ) where
 
@@ -25,16 +24,20 @@ getUserAgent :: Annex (Maybe U.UserAgent)
 getUserAgent = Annex.getState $ 
 	Just . fromMaybe defaultUserAgent . Annex.useragent
 
-getUrlOptions :: Annex U.UrlOptions
-getUrlOptions = mkUrlOptions
+withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a
+withUrlOptions a = Annex.getState Annex.urloptions >>= \case
+	Just uo -> a uo
+	Nothing -> do
+		uo <- mk
+		Annex.changeState $ \s -> s
+			{ Annex.urloptions = Just uo }
+		a uo
+  where
+	mk = mkUrlOptions
 		<$> getUserAgent
 		<*> headers
 		<*> options
-  where
 	headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case
 		Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
 		Nothing -> annexHttpHeaders <$> Annex.getGitConfig
 	options = map Param . annexWebOptions <$> Annex.getGitConfig
-
-withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a
-withUrlOptions a = liftIO . a =<< getUrlOptions

Annex/YoutubeDl.hs

@@ -124,8 +124,7 @@ youtubeDlTo key url dest = do
 -- without it. So, this first downloads part of the content and checks 
 -- if it's a html page; only then is youtube-dl used.
 htmlOnly :: URLString -> a -> Annex a -> Annex a
-htmlOnly url fallback a = do
-	uo <- getUrlOptions
+htmlOnly url fallback a = withUrlOptions $ \uo -> 
 	liftIO (downloadPartial url uo htmlPrefixLength) >>= \case
 		Just bs | isHtmlBs bs -> a
 		_ -> return fallback

Assistant/Upgrade.hs

@@ -316,8 +316,7 @@ usingDistribution :: IO Bool
 usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
 
 downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
-downloadDistributionInfo = do
-	uo <- liftAnnex Url.getUrlOptions
+downloadDistributionInfo = Url.withUrlOptions $ \uo -> do
 	gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
 	liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
 		let infof = tmpdir </> "info"

Assistant/WebApp/Configurators/IA.hs

@@ -189,8 +189,7 @@ escapeHeader :: String -> String
 escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
 
 getRepoInfo :: RemoteConfig -> Widget
-getRepoInfo c = do
-	uo <- liftAnnex Url.getUrlOptions
+getRepoInfo c = Url.withUrlOptions $ \uo ->
 	exists <- liftIO $ catchDefaultIO False $ Url.exists url uo
 	[whamlet|
 <a href="#{url}">

CHANGELOG

@@ -11,6 +11,7 @@ git-annex (6.20180317) UNRELEASED; urgency=medium
   * When adding a new version of a file, and annex.genmetadata is enabled,
     don't copy the data metadata from the old version of the file,
     instead use the mtime of the file.
+  * Avoid running annex.http-headers-command more than once.
 
  -- Joey Hess <id@joeyh.name>  Mon, 19 Mar 2018 23:13:59 -0400
 

Command/ImportFeed.hs

@@ -150,7 +150,7 @@ downloadFeed url
 	| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
 	| otherwise = do
 		showOutput
-		uo <- Url.getUrlOptions
+		Url.withUrlOptions $ \ou ->
 			liftIO $ withTmpFile "feed" $ \f h -> do
 				hClose h
 				ifM (Url.download url f uo)

Remote/BitTorrent.hs

@@ -207,7 +207,8 @@ downloadTorrentFile u = do
 					misctmp <- fromRepo gitAnnexTmpMiscDir
 					withTmpFileIn misctmp "torrent" $ \f h -> do
 						liftIO $ hClose h
-						ok <- Url.withUrlOptions $ Url.download u f
+						ok <- Url.withUrlOptions $ 
+							liftIO . Url.download u f
 						when ok $
 							liftIO $ renameFile f torrent
 						return ok

Remote/External.hs

@@ -683,7 +683,7 @@ checkKeyUrl :: Git.Repo -> CheckPresent
 checkKeyUrl r k = do
 	showChecking r
 	us <- getWebUrls k
-	anyM (\u -> withUrlOptions $ checkBoth u (keySize k)) us
+	anyM (\u -> withUrlOptions $ liftIO . checkBoth u (keySize k)) us
 
 getWebUrls :: Key -> Annex [URLString]
 getWebUrls key = filter supported <$> getUrls key

Remote/Git.hs

@@ -248,8 +248,7 @@ tryGitConfigRead autoinit r
 				return $ Right r'
 			Left l -> return $ Left l
 
-	geturlconfig = do
-		uo <- Url.getUrlOptions
+	geturlconfig = Url.withUrlOptions $ \uo -> do
 		v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
 			hClose h
 			let url = Git.repoLocation r ++ "/config"

Remote/Web.hs

@@ -108,7 +108,7 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
 	case downloader of
 		YoutubeDownloader -> youtubeDlCheck u'
 		_ -> do
-			Url.withUrlOptions $ catchMsgIO .
+			Url.withUrlOptions $ liftIO . catchMsgIO .
 				Url.checkBoth u' (keySize key)
   where
 	firsthit [] miss _ = return miss