d2b27ca136
This allows lockContentShared to lock content for eg, 10 minutes and if the process then gets terminated before it can unlock, the content will remain locked for that amount of time. The Windows implementation is not yet tested. In P2P.Annex, a duration of 10 minutes is used. This way, when p2pstdio or remotedaemon is serving the P2P protocol, and is asked to LOCKCONTENT, and that process gets killed, the content will not be subject to deletion. This is not a perfect solution to doc/todo/P2P_locking_connection_drop_safety.mdwn yet, but it gets most of the way there, without needing any P2P protocol changes. This is only done in v10 and higher repositories (or on Windows). It might be possible to backport it to v8 or earlier, but it would complicate locking even further, and without a separate lock file, might be hard. I think that by the time this fix reaches a given user, they will probably have been running git-annex 10.x long enough that their v8 repositories will have upgraded to v10 after the 1 year wait. And it's not as if git-annex hasn't already been subject to this problem (though I have not heard of any data loss caused by it) for 6 years already, so waiting another fraction of a year on top of however long it takes this fix to reach users is unlikely to be a problem.
907 lines
31 KiB
Haskell
907 lines
31 KiB
Haskell
{- Standard git remotes.
|
|
-
|
|
- Copyright 2011-2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Remote.Git (
|
|
remote,
|
|
configRead,
|
|
onLocalRepo,
|
|
) where
|
|
|
|
import Annex.Common
|
|
import Annex.Ssh
|
|
import Types.Remote
|
|
import Types.GitConfig
|
|
import qualified Git
|
|
import qualified Git.Config
|
|
import qualified Git.Construct
|
|
import qualified Git.Command
|
|
import qualified Git.GCrypt
|
|
import qualified Git.Types as Git
|
|
import qualified Annex
|
|
import Annex.Transfer
|
|
import Annex.CopyFile
|
|
import Annex.Verify
|
|
import Annex.Content (verificationOfContentFailed)
|
|
import Annex.UUID
|
|
import qualified Annex.Content
|
|
import qualified Annex.BranchState
|
|
import qualified Annex.Branch
|
|
import qualified Annex.Url as Url
|
|
import qualified Annex.SpecialRemote.Config as SpecialRemote
|
|
import Utility.Tmp
|
|
import Config
|
|
import Config.Cost
|
|
import Annex.SpecialRemote.Config
|
|
import Config.DynamicConfig
|
|
import Annex.Init
|
|
import Types.CleanupActions
|
|
import qualified CmdLine.GitAnnexShell.Fields as Fields
|
|
import Logs.Location
|
|
import Logs.Proxy
|
|
import Logs.Cluster.Basic
|
|
import Utility.Metered
|
|
import Utility.Env
|
|
import Utility.Batch
|
|
import Remote.Helper.Git
|
|
import Remote.Helper.Messages
|
|
import Remote.Helper.ExportImport
|
|
import qualified Remote.Helper.Ssh as Ssh
|
|
import qualified Remote.GCrypt
|
|
import qualified Remote.GitLFS
|
|
import qualified Remote.P2P
|
|
import qualified Remote.Helper.P2P as P2PHelper
|
|
import P2P.Address
|
|
import Annex.Path
|
|
import Creds
|
|
import Types.NumCopies
|
|
import Types.ProposedAccepted
|
|
import Annex.Action
|
|
import Messages.Progress
|
|
|
|
import Control.Concurrent
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
import qualified Data.ByteString as B
|
|
import qualified Utility.RawFilePath as R
|
|
import Network.URI
|
|
|
|
remote :: RemoteType
|
|
remote = RemoteType
|
|
{ typename = "git"
|
|
, enumerate = list
|
|
, generate = gen
|
|
, configParser = mkRemoteConfigParser
|
|
[ optionalStringParser locationField
|
|
(FieldDesc "url of git remote to remember with special remote")
|
|
]
|
|
, setup = gitSetup
|
|
, exportSupported = exportUnsupported
|
|
, importSupported = importUnsupported
|
|
, thirdPartyPopulated = False
|
|
}
|
|
|
|
locationField :: RemoteConfigField
|
|
locationField = Accepted "location"
|
|
|
|
list :: Bool -> Annex [Git.Repo]
|
|
list autoinit = do
|
|
c <- fromRepo Git.config
|
|
rs <- mapM (tweakurl c) =<< Annex.getGitRemotes
|
|
rs' <- mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs)
|
|
proxies <- doQuietAction getProxies
|
|
if proxies == mempty
|
|
then return rs'
|
|
else do
|
|
proxied <- listProxied proxies rs'
|
|
return (proxied++rs')
|
|
where
|
|
annexurl r = remoteConfig r "annexurl"
|
|
tweakurl c r = do
|
|
let n = fromJust $ Git.remoteName r
|
|
case M.lookup (annexurl r) c of
|
|
Nothing -> return r
|
|
Just url -> inRepo $ \g ->
|
|
Git.Construct.remoteNamed n $
|
|
Git.Construct.fromRemoteLocation (Git.fromConfigValue url) False g
|
|
|
|
isGitRemoteAnnex :: Git.Repo -> Bool
|
|
isGitRemoteAnnex r = "annex::" `isPrefixOf` Git.repoLocation r
|
|
|
|
{- Git remotes are normally set up using standard git commands, not
|
|
- git-annex initremote and enableremote.
|
|
-
|
|
- For initremote, probe the location to find the uuid.
|
|
- and set up a git remote.
|
|
-
|
|
- enableremote simply sets up a git remote using the stored location.
|
|
- No attempt is made to make the remote be accessible via ssh key setup,
|
|
- etc.
|
|
-}
|
|
gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
|
gitSetup Init mu _ c _ = do
|
|
let location = maybe (giveup "Specify location=url") fromProposedAccepted $
|
|
M.lookup locationField c
|
|
r <- inRepo $ Git.Construct.fromRemoteLocation location False
|
|
r' <- tryGitConfigRead False r False
|
|
let u = getUncachedUUID r'
|
|
if u == NoUUID
|
|
then giveup "git repository does not have an annex uuid"
|
|
else if isNothing mu || mu == Just u
|
|
then enableRemote (Just u) c
|
|
else giveup "git repository does not have specified uuid"
|
|
gitSetup (Enable _) mu _ c _ = enableRemote mu c
|
|
gitSetup (AutoEnable _) mu _ c _ = enableRemote mu c
|
|
|
|
enableRemote :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
|
enableRemote (Just u) c = do
|
|
rs <- Annex.getGitRemotes
|
|
unless (any (\r -> Git.remoteName r == Just cname) rs) $
|
|
inRepo $ Git.Command.run
|
|
[ Param "remote"
|
|
, Param "add"
|
|
, Param cname
|
|
, Param clocation
|
|
]
|
|
return (c, u)
|
|
where
|
|
cname = fromMaybe (giveup "no name") (SpecialRemote.lookupName c)
|
|
clocation = maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c)
|
|
enableRemote Nothing _ = giveup "unable to enable git remote with no specified uuid"
|
|
|
|
{- It's assumed to be cheap to read the config of non-URL remotes, so this is
|
|
- done each time git-annex is run in a way that uses remotes, unless
|
|
- annex-checkuuid is false.
|
|
-
|
|
- Conversely, the config of an URL remote is only read when there is no
|
|
- cached UUID value. -}
|
|
configRead :: Bool -> Git.Repo -> Annex Git.Repo
|
|
configRead autoinit r = do
|
|
gc <- Annex.getRemoteGitConfig r
|
|
hasuuid <- (/= NoUUID) <$> getRepoUUID r
|
|
annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc)
|
|
case (repoCheap r, annexignore, hasuuid) of
|
|
(_, True, _) -> return r
|
|
(True, _, _)
|
|
| remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r hasuuid
|
|
| otherwise -> return r
|
|
(False, _, False) -> configSpecialGitRemotes r >>= \case
|
|
Nothing -> tryGitConfigRead autoinit r False
|
|
Just r' -> return r'
|
|
_ -> return r
|
|
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
|
gen r u rc gc rs
|
|
-- Remote.GitLFS may be used with a repo that is also encrypted
|
|
-- with gcrypt so is checked first.
|
|
| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u rc gc rs
|
|
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u rc gc rs
|
|
| otherwise = case repoP2PAddress r of
|
|
Nothing -> do
|
|
st <- mkState r u gc
|
|
c <- parsedRemoteConfig remote rc
|
|
go st c <$> remoteCost gc c (defaultRepoCost r)
|
|
Just addr -> Remote.P2P.chainGen addr r u rc gc rs
|
|
where
|
|
go st c cst = Just new
|
|
where
|
|
new = Remote
|
|
{ uuid = u
|
|
, cost = cst
|
|
, name = Git.repoDescribe r
|
|
, storeKey = copyToRemote new st
|
|
, retrieveKeyFile = copyFromRemote new st
|
|
, retrieveKeyFileCheap = copyFromRemoteCheap st r
|
|
, retrievalSecurityPolicy = RetrievalAllKeysSecure
|
|
, removeKey = dropKey new st
|
|
, lockContent = Just (lockKey new st)
|
|
, checkPresent = inAnnex new st
|
|
, checkPresentCheap = repoCheap r
|
|
, exportActions = exportUnsupported
|
|
, importActions = importUnsupported
|
|
, whereisKey = Nothing
|
|
, remoteFsck = if Git.repoIsUrl r
|
|
then Nothing
|
|
else Just $ fsckOnRemote r
|
|
, repairRepo = if Git.repoIsUrl r
|
|
then Nothing
|
|
else Just $ repairRemote r
|
|
, config = c
|
|
, localpath = localpathCalc r
|
|
, getRepo = getRepoFromState st
|
|
, gitconfig = gc
|
|
, readonly = Git.repoIsHttp r
|
|
, appendonly = False
|
|
, untrustworthy = False
|
|
, availability = repoAvail r
|
|
, remotetype = remote
|
|
, mkUnavailable = unavailable r u rc gc rs
|
|
, getInfo = gitRepoInfo new
|
|
, claimUrl = Nothing
|
|
, checkUrl = Nothing
|
|
, remoteStateHandle = rs
|
|
}
|
|
|
|
defaultRepoCost :: Git.Repo -> Cost
|
|
defaultRepoCost r
|
|
| repoCheap r = cheapRemoteCost
|
|
| otherwise = expensiveRemoteCost
|
|
|
|
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
|
unavailable r = gen r'
|
|
where
|
|
r' = case Git.location r of
|
|
Git.Local { Git.gitdir = d } ->
|
|
r { Git.location = Git.LocalUnknown d }
|
|
Git.Url url -> case uriAuthority url of
|
|
Just auth ->
|
|
let auth' = auth { uriRegName = "!dne!" }
|
|
in r { Git.location = Git.Url (url { uriAuthority = Just auth' })}
|
|
Nothing -> r { Git.location = Git.Unknown }
|
|
_ -> r -- already unavailable
|
|
|
|
{- Tries to read the config for a specified remote, updates state, and
|
|
- returns the updated repo. -}
|
|
tryGitConfigRead :: Bool -> Git.Repo -> Bool -> Annex Git.Repo
|
|
tryGitConfigRead autoinit r hasuuid
|
|
| haveconfig r = return r -- already read
|
|
| Git.repoIsSsh r = storeUpdatedRemote $ do
|
|
v <- Ssh.onRemote NoConsumeStdin r
|
|
( pipedconfig Git.Config.ConfigList autoinit (Git.repoDescribe r)
|
|
, return (Left "configlist failed")
|
|
)
|
|
"configlist" [] configlistfields
|
|
case v of
|
|
Right r'
|
|
| haveconfig r' -> return r'
|
|
| otherwise -> configlist_failed
|
|
Left _ -> configlist_failed
|
|
| Git.repoIsHttp r = storeUpdatedRemote geturlconfig
|
|
| Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteAnnexConfig r "uuid")
|
|
| Git.repoIsUrl r = do
|
|
set_ignore "uses a protocol not supported by git-annex" False
|
|
return r
|
|
| otherwise = storeUpdatedRemote $
|
|
readlocalannexconfig
|
|
`catchNonAsync` const failedreadlocalconfig
|
|
where
|
|
haveconfig = not . M.null . Git.config
|
|
|
|
pipedconfig st mustincludeuuuid configloc cmd params = do
|
|
v <- liftIO $ Git.Config.fromPipe r cmd params st
|
|
case v of
|
|
Right (r', val, _err) -> do
|
|
unless (isUUIDConfigured r' || val == mempty || not mustincludeuuuid) $ do
|
|
warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
|
warning $ UnquotedString $ "Instead, got: " ++ show val
|
|
warning "This is unexpected; please check the network transport!"
|
|
return $ Right r'
|
|
Left l -> do
|
|
warning $ UnquotedString $ "Unable to parse git config from " ++ configloc
|
|
return $ Left (show l)
|
|
|
|
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
|
|
let url = Git.repoLocation r ++ "/config"
|
|
v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do
|
|
liftIO $ hClose h
|
|
Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
|
|
Right () -> pipedconfig Git.Config.ConfigNullList
|
|
False url "git"
|
|
[ Param "config"
|
|
, Param "--null"
|
|
, Param "--list"
|
|
, Param "--file"
|
|
, File tmpfile
|
|
]
|
|
Left err -> return (Left err)
|
|
case v of
|
|
Right r' -> do
|
|
-- Cache when http remote is not bare for
|
|
-- optimisation.
|
|
unless (fromMaybe False $ Git.Config.isBare r') $
|
|
setremote setRemoteBare False
|
|
return r'
|
|
Left err -> do
|
|
set_ignore "not usable by git-annex" False
|
|
warning $ UnquotedString $ url ++ " " ++ err
|
|
return r
|
|
|
|
{- Is this remote just not available, or does
|
|
- it not have git-annex-shell?
|
|
- Find out by trying to fetch from the remote. -}
|
|
configlist_failed = case Git.remoteName r of
|
|
Nothing -> return r
|
|
Just n -> do
|
|
whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do
|
|
set_ignore "does not have git-annex installed" True
|
|
return r
|
|
|
|
set_ignore msg longmessage = do
|
|
case Git.remoteName r of
|
|
Nothing -> noop
|
|
Just n -> do
|
|
warning $ UnquotedString $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"
|
|
when longmessage $
|
|
warning $ UnquotedString $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n
|
|
setremote setRemoteIgnore True
|
|
|
|
setremote setter v = case Git.remoteName r of
|
|
Nothing -> noop
|
|
Just _ -> setter r v
|
|
|
|
handlegcrypt Nothing = return r
|
|
handlegcrypt (Just _cacheduuid) = do
|
|
-- Generate UUID from the gcrypt-id
|
|
g <- gitRepo
|
|
case Git.GCrypt.remoteRepoId g (Git.remoteName r) of
|
|
Nothing -> return r
|
|
Just v -> storeUpdatedRemote $ liftIO $ setUUID r $
|
|
genUUIDInNameSpace gCryptNameSpace (encodeBS v)
|
|
|
|
{- The local repo may not yet be initialized, so try to initialize
|
|
- it if allowed. However, if that fails, still return the read
|
|
- git config. -}
|
|
readlocalannexconfig = do
|
|
let check = do
|
|
Annex.BranchState.disableUpdate
|
|
catchNonAsync (autoInitialize noop (pure [])) $ \e ->
|
|
warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++
|
|
": " ++ show e
|
|
Annex.getState Annex.repo
|
|
let r' = r { Git.repoPathSpecifiedExplicitly = True }
|
|
s <- newLocal r'
|
|
liftIO $ Annex.eval s $ check
|
|
`finally` quiesce True
|
|
|
|
failedreadlocalconfig = do
|
|
unless hasuuid $ case Git.remoteName r of
|
|
Nothing -> noop
|
|
Just n -> do
|
|
warning $ UnquotedString $ "Remote " ++ n ++ " cannot currently be accessed."
|
|
return r
|
|
|
|
configlistfields = if autoinit
|
|
then [(Fields.autoInit, "1")]
|
|
else []
|
|
|
|
{- Handles special remotes that can be enabled by the presence of
|
|
- regular git remotes.
|
|
-
|
|
- When a remote repo is found to be such a special remote, its
|
|
- UUID is cached in the git config, and the repo returned with
|
|
- the UUID set.
|
|
-}
|
|
configSpecialGitRemotes :: Git.Repo -> Annex (Maybe Git.Repo)
|
|
configSpecialGitRemotes r = Remote.GitLFS.configKnownUrl r >>= \case
|
|
Nothing -> return Nothing
|
|
Just r' -> Just <$> storeUpdatedRemote (return r')
|
|
|
|
storeUpdatedRemote :: Annex Git.Repo -> Annex Git.Repo
|
|
storeUpdatedRemote = observe $ \r' -> do
|
|
l <- Annex.getGitRemotes
|
|
let rs = exchange l r'
|
|
Annex.changeState $ \s -> s { Annex.gitremotes = Just rs }
|
|
where
|
|
exchange [] _ = []
|
|
exchange (old:ls) new
|
|
| Git.remoteName old == Git.remoteName new =
|
|
new : exchange ls new
|
|
| otherwise =
|
|
old : exchange ls new
|
|
|
|
{- Checks if a given remote has the content for a key in its annex. -}
|
|
inAnnex :: Remote -> State -> Key -> Annex Bool
|
|
inAnnex rmt st key = do
|
|
repo <- getRepo rmt
|
|
inAnnex' repo rmt st key
|
|
|
|
inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
|
|
inAnnex' repo rmt st@(State connpool duc _ _ _) key
|
|
| Git.repoIsHttp repo = checkhttp
|
|
| Git.repoIsUrl repo = checkremote
|
|
| otherwise = checklocal
|
|
where
|
|
checkhttp = do
|
|
gc <- Annex.getGitConfig
|
|
Url.withUrlOptionsPromptingCreds $ \uo ->
|
|
anyM (\u -> Url.checkBoth u (fromKey keySize key) uo)
|
|
(keyUrls gc repo rmt key)
|
|
checkremote = P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt)) key
|
|
checklocal = ifM duc
|
|
( guardUsable repo (cantCheck repo) $
|
|
maybe (cantCheck repo) return
|
|
=<< onLocalFast st (Annex.Content.inAnnexSafe key)
|
|
, cantCheck repo
|
|
)
|
|
|
|
keyUrls :: GitConfig -> Git.Repo -> Remote -> Key -> [String]
|
|
keyUrls gc repo r key = map tourl locs'
|
|
where
|
|
tourl l = Git.repoLocation repo ++ "/" ++ l
|
|
-- If the remote is known to not be bare, try the hash locations
|
|
-- used for non-bare repos first, as an optimisation.
|
|
locs
|
|
| remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key
|
|
| otherwise = annexLocationsBare gc key
|
|
#ifndef mingw32_HOST_OS
|
|
locs' = map fromRawFilePath locs
|
|
#else
|
|
locs' = map (replace "\\" "/" . fromRawFilePath) locs
|
|
#endif
|
|
remoteconfig = gitconfig r
|
|
|
|
dropKey :: Remote -> State -> Key -> Annex ()
|
|
dropKey r st key = do
|
|
repo <- getRepo r
|
|
dropKey' repo r st key
|
|
|
|
dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex ()
|
|
dropKey' repo r st@(State connpool duc _ _ _) key
|
|
| not $ Git.repoIsUrl repo = ifM duc
|
|
( guardUsable repo (giveup "cannot access remote") $
|
|
commitOnCleanup repo r st $ onLocalFast st $ do
|
|
whenM (Annex.Content.inAnnex key) $ do
|
|
let cleanup = logStatus key InfoMissing
|
|
Annex.Content.lockContentForRemoval key cleanup $ \lock -> do
|
|
Annex.Content.removeAnnex lock
|
|
cleanup
|
|
, giveup "remote does not have expected annex.uuid value"
|
|
)
|
|
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
|
|
| otherwise = P2PHelper.remove (uuid r)
|
|
(Ssh.runProto r connpool (return (Right False, Nothing))) key
|
|
|
|
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
|
lockKey r st key callback = do
|
|
repo <- getRepo r
|
|
lockKey' repo r st key callback
|
|
|
|
lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
|
lockKey' repo r st@(State connpool duc _ _ _) key callback
|
|
| not $ Git.repoIsUrl repo = ifM duc
|
|
( guardUsable repo failedlock $ do
|
|
inorigrepo <- Annex.makeRunner
|
|
-- Lock content from perspective of remote,
|
|
-- and then run the callback in the original
|
|
-- annex monad, not the remote's.
|
|
onLocalFast st $
|
|
Annex.Content.lockContentShared key Nothing $
|
|
liftIO . inorigrepo . callback
|
|
, failedlock
|
|
)
|
|
| Git.repoIsSsh repo = do
|
|
showLocking r
|
|
let withconn = Ssh.withP2PShellConnection r connpool failedlock
|
|
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
|
|
| otherwise = failedlock
|
|
where
|
|
failedlock = giveup "can't lock content"
|
|
|
|
{- Tries to copy a key's content from a remote's annex to a file. -}
|
|
copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
|
|
copyFromRemote r st key file dest meterupdate vc = do
|
|
repo <- getRepo r
|
|
copyFromRemote'' repo r st key file dest meterupdate vc
|
|
|
|
copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
|
|
copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc
|
|
| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do
|
|
gc <- Annex.getGitConfig
|
|
ok <- Url.withUrlOptionsPromptingCreds $
|
|
Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest
|
|
unless ok $
|
|
giveup "failed to download content"
|
|
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do
|
|
u <- getUUID
|
|
hardlink <- wantHardLink
|
|
let bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
|
|
<|> remoteAnnexBwLimit (gitconfig r)
|
|
-- run copy from perspective of remote
|
|
onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case
|
|
Just (object, _sz, check) -> do
|
|
let checksuccess = check >>= \case
|
|
Just err -> giveup err
|
|
Nothing -> return True
|
|
copier <- mkFileCopier hardlink st
|
|
(ok, v) <- runTransfer (Transfer Download u (fromKey id key))
|
|
Nothing file Nothing stdRetry $ \p ->
|
|
metered (Just (combineMeterUpdate p meterupdate)) key bwlimit $ \_ p' ->
|
|
copier object dest key p' checksuccess vc
|
|
if ok
|
|
then return v
|
|
else giveup "failed to retrieve content from remote"
|
|
Nothing -> giveup "content is not present in remote"
|
|
| Git.repoIsSsh repo =
|
|
P2PHelper.retrieve
|
|
(gitconfig r)
|
|
(Ssh.runProto r connpool (return (False, UnVerified)))
|
|
key file dest meterupdate vc
|
|
| otherwise = giveup "copying from non-ssh, non-http remote not supported"
|
|
|
|
copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
|
|
#ifndef mingw32_HOST_OS
|
|
copyFromRemoteCheap st repo
|
|
| not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do
|
|
gc <- getGitConfigFromState st
|
|
loc <- liftIO $ gitAnnexLocation key repo gc
|
|
liftIO $ ifM (R.doesPathExist loc)
|
|
( do
|
|
absloc <- absPath loc
|
|
R.createSymbolicLink absloc (toRawFilePath file)
|
|
, giveup "remote does not contain key"
|
|
)
|
|
| otherwise = Nothing
|
|
#else
|
|
copyFromRemoteCheap _ _ = Nothing
|
|
#endif
|
|
|
|
{- Tries to copy a key's content to a remote's annex. -}
|
|
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
|
|
copyToRemote r st key af o meterupdate = do
|
|
repo <- getRepo r
|
|
copyToRemote' repo r st key af o meterupdate
|
|
|
|
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
|
|
copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
|
|
| not $ Git.repoIsUrl repo = ifM duc
|
|
( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $
|
|
copylocal =<< Annex.Content.prepSendAnnex' key o
|
|
, giveup "remote does not have expected annex.uuid value"
|
|
)
|
|
| Git.repoIsSsh repo =
|
|
P2PHelper.store (uuid r) (gitconfig r)
|
|
(Ssh.runProto r connpool (return Nothing))
|
|
key af o meterupdate
|
|
|
|
| otherwise = giveup "copying to non-ssh repo not supported"
|
|
where
|
|
copylocal Nothing = giveup "content not available"
|
|
copylocal (Just (object, sz, check)) = do
|
|
-- The check action is going to be run in
|
|
-- the remote's Annex, but it needs access to the local
|
|
-- Annex monad's state.
|
|
checkio <- Annex.withCurrentState check
|
|
u <- getUUID
|
|
hardlink <- wantHardLink
|
|
let bwlimit = remoteAnnexBwLimitUpload (gitconfig r)
|
|
<|> remoteAnnexBwLimit (gitconfig r)
|
|
-- run copy from perspective of remote
|
|
res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
|
|
( return True
|
|
, runTransfer (Transfer Download u (fromKey id key)) Nothing af Nothing stdRetry $ \p -> do
|
|
let verify = RemoteVerify r
|
|
copier <- mkFileCopier hardlink st
|
|
let rsp = RetrievalAllKeysSecure
|
|
let checksuccess = liftIO checkio >>= \case
|
|
Just err -> giveup err
|
|
Nothing -> return True
|
|
logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
|
|
metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
|
|
copier object (fromRawFilePath dest) key p' checksuccess verify
|
|
)
|
|
unless res $
|
|
giveup "failed to send content to remote"
|
|
|
|
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
|
|
fsckOnRemote r params
|
|
| Git.repoIsUrl r = return $ return False
|
|
| otherwise = return $ do
|
|
program <- programPath
|
|
r' <- Git.Config.read r
|
|
environ <- getEnvironment
|
|
let environ' = addEntries
|
|
[ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r')
|
|
, ("GIT_DIR", fromRawFilePath $ Git.localGitDir r')
|
|
] environ
|
|
batchCommandEnv program (Param "fsck" : params) (Just environ')
|
|
|
|
{- The passed repair action is run in the Annex monad of the remote. -}
|
|
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
|
|
repairRemote r a = return $ do
|
|
s <- Annex.new r
|
|
Annex.eval s $ do
|
|
Annex.BranchState.disableUpdate
|
|
ensureInitialized noop (pure [])
|
|
a `finally` quiesce True
|
|
|
|
data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)])
|
|
|
|
{- This can safely be called on a Repo that is not local, but of course
|
|
- onLocal will not work if used with the result. -}
|
|
mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex)
|
|
mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar [])
|
|
|
|
{- Runs an action from the perspective of a local remote.
|
|
-
|
|
- The AnnexState is cached for speed and to avoid resource leaks.
|
|
- However, it is quiesced after each call to avoid git processes
|
|
- hanging around on removable media.
|
|
-
|
|
- The remote will be automatically initialized/upgraded first,
|
|
- when possible.
|
|
-}
|
|
onLocal :: State -> Annex a -> Annex a
|
|
onLocal (State _ _ _ _ lra) = onLocal' lra
|
|
|
|
onLocalRepo :: Git.Repo -> Annex a -> Annex a
|
|
onLocalRepo repo a = do
|
|
lra <- mkLocalRemoteAnnex repo
|
|
onLocal' lra a
|
|
|
|
newLocal :: Git.Repo -> Annex (Annex.AnnexState, Annex.AnnexRead)
|
|
newLocal repo = do
|
|
(st, rd) <- liftIO $ Annex.new repo
|
|
debugenabled <- Annex.getRead Annex.debugenabled
|
|
debugselector <- Annex.getRead Annex.debugselector
|
|
force <- Annex.getRead Annex.force
|
|
return (st, rd
|
|
{ Annex.debugenabled = debugenabled
|
|
, Annex.debugselector = debugselector
|
|
, Annex.force = force
|
|
})
|
|
|
|
onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a
|
|
onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case
|
|
[] -> do
|
|
liftIO $ putMVar mv []
|
|
v <- newLocal repo
|
|
go (v, ensureInitialized noop (pure []) >> a)
|
|
(v:rest) -> do
|
|
liftIO $ putMVar mv rest
|
|
go (v, a)
|
|
where
|
|
go ((st, rd), a') = do
|
|
curro <- Annex.getState Annex.output
|
|
let act = Annex.run (st { Annex.output = curro }, rd) $
|
|
a' `finally` quiesce True
|
|
(ret, (st', _rd)) <- liftIO $ act `onException` cache (st, rd)
|
|
liftIO $ cache (st', rd)
|
|
return ret
|
|
cache v = do
|
|
l <- takeMVar mv
|
|
putMVar mv (v:l)
|
|
|
|
{- Faster variant of onLocal.
|
|
-
|
|
- The repository's git-annex branch is not updated, as an optimisation.
|
|
- No caller of onLocalFast can query data from the branch and be ensured
|
|
- it gets the most current value. Caller of onLocalFast can make changes
|
|
- to the branch, however.
|
|
-}
|
|
onLocalFast :: State -> Annex a -> Annex a
|
|
onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a
|
|
|
|
commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a
|
|
commitOnCleanup repo r st a = go `after` a
|
|
where
|
|
go = Annex.addCleanupAction (RemoteCleanup $ uuid r) cleanup
|
|
cleanup
|
|
| not $ Git.repoIsUrl repo = onLocalFast st $
|
|
doQuietSideAction $
|
|
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
|
| otherwise = noop
|
|
|
|
wantHardLink :: Annex Bool
|
|
wantHardLink = (annexHardLink <$> Annex.getGitConfig)
|
|
-- Not unlocked files that are hard linked in the work tree,
|
|
-- because they can be modified at any time.
|
|
<&&> (not <$> annexThin <$> Annex.getGitConfig)
|
|
|
|
type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
|
|
|
|
-- If either the remote or local repository wants to use hard links,
|
|
-- the copier will do so (falling back to copying if a hard link cannot be
|
|
-- made).
|
|
--
|
|
-- When a hard link is created, returns Verified; the repo being linked
|
|
-- from is implicitly trusted, so no expensive verification needs to be
|
|
-- done. Also returns Verified if the key's content is verified while
|
|
-- copying it.
|
|
mkFileCopier :: Bool -> State -> Annex FileCopier
|
|
mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
|
|
localwanthardlink <- wantHardLink
|
|
let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True
|
|
if remotewanthardlink || localwanthardlink
|
|
then return $ \src dest k p check verifyconfig ->
|
|
ifM (liftIO (catchBoolIO (linker src dest)))
|
|
( ifM check
|
|
( return (True, Verified)
|
|
, do
|
|
verificationOfContentFailed (toRawFilePath dest)
|
|
return (False, UnVerified)
|
|
)
|
|
, copier src dest k p check verifyconfig
|
|
)
|
|
else return copier
|
|
where
|
|
copier src dest k p check verifyconfig = do
|
|
iv <- startVerifyKeyContentIncrementally verifyconfig k
|
|
liftIO (fileCopier copycowtried src dest p iv) >>= \case
|
|
Copied -> ifM check
|
|
( finishVerifyKeyContentIncrementally iv
|
|
, do
|
|
verificationOfContentFailed (toRawFilePath dest)
|
|
return (False, UnVerified)
|
|
)
|
|
CopiedCoW -> unVerified check
|
|
|
|
{- Normally the UUID of a local repository is checked at startup,
|
|
- but annex-checkuuid config can prevent that. To avoid getting
|
|
- confused, a deferred check is done just before the repository
|
|
- is used.
|
|
- This returns False when the repository UUID is not as expected. -}
|
|
type DeferredUUIDCheck = Annex Bool
|
|
|
|
data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex
|
|
|
|
getRepoFromState :: State -> Annex Git.Repo
|
|
getRepoFromState (State _ _ _ a _) = fst <$> a
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
{- The config of the remote git repository, cached for speed. -}
|
|
getGitConfigFromState :: State -> Annex GitConfig
|
|
getGitConfigFromState (State _ _ _ a _) = snd <$> a
|
|
#endif
|
|
|
|
mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State
|
|
mkState r u gc = do
|
|
pool <- Ssh.mkP2PShellConnectionPool
|
|
copycowtried <- liftIO newCopyCoWTried
|
|
lra <- mkLocalRemoteAnnex r
|
|
(duc, getrepo) <- go
|
|
return $ State pool duc copycowtried getrepo lra
|
|
where
|
|
go
|
|
| remoteAnnexCheckUUID gc = return
|
|
(return True, return (r, extractGitConfig FromGitConfig r))
|
|
| otherwise = do
|
|
rv <- liftIO newEmptyMVar
|
|
let getrepo = ifM (liftIO $ isEmptyMVar rv)
|
|
( do
|
|
r' <- tryGitConfigRead False r True
|
|
let t = (r', extractGitConfig FromGitConfig r')
|
|
void $ liftIO $ tryPutMVar rv t
|
|
return t
|
|
, liftIO $ readMVar rv
|
|
)
|
|
|
|
cv <- liftIO newEmptyMVar
|
|
let duc = ifM (liftIO $ isEmptyMVar cv)
|
|
( do
|
|
r' <- fst <$> getrepo
|
|
u' <- getRepoUUID r'
|
|
let ok = u' == u
|
|
void $ liftIO $ tryPutMVar cv ok
|
|
unless ok $
|
|
warning $ UnquotedString $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."
|
|
return ok
|
|
, liftIO $ readMVar cv
|
|
)
|
|
|
|
return (duc, getrepo)
|
|
|
|
listProxied :: M.Map UUID (S.Set Proxy) -> [Git.Repo] -> Annex [Git.Repo]
|
|
listProxied proxies rs = concat <$> mapM go rs
|
|
where
|
|
go r = do
|
|
g <- Annex.gitRepo
|
|
u <- getRepoUUID r
|
|
gc <- Annex.getRemoteGitConfig r
|
|
let cu = fromMaybe u $ remoteAnnexConfigUUID gc
|
|
if not (canproxy gc r) || cu == NoUUID
|
|
then pure []
|
|
else case M.lookup cu proxies of
|
|
Nothing -> pure []
|
|
Just proxied -> catMaybes
|
|
<$> mapM (mkproxied g r gc proxied)
|
|
(S.toList proxied)
|
|
|
|
proxiedremotename r p = do
|
|
n <- Git.remoteName r
|
|
pure $ n ++ "-" ++ proxyRemoteName p
|
|
|
|
mkproxied g r gc proxied p = case proxiedremotename r p of
|
|
Nothing -> pure Nothing
|
|
Just proxyname -> mkproxied' g r gc proxied p proxyname
|
|
|
|
-- The proxied remote is constructed by renaming the proxy remote,
|
|
-- changing its uuid, and setting the proxied remote's inherited
|
|
-- configs and uuid in Annex state.
|
|
mkproxied' g r gc proxied p proxyname
|
|
| any isconfig (M.keys (Git.config g)) = pure Nothing
|
|
| otherwise = do
|
|
clusters <- getClustersWith id
|
|
-- Not using addGitConfigOverride for inherited
|
|
-- configs, because child git processes do not
|
|
-- need them to be provided with -c.
|
|
Annex.adjustGitRepo (pure . annexconfigadjuster clusters)
|
|
return $ Just $ renamedr
|
|
where
|
|
renamedr =
|
|
let c = adduuid configkeyUUID $
|
|
Git.fullconfig r
|
|
in r
|
|
{ Git.remoteName = Just proxyname
|
|
, Git.config = M.map Prelude.head c
|
|
, Git.fullconfig = c
|
|
}
|
|
|
|
annexconfigadjuster clusters r' =
|
|
let c = adduuid (configRepoUUID renamedr) $
|
|
addurl $
|
|
addproxiedby $
|
|
adjustclusternode clusters $
|
|
inheritconfigs $ Git.fullconfig r'
|
|
in r'
|
|
{ Git.config = M.map Prelude.head c
|
|
, Git.fullconfig = c
|
|
}
|
|
|
|
adduuid ck = M.insert ck
|
|
[Git.ConfigValue $ fromUUID $ proxyRemoteUUID p]
|
|
|
|
addurl = M.insert (remoteConfig renamedr (remoteGitConfigKey UrlField))
|
|
[Git.ConfigValue $ encodeBS $ Git.repoLocation r]
|
|
|
|
addproxiedby = case remoteAnnexUUID gc of
|
|
Just u -> addremoteannexfield ProxiedByField
|
|
[Git.ConfigValue $ fromUUID u]
|
|
Nothing -> id
|
|
|
|
-- A node of a cluster that is being proxied along with
|
|
-- that cluster does not need to be synced with
|
|
-- by default, because syncing with the cluster will
|
|
-- effectively sync with all of its nodes.
|
|
--
|
|
-- Also, give it a slightly higher cost than the
|
|
-- cluster by default, to encourage using the cluster.
|
|
adjustclusternode clusters =
|
|
case M.lookup (ClusterNodeUUID (proxyRemoteUUID p)) (clusterNodeUUIDs clusters) of
|
|
Just cs
|
|
| any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) ->
|
|
addremoteannexfield SyncField
|
|
[Git.ConfigValue $ Git.Config.boolConfig' False]
|
|
. addremoteannexfield CostField
|
|
[Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1]
|
|
_ -> id
|
|
|
|
proxieduuids = S.map proxyRemoteUUID proxied
|
|
|
|
addremoteannexfield f = M.insert
|
|
(remoteAnnexConfig renamedr (remoteGitConfigKey f))
|
|
|
|
inheritconfigs c = foldl' inheritconfig c proxyInheritedFields
|
|
|
|
inheritconfig c k = case (M.lookup dest c, M.lookup src c) of
|
|
(Nothing, Just v) -> M.insert dest v c
|
|
_ -> c
|
|
where
|
|
src = remoteAnnexConfig r k
|
|
dest = remoteAnnexConfig renamedr k
|
|
|
|
-- When the git config has anything set for a remote,
|
|
-- avoid making a proxied remote with the same name.
|
|
-- It is possible to set git configs of proxies, but it
|
|
-- needs both the url and uuid config to be manually set.
|
|
isconfig (Git.ConfigKey configkey) =
|
|
proxyconfigprefix `B.isPrefixOf` configkey
|
|
where
|
|
Git.ConfigKey proxyconfigprefix = remoteConfig proxyname mempty
|
|
|
|
-- Git remotes that are gcrypt or git-lfs special remotes cannot
|
|
-- proxy. Local git remotes cannot proxy either because
|
|
-- git-annex-shell is not used to access a local git url.
|
|
-- Proxing is also yet supported for remotes using P2P
|
|
-- addresses.
|
|
canproxy gc r
|
|
| remoteAnnexGitLFS gc = False
|
|
| Git.GCrypt.isEncrypted r = False
|
|
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = False
|
|
| otherwise = isNothing (repoP2PAddress r)
|