summaryrefslogtreecommitdiff
path: root/Remote/GitLFS.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Remote/GitLFS.hs')
-rw-r--r--Remote/GitLFS.hs99
1 files changed, 72 insertions, 27 deletions
diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 4765d2f..3c43ab1 100644
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@@ -17,6 +17,7 @@ import qualified Git
import qualified Git.Types as Git
import qualified Git.Url
import qualified Git.GCrypt
+import qualified Git.Credential as Git
import Config
import Config.Cost
import Remote.Helper.Special
@@ -42,6 +43,7 @@ import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
+import qualified Control.Concurrent.MSemN as MSemN
remote :: RemoteType
remote = RemoteType
@@ -64,7 +66,8 @@ gen r u c gc = do
g <- Annex.gitRepo
liftIO $ Git.GCrypt.encryptedRemote g r
else pure r
- h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r' gc
+ sem <- liftIO $ MSemN.new 1
+ h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc
cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store u h)
@@ -159,31 +162,34 @@ mySetup _ mu _ c gc = do
data LFSHandle = LFSHandle
{ downloadEndpoint :: Maybe LFS.Endpoint
, uploadEndpoint :: Maybe LFS.Endpoint
+ , getEndPointLock :: MSemN.MSemN Int
, remoteRepo :: Git.Repo
, remoteGitConfig :: RemoteGitConfig
}
+-- Only let one thread at a time do endpoint discovery.
+withEndPointLock :: LFSHandle -> Annex a -> Annex a
+withEndPointLock h = bracket_
+ (liftIO $ MSemN.wait l 1)
+ (liftIO $ MSemN.signal l 1)
+ where
+ l = getEndPointLock h
+
discoverLFSEndpoint :: LFS.TransferRequestOperation -> LFSHandle -> Annex (Maybe LFS.Endpoint)
discoverLFSEndpoint tro h
| Git.repoIsSsh r = gossh
| Git.repoIsHttp r = gohttp
- | otherwise = do
- warning "git-lfs endpoint has unsupported URI scheme"
- return Nothing
+ | otherwise = unsupportedurischeme
where
r = remoteRepo h
lfsrepouri = case Git.location r of
Git.Url u -> u
_ -> giveup $ "unsupported git-lfs remote location " ++ Git.repoLocation r
- gohttp = case tro of
- LFS.RequestDownload -> return $ LFS.guessEndpoint lfsrepouri
- LFS.RequestUpload -> do
- -- git-lfs does support storing over http,
- -- but it would need prompting for http basic
- -- authentication each time git-annex discovered
- -- the endpoint.
- warning "Storing content in git-lfs currently needs a ssh repository url, not http."
- return Nothing
+
+ unsupportedurischeme = do
+ warning "git-lfs endpoint has unsupported URI scheme"
+ return Nothing
+
gossh = case mkSshHost <$> Git.Url.hostuser r of
Nothing -> do
warning "Unable to parse ssh url for git-lfs remote."
@@ -216,6 +222,48 @@ discoverLFSEndpoint tro h
warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery"
return Nothing
Just endpoint -> return (Just endpoint)
+
+ -- The endpoint may or may not need http basic authentication,
+ -- which involves using git-credential to prompt for the password.
+ --
+ -- To determine if it does, make a download or upload request to
+ -- it, not including any objects in the request, and see if
+ -- the server requests authentication.
+ gohttp = case LFS.guessEndpoint lfsrepouri of
+ Nothing -> unsupportedurischeme
+ Just endpoint -> do
+ let testreq = LFS.startTransferRequest endpoint transfernothing
+ flip catchNonAsync (const (returnendpoint endpoint)) $ do
+ resp <- makeSmallAPIRequest testreq
+ if needauth (responseStatus resp)
+ then do
+ cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri)
+ let endpoint' = addbasicauth cred endpoint
+ let testreq' = LFS.startTransferRequest endpoint' transfernothing
+ flip catchNonAsync (const (returnendpoint endpoint')) $ do
+ resp' <- makeSmallAPIRequest testreq'
+ inRepo $ if needauth (responseStatus resp')
+ then Git.rejectUrlCredential cred
+ else Git.approveUrlCredential cred
+ returnendpoint endpoint'
+ else returnendpoint endpoint
+ where
+ transfernothing = LFS.TransferRequest
+ { LFS.req_operation = tro
+ , LFS.req_transfers = [LFS.Basic]
+ , LFS.req_ref = Nothing
+ , LFS.req_objects = []
+ }
+ returnendpoint = return . Just
+
+ needauth status = status == unauthorized401
+
+ addbasicauth cred endpoint =
+ case (Git.credentialUsername cred, Git.credentialPassword cred) of
+ (Just u, Just p) ->
+ LFS.modifyEndpointRequest endpoint $
+ applyBasicAuth (encodeBS u) (encodeBS p)
+ _ -> endpoint
-- The endpoint is cached for later use.
getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
@@ -223,7 +271,7 @@ getLFSEndpoint tro hv = do
h <- liftIO $ atomically $ readTVar hv
case f h of
Just endpoint -> return (Just endpoint)
- Nothing -> discoverLFSEndpoint tro h >>= \case
+ Nothing -> withEndPointLock h $ discoverLFSEndpoint tro h >>= \case
Just endpoint -> do
liftIO $ atomically $ writeTVar hv $
case tro of
@@ -256,16 +304,14 @@ sendTransferRequest
=> LFS.TransferRequest
-> LFS.Endpoint
-> Annex (Either String (LFS.TransferResponse op))
-sendTransferRequest req endpoint =
- case LFS.startTransferRequest endpoint req of
- Just httpreq -> do
- httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
- return $ case LFS.parseTransferResponse (responseBody httpresp) of
- LFS.ParsedTransferResponse resp -> Right resp
- LFS.ParsedTransferResponseError tro -> Left $
- T.unpack $ LFS.resperr_message tro
- LFS.ParseFailed err -> Left err
- Nothing -> return $ Left "unable to parse git-lfs endpoint url"
+sendTransferRequest req endpoint = do
+ let httpreq = LFS.startTransferRequest endpoint req
+ httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
+ return $ case LFS.parseTransferResponse (responseBody httpresp) of
+ LFS.ParsedTransferResponse resp -> Right resp
+ LFS.ParsedTransferResponseError tro -> Left $
+ T.unpack $ LFS.resperr_message tro
+ LFS.ParseFailed err -> Left err
extractKeySha256 :: Key -> Maybe LFS.SHA256
extractKeySha256 k = case keyVariety k of
@@ -409,9 +455,8 @@ checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case
-- Unable to find enough information to request the key
-- from git-lfs, so it's not present there.
Nothing -> return False
- Just (req, sha256, size) -> case LFS.startTransferRequest endpoint req of
- Nothing -> giveup "unable to parse git-lfs endpoint url"
- Just httpreq -> go sha256 size =<< makeSmallAPIRequest httpreq
+ Just (req, sha256, size) -> go sha256 size
+ =<< makeSmallAPIRequest (LFS.startTransferRequest endpoint req)
where
go sha256 size httpresp
| responseStatus httpresp == status200 = go' sha256 size $