Add annex.httpheaders and annex.httpheader-command config settings

Allow custom headers to be sent with all HTTP requests.

(Requested by the Internet Archive)
This commit is contained in:
Joey Hess 2012-04-22 01:13:09 -04:00
parent 5fbe83f595
commit 84ac8c58db
9 changed files with 66 additions and 27 deletions

View file

@ -94,7 +94,9 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r
| not $ M.null $ Git.config r = return r -- already read
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
| Git.repoIsHttp r = store $ safely geturlconfig
| Git.repoIsHttp r = do
headers <- getHttpHeaders
store $ safely $ geturlconfig headers
| Git.repoIsUrl r = return r
| otherwise = store $ safely $ onLocal r $ do
ensureInitialized
@ -109,8 +111,8 @@ tryGitConfigRead r
pOpen ReadFromPipe cmd (toCommand params) $
Git.Config.hRead r
geturlconfig = do
s <- Url.get (Git.repoLocation r ++ "/config")
geturlconfig headers = do
s <- Url.get (Git.repoLocation r ++ "/config") headers
withTempFile "git-annex.tmp" $ \tmpfile h -> do
hPutStr h s
hClose h
@ -136,16 +138,16 @@ tryGitConfigRead r
-}
inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
inAnnex r key
| Git.repoIsHttp r = checkhttp
| Git.repoIsHttp r = checkhttp =<< getHttpHeaders
| Git.repoIsUrl r = checkremote
| otherwise = checklocal
where
checkhttp = liftIO $ go undefined $ keyUrls r key
checkhttp headers = liftIO $ go undefined $ keyUrls r key
where
go e [] = return $ Left e
go _ (u:us) = do
res <- catchMsgIO $
Url.check u (keySize key)
Url.check u headers (keySize key)
case res of
Left e -> go e us
v -> return v

View file

@ -83,4 +83,5 @@ checkKey key = do
checkKey' :: Key -> [URLString] -> Annex Bool
checkKey' key us = untilTrue us $ \u -> do
showAction $ "checking " ++ u
liftIO $ Url.check u (keySize key)
headers <- getHttpHeaders
liftIO $ Url.check u headers (keySize key)