mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

start at retieval from LFS

Browse source 
Doesn't yet download the content, which will need to support resuming.
This commit is contained in:
Joey Hess 2019-08-03 12:51:16 -04:00
parent 5be0a35dae
commit 28c0395d61
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 35 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

55
Remote/GitLFS.hs
View file

@ -21,23 +21,20 @@ import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Remote.Helper.Git import Remote.Helper.Git
import Remote.Helper.Http import Remote.Helper.Http
import qualified Remote.Helper.Ssh as Ssh
import Annex.Ssh import Annex.Ssh
import Annex.UUID import Annex.UUID
import Utility.SshHost import Utility.SshHost
import qualified Utility.GitLFS as LFS import qualified Utility.GitLFS as LFS
import Backend.Hash import Backend.Hash
import Utility.Hash import Utility.Hash
import Utility.FileSize
import Crypto import Crypto
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.String import Data.String
import Network.HTTP.Client import Network.HTTP.Client hiding (port)
import Network.HTTP.Types import Network.HTTP.Types
import System.Log.Logger import System.Log.Logger
import qualified Data.Map as M import qualified Data.Map as M
import qualified Network.URI as URI
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
@ -56,13 +53,13 @@ remote = RemoteType
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc = do
handle <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r gc h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r gc
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store handle) (simplyPrepare $ store h)
(simplyPrepare $ retrieve handle) (simplyPrepare $ retrieve h)
(simplyPrepare $ remove handle) (simplyPrepare $ remove h)
(simplyPrepare $ checkKey handle) (simplyPrepare $ checkKey h)
(this cst) (this cst)
where where
this cst = Remote this cst = Remote
@ -206,8 +203,10 @@ getLFSEndpoint tro hv = do
LFS.RequestDownload -> downloadEndpoint LFS.RequestDownload -> downloadEndpoint
LFS.RequestUpload -> uploadEndpoint LFS.RequestUpload -> uploadEndpoint
makeAPIRequest :: Request -> Annex (Response L.ByteString) -- Make an API request that is expected to have a small response body.
makeAPIRequest req = do -- Not for use in downloading an object.
makeSmallAPIRequest :: Request -> Annex (Response L.ByteString)
makeSmallAPIRequest req = do
uo <- getUrlOptions uo <- getUrlOptions
let req' = applyRequest uo req let req' = applyRequest uo req
liftIO $ debugM "git-lfs" (show req') liftIO $ debugM "git-lfs" (show req')
@ -225,7 +224,7 @@ sendTransferRequest
sendTransferRequest req endpoint = sendTransferRequest req endpoint =
case LFS.startTransferRequest endpoint req of case LFS.startTransferRequest endpoint req of
Just httpreq -> do Just httpreq -> do
httpresp <- makeAPIRequest $ setRequestCheckStatus httpreq httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
return $ case LFS.parseTransferResponse (responseBody httpresp) of return $ case LFS.parseTransferResponse (responseBody httpresp) of
LFS.ParsedTransferResponse resp -> Right resp LFS.ParsedTransferResponse resp -> Right resp
LFS.ParsedTransferResponseError tro -> Left $ LFS.ParsedTransferResponseError tro -> Left $
@ -317,17 +316,33 @@ store h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case
Nothing -> giveup "unable to parse git-lfs server upload url" Nothing -> giveup "unable to parse git-lfs server upload url"
Just [] -> noop -- server already has it Just [] -> noop -- server already has it
Just reqs -> forM_ reqs $ Just reqs -> forM_ reqs $
makeAPIRequest . setRequestCheckStatus makeSmallAPIRequest . setRequestCheckStatus
failederr e = do failederr e = do
warning (show e) warning (show e)
return False return False
retrieve :: TVar LFSHandle -> Retriever retrieve :: TVar LFSHandle -> Retriever
retrieve h = byteRetriever $ \k sink -> getLFSEndpoint LFS.RequestDownload h >>= \case retrieve h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> return False Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> do Just endpoint -> mkDownloadRequest k >>= \case
liftIO $ print ("endpoint", endpoint) Nothing -> giveup "unable to download this object from git-lfs"
return False Just req -> sendTransferRequest req endpoint >>= \case
Left err -> giveup (show err)
Right resp -> case LFS.objects resp of
[] -> giveup "git-lfs server did not provide a way to download this object"
(tro:_) -> receive dest p tro
where
receive dest p tro = case LFS.resp_error tro of
Just err -> giveup $ T.unpack $ LFS.respobjerr_message err
Nothing -> case LFS.resp_actions tro of
Nothing -> giveup "git-lfs server did not provide a way to download this object"
Just op -> case LFS.downloadOperationRequest op of
Nothing -> giveup "unable to parse git-lfs server download url"
Just req ->
-- TODO stream to file
-- TODO resume and append if the file already exists
giveup "TODO"
checkKey :: TVar LFSHandle -> CheckPresent checkKey :: TVar LFSHandle -> CheckPresent
checkKey h key = getLFSEndpoint LFS.RequestDownload h >>= \case checkKey h key = getLFSEndpoint LFS.RequestDownload h >>= \case
@ -338,7 +353,7 @@ checkKey h key = getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> return False Nothing -> return False
Just req -> case LFS.startTransferRequest endpoint req of Just req -> case LFS.startTransferRequest endpoint req of
Nothing -> giveup "unable to parse git-lfs endpoint url" Nothing -> giveup "unable to parse git-lfs endpoint url"
Just httpreq -> go =<< makeAPIRequest httpreq Just httpreq -> go =<< makeSmallAPIRequest httpreq
where where
go httpresp go httpresp
| responseStatus httpresp == status200 = | responseStatus httpresp == status200 =
@ -365,6 +380,6 @@ retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False retrieveCheap _ _ _ = return False
remove :: TVar LFSHandle -> Remover remove :: TVar LFSHandle -> Remover
remove h key = do remove _h _key = do
warning "git-lfs does not support removing content" warning "git-lfs does not support removing content"
return False return False