git-annex/Remote/GitLFS.hs
Joey Hess 5cfcf1f05f
cache remote.log
Unlikely to speed up any of the existing uses much, but I want to use it
in a message that might be displayed many times.
2020-09-22 13:52:26 -04:00

545 lines
19 KiB
Haskell

{- Using git-lfs as a remote.
-
- Copyright 2019-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Remote.GitLFS (remote, gen, configKnownUrl) where
import Annex.Common
import Types.Remote
import Annex.Url
import Types.Key
import Types.Creds
import Types.ProposedAccepted
import Types.NumCopies
import qualified Annex
import qualified Git
import qualified Git.Types as Git
import qualified Git.Url
import qualified Git.Remote
import qualified Git.GCrypt
import qualified Git.Credential as Git
import Config
import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.ExportImport
import Remote.Helper.Git
import Remote.Helper.Http
import qualified Remote.GCrypt
import Annex.Ssh
import Annex.UUID
import Crypto
import Backend.Hash
import Utility.Hash
import Utility.SshHost
import Utility.Url
import Logs.Remote
import Logs.RemoteState
import qualified Git.Config
#ifdef WITH_GIT_LFS
import qualified Network.GitLFS as LFS
#else
import qualified Utility.GitLFS as LFS
#endif
import Control.Concurrent.STM
import Data.String
import Network.HTTP.Types
import Network.HTTP.Client hiding (port)
import System.Log.Logger
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 = specialRemoteType $ RemoteType
{ typename = "git-lfs"
-- Remote.Git takes care of enumerating git-lfs remotes too,
-- and will call our gen on them.
, enumerate = const (return [])
, generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser urlField
(FieldDesc "url of git-lfs repository")
]
, setup = mySetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
urlField :: RemoteConfigField
urlField = Accepted "url"
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u rc gc rs = do
c <- parsedRemoteConfig remote rc
-- If the repo uses gcrypt, get the underlaying repo without the
-- gcrypt url, to do LFS endpoint discovery on.
r' <- if Git.GCrypt.isEncrypted r
then do
g <- Annex.gitRepo
liftIO $ Git.GCrypt.encryptedRemote g r
else pure r
sem <- liftIO $ MSemN.new 1
h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc
cst <- remoteCost gc expensiveRemoteCost
let specialcfg = (specialRemoteCfg c)
-- chunking would not improve git-lfs
{ chunkConfig = NoChunks
}
return $ Just $ specialRemote' specialcfg c
(store rs h)
(retrieve rs h)
(remove h)
(checkKey rs h)
(this c cst h)
where
this c cst h = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retrieveKeyFileDummy
, retrieveKeyFileCheap = Nothing
-- content stored on git-lfs is hashed with SHA256
-- no matter what git-annex key it's for, and the hash
-- is checked on download
, retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Just $ lockKey (this c cst h) rs h
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = exportUnsupported
, importActions = importUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, getRepo = return r
, gitconfig = gc
, localpath = Nothing
, remotetype = remote
, availability = GloballyAvailable
, readonly = False
-- content cannot be removed from a git-lfs repo
, appendonly = True
, mkUnavailable = return Nothing
, getInfo = gitRepoInfo (this c cst h)
, claimUrl = Nothing
, checkUrl = Nothing
, remoteStateHandle = rs
}
mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
mySetup ss mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
(c', _encsetup) <- encryptionSetup c gc
pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c'
let failinitunlessforced msg = case ss of
Init -> unlessM (Annex.getState Annex.force) (giveup msg)
Enable _ -> noop
case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of
(False, False) -> noop
(True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
(True, False) -> failinitunlessforced $ unwords $
[ "Encryption is enabled for this remote,"
, "but only the files that git-annex stores on"
, "it would be encrypted; "
, "anything that git push sends to it would"
, "not be encrypted. Recommend prefixing the"
, "url with \"gcrypt::\" to also encrypt"
, "git pushes."
, "(Use --force if you want to use this"
, "likely insecure configuration.)"
]
(False, True) -> failinitunlessforced $ unwords
[ "You used a \"gcrypt::\" url for this remote,"
, "but encryption=none prevents git-annex"
, "from encrypting files it stores there."
, "(Use --force if you want to use this"
, "likely insecure configuration.)"
]
-- Set up remote.name.url to point to the repo,
-- (so it's also usable by git as a non-special remote),
-- and set remote.name.annex-git-lfs = true
gitConfigSpecialRemote u c' [("git-lfs", "true")]
setConfig (remoteConfig c "url") url
return (c', u)
where
url = maybe (giveup "Specify url=") fromProposedAccepted
(M.lookup urlField c)
remotename = fromJust (lookupName c)
{- Check if a remote's url is one known to belong to a git-lfs repository.
- If so, set the necessary configuration to enable using the remote
- with git-lfs. -}
configKnownUrl :: Git.Repo -> Annex (Maybe Git.Repo)
configKnownUrl r
| Git.repoIsUrl r = do
m <- remoteConfigMap
g <- Annex.gitRepo
case Annex.SpecialRemote.Config.findByRemoteConfig (match g) m of
((u, _, mcu):[]) -> Just <$> go u mcu
_ -> return Nothing
| otherwise = return Nothing
where
match g c = fromMaybe False $ do
t <- fromProposedAccepted
<$> M.lookup Annex.SpecialRemote.Config.typeField c
u <- fromProposedAccepted
<$> M.lookup urlField c
let u' = Git.Remote.parseRemoteLocation u g
return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u'
&& t == typename remote
go u mcu = do
r' <- set "uuid" (fromUUID u) =<< set "git-lfs" "true" r
case mcu of
Just (Annex.SpecialRemote.Config.ConfigFrom cu) ->
set "config-uuid" (fromUUID cu) r'
Nothing -> return r'
set k v r' = do
let k' = remoteAnnexConfig r' k
setConfig k' v
return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r'
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 = unsupportedurischeme
where
r = remoteRepo h
lfsrepouri = case Git.location r of
Git.Url u -> u
_ -> giveup $ "unsupported git-lfs remote location " ++ Git.repoLocation r
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."
return Nothing
Just (Left err) -> do
warning err
return Nothing
Just (Right hostuser) -> do
let port = Git.Url.port r
-- Remove leading /~/ from path. That is added when
-- converting a scp-style repository location with
-- a relative path into an url, and is legal
-- according to git-clone(1), but github does not
-- support it.
let remotepath = if "/~/" `isPrefixOf` Git.Url.path r
then drop 3 (Git.Url.path r)
else Git.Url.path r
let ps = LFS.sshDiscoverEndpointCommand remotepath tro
-- Note that no shellEscape is done here, because
-- at least github's git-lfs implementation does
-- not allow for shell quoting.
let remotecmd = unwords ps
(sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd
liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case
Left err -> do
warning $ "ssh connection to git-lfs remote failed: " ++ show err
return Nothing
Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of
Nothing -> do
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 (Git.credentialBasicAuth 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 (Just ba) endpoint =
LFS.modifyEndpointRequest endpoint $
applyBasicAuth' ba
addbasicauth Nothing endpoint = endpoint
-- The endpoint is cached for later use.
getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
getLFSEndpoint tro hv = do
h <- liftIO $ atomically $ readTVar hv
case f h of
Just endpoint -> return (Just endpoint)
Nothing -> withEndPointLock h $ discoverLFSEndpoint tro h >>= \case
Just endpoint -> do
liftIO $ atomically $ writeTVar hv $
case tro of
LFS.RequestDownload ->
h { downloadEndpoint = Just endpoint }
LFS.RequestUpload ->
h { uploadEndpoint = Just endpoint }
return (Just endpoint)
Nothing -> return Nothing
where
f = case tro of
LFS.RequestDownload -> downloadEndpoint
LFS.RequestUpload -> uploadEndpoint
-- Make an API request that is expected to have a small response body.
-- Not for use in downloading an object.
makeSmallAPIRequest :: Request -> Annex (Response L.ByteString)
makeSmallAPIRequest req = do
uo <- getUrlOptions
let req' = applyRequest uo req
liftIO $ debugM "git-lfs" (show req')
resp <- liftIO $ httpLbs req' (httpManager uo)
-- Only debug the http status code, not the json
-- which may include an authentication token.
liftIO $ debugM "git-lfs" (show $ responseStatus resp)
return resp
sendTransferRequest
:: LFS.IsTransferResponseOperation op
=> LFS.TransferRequest
-> LFS.Endpoint
-> Annex (Either String (LFS.TransferResponse op))
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 fromKey keyVariety k of
SHA2Key (HashSize 256) (HasExt hasext)
| hasext -> eitherToMaybe $ E.decodeUtf8' (keyHash k)
| otherwise -> eitherToMaybe $ E.decodeUtf8' (fromKey keyName k)
_ -> Nothing
-- The size of an encrypted key is the size of the input data, but we need
-- the actual object size.
extractKeySize :: Key -> Maybe Integer
extractKeySize k
| isEncKey k = Nothing
| otherwise = fromKey keySize k
mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) ->
ret sha256 size
(_, Just size) -> do
sha256 <- calcsha256
remembersha256 sha256
ret sha256 size
_ -> do
sha256 <- calcsha256
size <- liftIO $ getFileSize content
rememberboth sha256 size
ret sha256 size
where
calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content
ret sha256 size = do
let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256
, LFS.req_size = size
}
let req = LFS.TransferRequest
{ LFS.req_operation = LFS.RequestUpload
, LFS.req_transfers = [LFS.Basic]
, LFS.req_ref = Nothing
, LFS.req_objects = [obj]
}
return (req, sha256, size)
remembersha256 sha256 = setRemoteState rs k (T.unpack sha256)
rememberboth sha256 size = setRemoteState rs k $
show size ++ " " ++ T.unpack sha256
mkDownloadRequest :: RemoteStateHandle -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer))
mkDownloadRequest rs k = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) -> ret sha256 size
(_, Just size) ->
remembersha256 >>= \case
Just sha256 -> ret sha256 size
Nothing -> return Nothing
_ -> do
rememberboth >>= \case
Just (sha256, size) -> ret sha256 size
Nothing -> return Nothing
where
ret sha256 size = do
let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256
, LFS.req_size = size
}
let req = LFS.TransferRequest
{ LFS.req_operation = LFS.RequestDownload
, LFS.req_transfers = [LFS.Basic]
, LFS.req_ref = Nothing
, LFS.req_objects = [obj]
}
return $ Just (req, sha256, size)
remembersha256 = fmap T.pack <$> getRemoteState rs k
rememberboth = maybe Nothing parse <$> getRemoteState rs k
where
parse s = case words s of
[ssize, ssha256] -> do
size <- readish ssize
return (T.pack ssha256, size)
_ -> Nothing
store :: RemoteStateHandle -> TVar LFSHandle -> Storer
store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case
Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> do
(req, sha256, size) <- mkUploadRequest rs k src
sendTransferRequest req endpoint >>= \case
Right resp -> do
body <- liftIO $ httpBodyStorer src p
forM_ (LFS.objects resp) $
send body sha256 size
Left err -> giveup err
where
send body sha256 size tro
| LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size =
giveup "git-lfs server requested other object than the one we asked to send"
| otherwise = case LFS.resp_error tro of
Just err -> giveup $
T.unpack $ LFS.respobjerr_message err
Nothing -> case LFS.resp_actions tro of
Nothing -> noop
Just op -> case LFS.uploadOperationRequests op body sha256 size of
Nothing -> giveup "unable to parse git-lfs server upload url"
Just [] -> noop -- server already has it
Just reqs -> forM_ reqs $
makeSmallAPIRequest . setRequestCheckStatus
retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever
retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> mkDownloadRequest rs k >>= \case
Nothing -> giveup "unable to download this object from git-lfs"
Just (req, sha256, size) -> 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:_)
| LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size ->
giveup "git-lfs server replied with other object than the one we requested"
| otherwise -> go dest p tro
where
go 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 -> do
uo <- getUrlOptions
liftIO $ downloadConduit p req dest uo
-- Since git-lfs does not support removing content, nothing needs to be
-- done to lock content in the remote, except for checking that the content
-- is actually present.
lockKey :: Remote -> RemoteStateHandle -> TVar LFSHandle -> Key -> (VerifiedCopy -> Annex a) -> Annex a
lockKey r rs h key callback =
ifM (checkKey rs h key)
( withVerifiedCopy LockedCopy (uuid r) (return True) callback
, giveup $ "content seems to be missing from " ++ name r
)
checkKey :: RemoteStateHandle -> TVar LFSHandle -> CheckPresent
checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> mkDownloadRequest rs key >>= \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) -> go sha256 size
=<< makeSmallAPIRequest (LFS.startTransferRequest endpoint req)
where
go sha256 size httpresp
| responseStatus httpresp == status200 = go' sha256 size $
LFS.parseTransferResponse (responseBody httpresp)
| otherwise = giveup $
"git-lfs server refused request: " ++ show (responseStatus httpresp)
go' :: LFS.SHA256 -> Integer -> LFS.ParsedTransferResponse LFS.DownloadOperation -> Annex Bool
go' _ _ (LFS.ParseFailed err) =
giveup $ "unable to parse response from git-lfs server: " ++ err
-- If the server responds with a json error message,
-- the content is presumably not present.
go' _ _ (LFS.ParsedTransferResponseError _) = return False
-- If the server responds with at least one download operation,
-- we will assume the content is present. We could also try to HEAD
-- that download, but there's no guarantee HEAD is supported, and
-- at most that would detect breakage where the server is confused
-- about what objects it has.
go' sha256 size (LFS.ParsedTransferResponse resp) =
case LFS.objects resp of
[] -> return False
(tro:_)
| isNothing (LFS.resp_actions tro) -> return False
| isJust (LFS.resp_error tro) -> return False
| LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size ->
giveup "git-lfs server replied with other object than the one we requested"
| otherwise -> return True
remove :: TVar LFSHandle -> Remover
remove _h _key = giveup "git-lfs does not support removing content"