537f9d9a11
New error message: Remote foo not usable by git-annex; setting annex-ignore http://localhost/foo/config download failed: Configuration of annex.security.allowed-ip-addresses does not allow accessing address ::1 If git config parse fails, or the git config file is not available at the url, a better error message for that is also shown. This commit was sponsored by Mark Reidenbach on Patreon.
1042 lines
35 KiB
Haskell
1042 lines
35 KiB
Haskell
{- Standard git remotes.
|
|
-
|
|
- Copyright 2011-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Remote.Git (
|
|
remote,
|
|
configRead,
|
|
repoAvail,
|
|
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 Logs.Presence
|
|
import Annex.Transfer
|
|
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 Utility.Metered
|
|
import Utility.CopyFile
|
|
import Utility.Env
|
|
import Utility.FileMode
|
|
import Utility.Batch
|
|
import Utility.SimpleProtocol
|
|
import Utility.Touch
|
|
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 Types.Backend
|
|
import Backend
|
|
import Annex.Action
|
|
import Annex.Verify
|
|
import Messages.Progress
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
import qualified Utility.RawFilePath as R
|
|
#endif
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.MSampleVar
|
|
import qualified Data.Map as M
|
|
import qualified Data.ByteString as S
|
|
import Data.Time.Clock.POSIX
|
|
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
|
|
mapM (configRead autoinit) 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) g
|
|
|
|
{- Git remotes are normally set up using standard git command, not
|
|
- git-annex initremote and enableremote.
|
|
-
|
|
- For initremote, the git remote must already be set up, and have a uuid.
|
|
- Initremote simply remembers its location.
|
|
-
|
|
- 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 = fromMaybe (giveup "Specify location=url") $
|
|
Url.parseURIRelaxed . fromProposedAccepted
|
|
=<< M.lookup locationField c
|
|
rs <- Annex.getGitRemotes
|
|
u <- case filter (\r -> Git.location r == Git.Url location) rs of
|
|
[r] -> getRepoUUID r
|
|
[] -> giveup "could not find existing git remote with specified location"
|
|
_ -> giveup "found multiple git remotes with specified location"
|
|
if isNothing mu || mu == Just u
|
|
then return (c, u)
|
|
else error "git remote did 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
|
|
inRepo $ Git.Command.run
|
|
[ Param "remote"
|
|
, Param "add"
|
|
, Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c)
|
|
, Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c)
|
|
]
|
|
return (c, u)
|
|
enableRemote Nothing _ = error "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 defcst
|
|
Just addr -> Remote.P2P.chainGen addr r u rc gc rs
|
|
where
|
|
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
|
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 = availabilityCalc r
|
|
, remotetype = remote
|
|
, mkUnavailable = unavailable r u rc gc rs
|
|
, getInfo = gitRepoInfo new
|
|
, claimUrl = Nothing
|
|
, checkUrl = Nothing
|
|
, remoteStateHandle = rs
|
|
}
|
|
|
|
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
|
|
|
|
{- Checks relatively inexpensively if a repository is available for use. -}
|
|
repoAvail :: Git.Repo -> Annex Bool
|
|
repoAvail r
|
|
| Git.repoIsHttp r = return True
|
|
| Git.GCrypt.isEncrypted r = do
|
|
g <- gitRepo
|
|
liftIO $ do
|
|
er <- Git.GCrypt.encryptedRemote g r
|
|
if Git.repoIsLocal er || Git.repoIsLocalUnknown er
|
|
then catchBoolIO $
|
|
void (Git.Config.read er) >> return True
|
|
else return True
|
|
| Git.repoIsUrl r = return True
|
|
| Git.repoIsLocalUnknown r = return False
|
|
| otherwise = liftIO $ isJust <$> catchMaybeIO (Git.Config.read r)
|
|
|
|
{- 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 $
|
|
liftIO 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' || S.null val || not mustincludeuuuid) $ do
|
|
warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
|
warning $ "Instead, got: " ++ show val
|
|
warning $ "This is unexpected; please check the network transport!"
|
|
return $ Right r'
|
|
Left l -> do
|
|
warning $ "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 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 (Git.Config.isBare r') $
|
|
setremote setRemoteBare False
|
|
return r'
|
|
Left err -> do
|
|
set_ignore "not usable by git-annex" False
|
|
warning $ 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 $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"
|
|
when longmessage $
|
|
warning $ "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 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 $ \e ->
|
|
warning $ "remote " ++ Git.repoDescribe r ++
|
|
":" ++ show e
|
|
Annex.getState Annex.repo
|
|
s <- Annex.new r
|
|
Annex.eval s $ check `finally` stopCoProcesses
|
|
|
|
failedreadlocalconfig = do
|
|
unless hasuuid $ case Git.remoteName r of
|
|
Nothing -> noop
|
|
Just n -> do
|
|
warning $ "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
|
|
showChecking repo
|
|
gc <- Annex.getGitConfig
|
|
ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key))
|
|
( return True
|
|
, giveup "not found"
|
|
)
|
|
checkremote =
|
|
let fallback = Ssh.inAnnex repo key
|
|
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) 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 = reverse (annexLocations gc key)
|
|
| otherwise = annexLocations 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
|
|
Annex.Content.saveState True
|
|
, giveup "remote does not have expected annex.uuid value"
|
|
)
|
|
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
|
|
| otherwise = commitOnCleanup repo r st $ do
|
|
let fallback = Ssh.dropKey' repo key
|
|
P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) 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 $
|
|
liftIO . inorigrepo . callback
|
|
, failedlock
|
|
)
|
|
| Git.repoIsSsh repo = do
|
|
showLocking r
|
|
let withconn = Ssh.withP2PSshConnection r connpool fallback
|
|
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
|
|
| otherwise = failedlock
|
|
where
|
|
fallback = withNullHandle $ \nullh -> do
|
|
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
|
|
repo "lockcontent"
|
|
[Param $ serializeKey key] []
|
|
let p = (proc cmd (toCommand params))
|
|
{ std_in = CreatePipe
|
|
, std_out = CreatePipe
|
|
, std_err = UseHandle nullh
|
|
}
|
|
bracketIO (createProcess p) cleanupProcess fallback'
|
|
|
|
fallback' (Just hin, Just hout, Nothing, p) = do
|
|
v <- liftIO $ tryIO $ getProtocolLine hout
|
|
let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync
|
|
[ hPutStrLn hout ""
|
|
, hFlush hout
|
|
, hClose hin
|
|
, hClose hout
|
|
, void $ waitForProcess p
|
|
]
|
|
let checkexited = not . isJust <$> getProcessExitCode p
|
|
case v of
|
|
Left _exited -> do
|
|
showNote "lockcontent failed"
|
|
liftIO $ do
|
|
hClose hin
|
|
hClose hout
|
|
void $ waitForProcess p
|
|
failedlock
|
|
Right l
|
|
| l == Just Ssh.contentLockedMarker -> bracket_
|
|
noop
|
|
signaldone
|
|
(withVerifiedCopy LockedCopy r checkexited callback)
|
|
| otherwise -> do
|
|
showNote "lockcontent failed"
|
|
signaldone
|
|
failedlock
|
|
fallback' _ = error "internal"
|
|
|
|
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 -> Annex Verification
|
|
copyFromRemote = copyFromRemote' False
|
|
|
|
copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
|
|
copyFromRemote' forcersync r st key file dest meterupdate = do
|
|
repo <- getRepo r
|
|
copyFromRemote'' repo forcersync r st key file dest meterupdate
|
|
|
|
copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
|
|
copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest meterupdate
|
|
| Git.repoIsHttp repo = do
|
|
gc <- Annex.getGitConfig
|
|
ok <- Url.withUrlOptionsPromptingCreds $
|
|
Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest
|
|
unless ok $
|
|
giveup "failed to download content"
|
|
return UnVerified
|
|
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do
|
|
u <- getUUID
|
|
hardlink <- wantHardLink
|
|
-- run copy from perspective of remote
|
|
onLocalFast st $ Annex.Content.prepSendAnnex key >>= \case
|
|
Just (object, checksuccess) -> do
|
|
let verify = Annex.Content.RemoteVerify r
|
|
copier <- mkCopier hardlink st
|
|
(ok, v) <- runTransfer (Transfer Download u (fromKey id key))
|
|
file Nothing stdRetry $ \p ->
|
|
metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' ->
|
|
copier object dest key p' checksuccess verify
|
|
if ok
|
|
then return v
|
|
else giveup "failed to retrieve content from remote"
|
|
Nothing -> giveup "content is not present in remote"
|
|
| Git.repoIsSsh repo = if forcersync
|
|
then do
|
|
(ok, v) <- fallback meterupdate
|
|
if ok
|
|
then return v
|
|
else giveup "failed to retrieve content from remote"
|
|
else P2PHelper.retrieve
|
|
(Annex.Content.RemoteVerify r)
|
|
(\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p))
|
|
key file dest meterupdate
|
|
| otherwise = giveup "copying from non-ssh, non-http remote not supported"
|
|
where
|
|
fallback p = unVerified $ feedprogressback $ \p' -> do
|
|
oh <- mkOutputHandlerQuiet
|
|
Ssh.rsyncHelper oh (Just (combineMeterUpdate p' p))
|
|
=<< Ssh.rsyncParamsRemote False r Download key dest file
|
|
|
|
{- Feed local rsync's progress info back to the remote,
|
|
- by forking a feeder thread that runs
|
|
- git-annex-shell transferinfo at the same time
|
|
- git-annex-shell sendkey is running.
|
|
-
|
|
- To avoid extra password prompts, this is only done when ssh
|
|
- connection caching is supported.
|
|
- Note that it actually waits for rsync to indicate
|
|
- progress before starting transferinfo, in order
|
|
- to ensure ssh connection caching works and reuses
|
|
- the connection set up for the sendkey.
|
|
-
|
|
- Also note that older git-annex-shell does not support
|
|
- transferinfo, so stderr is dropped and failure ignored.
|
|
-}
|
|
feedprogressback a = ifM (isJust <$> sshCacheDir)
|
|
( feedprogressback' a
|
|
, a $ const noop
|
|
)
|
|
feedprogressback' a = do
|
|
u <- getUUID
|
|
let AssociatedFile afile = file
|
|
let fields = (Fields.remoteUUID, fromUUID u)
|
|
: maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile
|
|
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
|
|
repo "transferinfo"
|
|
[Param $ serializeKey key] fields
|
|
v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
|
|
pv <- liftIO $ newEmptyMVar
|
|
tid <- liftIO $ forkIO $ void $ tryIO $ do
|
|
bytes <- readSV v
|
|
p <- createProcess $
|
|
(proc cmd (toCommand params))
|
|
{ std_in = CreatePipe
|
|
, std_err = CreatePipe
|
|
}
|
|
putMVar pv p
|
|
hClose $ stderrHandle p
|
|
let h = stdinHandle p
|
|
let send b = do
|
|
hPrint h b
|
|
hFlush h
|
|
send bytes
|
|
forever $
|
|
send =<< readSV v
|
|
let feeder = \n -> do
|
|
meterupdate n
|
|
writeSV v (fromBytesProcessed n)
|
|
|
|
-- It can easily take 0.3 seconds to clean up after
|
|
-- the transferinfo, and all that's involved is shutting
|
|
-- down the process and associated thread cleanly. So,
|
|
-- do it in the background.
|
|
let cleanup = forkIO $ do
|
|
void $ tryIO $ killThread tid
|
|
void $ tryNonAsync $
|
|
maybe noop (void . waitForProcess . processHandle)
|
|
=<< tryTakeMVar pv
|
|
|
|
let forcestop = do
|
|
void $ tryIO $ killThread tid
|
|
void $ tryNonAsync $
|
|
maybe noop cleanupProcess
|
|
=<< tryTakeMVar pv
|
|
|
|
bracketIO noop (const cleanup) (const $ a feeder)
|
|
`onException` liftIO forcestop
|
|
|
|
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 -> MeterUpdate -> Annex ()
|
|
copyToRemote r st key file meterupdate = do
|
|
repo <- getRepo r
|
|
copyToRemote' repo r st key file meterupdate
|
|
|
|
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex ()
|
|
copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
|
|
| not $ Git.repoIsUrl repo = ifM duc
|
|
( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $
|
|
copylocal =<< Annex.Content.prepSendAnnex key
|
|
, giveup "remote does not have expected annex.uuid value"
|
|
)
|
|
| Git.repoIsSsh repo = commitOnCleanup repo r st $
|
|
P2PHelper.store
|
|
(Ssh.runProto r connpool (return False) . copyremotefallback)
|
|
key file meterupdate
|
|
|
|
| otherwise = giveup "copying to non-ssh repo not supported"
|
|
where
|
|
copylocal Nothing = giveup "content not available"
|
|
copylocal (Just (object, checksuccess)) = do
|
|
-- The checksuccess action is going to be run in
|
|
-- the remote's Annex, but it needs access to the local
|
|
-- Annex monad's state.
|
|
checksuccessio <- Annex.withCurrentState checksuccess
|
|
u <- getUUID
|
|
hardlink <- wantHardLink
|
|
-- run copy from perspective of remote
|
|
res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
|
|
( return True
|
|
, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do
|
|
let verify = Annex.Content.RemoteVerify r
|
|
copier <- mkCopier hardlink st
|
|
let rsp = RetrievalAllKeysSecure
|
|
res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest ->
|
|
metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' ->
|
|
copier object (fromRawFilePath dest) key p' (liftIO checksuccessio) verify
|
|
Annex.Content.saveState True
|
|
return res
|
|
)
|
|
unless res $
|
|
giveup "failed to send content to remote"
|
|
copyremotefallback p = either (const False) id
|
|
<$> tryNonAsync (copyremotefallback' p)
|
|
copyremotefallback' p = Annex.Content.sendAnnex key noop $ \object -> do
|
|
-- This is too broad really, but recvkey normally
|
|
-- verifies content anyway, so avoid complicating
|
|
-- it with a local sendAnnex check and rollback.
|
|
let unlocked = True
|
|
oh <- mkOutputHandlerQuiet
|
|
Ssh.rsyncHelper oh (Just p)
|
|
=<< Ssh.rsyncParamsRemote unlocked r Upload key object file
|
|
|
|
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
|
|
fsckOnRemote r params
|
|
| Git.repoIsUrl r = do
|
|
s <- Ssh.git_annex_shell NoConsumeStdin r "fsck" params []
|
|
return $ case s of
|
|
Nothing -> return False
|
|
Just (c, ps) -> batchCommand c ps
|
|
| 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
|
|
a `finally` stopCoProcesses
|
|
|
|
data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe Annex.AnnexState))
|
|
|
|
{- 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 Nothing)
|
|
|
|
{- Runs an action from the perspective of a local remote.
|
|
-
|
|
- The AnnexState is cached for speed and to avoid resource leaks.
|
|
- However, coprocesses are stopped 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
|
|
|
|
onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a
|
|
onLocal' (LocalRemoteAnnex repo v) a = liftIO (takeMVar v) >>= \case
|
|
Nothing -> do
|
|
st <- liftIO $ Annex.new repo
|
|
go (st, ensureInitialized >> a)
|
|
Just st -> go (st, a)
|
|
where
|
|
go (st, a') = do
|
|
curro <- Annex.getState Annex.output
|
|
let act = Annex.run (st { Annex.output = curro }) $
|
|
a' `finally` stopCoProcesses
|
|
(ret, st') <- liftIO $ act `onException` cache st
|
|
liftIO $ cache st'
|
|
return ret
|
|
cache st = putMVar v (Just st)
|
|
|
|
{- 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 = do
|
|
Just (shellcmd, shellparams) <-
|
|
Ssh.git_annex_shell NoConsumeStdin
|
|
repo "commit" [] []
|
|
|
|
-- Throw away stderr, since the remote may not
|
|
-- have a new enough git-annex shell to
|
|
-- support committing.
|
|
liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh ->
|
|
let p = (proc shellcmd (toCommand shellparams))
|
|
{ std_out = UseHandle nullh
|
|
, std_err = UseHandle nullh
|
|
}
|
|
in withCreateProcess p $ \_ _ _ ->
|
|
forceSuccessProcess p
|
|
|
|
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)
|
|
|
|
-- Copies from src to dest, updating a meter. If the copy finishes
|
|
-- successfully, calls a final check action, which must also succeed, or
|
|
-- returns false.
|
|
--
|
|
-- 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.
|
|
type Copier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
|
|
|
|
mkCopier :: Bool -> State -> Annex Copier
|
|
mkCopier remotewanthardlink st = do
|
|
let copier = fileCopier st
|
|
localwanthardlink <- wantHardLink
|
|
let linker = \src dest -> createLink src 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)
|
|
, return (False, UnVerified)
|
|
)
|
|
, copier src dest k p check verifyconfig
|
|
)
|
|
else return copier
|
|
|
|
{- 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.P2PSshConnectionPool 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.mkP2PSshConnectionPool
|
|
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 $ 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)
|
|
|
|
-- To avoid the overhead of trying copy-on-write every time, it's tried
|
|
-- once and if it fails, is not tried again.
|
|
newtype CopyCoWTried = CopyCoWTried (MVar Bool)
|
|
|
|
newCopyCoWTried :: IO CopyCoWTried
|
|
newCopyCoWTried = CopyCoWTried <$> newEmptyMVar
|
|
|
|
{- Copys a file. Uses copy-on-write if it is supported. Otherwise,
|
|
- copies the file itself. If the destination already exists,
|
|
- an interruped copy will resume where it left off.
|
|
-
|
|
- When copy-on-write is used, returns UnVerified, because the content of
|
|
- the file has not been verified to be correct. When the file has to be
|
|
- read to copy it, a hash is calulated at the same time.
|
|
-
|
|
- Note that, when the destination file already exists, it's read both
|
|
- to start calculating the hash, and also to verify that its content is
|
|
- the same as the start of the source file. It's possible that the
|
|
- destination file was created from some other source file,
|
|
- (eg when isStableKey is false), and doing this avoids getting a
|
|
- corrupted file in such cases.
|
|
-}
|
|
fileCopier :: State -> Copier
|
|
#ifdef mingw32_HOST_OS
|
|
fileCopier _st src dest k meterupdate check verifyconfig = docopy
|
|
where
|
|
#else
|
|
fileCopier st src dest k meterupdate check verifyconfig =
|
|
-- If multiple threads reach this at the same time, they
|
|
-- will both try CoW, which is acceptable.
|
|
ifM (liftIO $ isEmptyMVar copycowtried)
|
|
( do
|
|
ok <- docopycow
|
|
void $ liftIO $ tryPutMVar copycowtried ok
|
|
if ok
|
|
then unVerified check
|
|
else docopy
|
|
, ifM (liftIO $ readMVar copycowtried)
|
|
( do
|
|
ok <- docopycow
|
|
if ok
|
|
then unVerified check
|
|
else docopy
|
|
, docopy
|
|
)
|
|
)
|
|
where
|
|
copycowtried = case st of
|
|
State _ _ (CopyCoWTried v) _ _ -> v
|
|
docopycow = liftIO $ watchFileSize dest meterupdate $
|
|
copyCoW CopyTimeStamps src dest
|
|
#endif
|
|
|
|
dest' = toRawFilePath dest
|
|
|
|
docopy = do
|
|
iv <- startVerifyKeyContentIncrementally verifyconfig k
|
|
|
|
-- The file might have had the write bit removed,
|
|
-- so make sure we can write to it.
|
|
void $ liftIO $ tryIO $ allowWrite dest'
|
|
|
|
liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->
|
|
withBinaryFile src ReadMode $ \hsrc -> do
|
|
sofar <- compareexisting iv hdest hsrc zeroBytesProcessed
|
|
docopy' iv hdest hsrc sofar
|
|
|
|
-- Copy src mode and mtime.
|
|
mode <- liftIO $ fileMode <$> getFileStatus src
|
|
mtime <- liftIO $ utcTimeToPOSIXSeconds <$> getModificationTime src
|
|
liftIO $ setFileMode dest mode
|
|
liftIO $ touch dest' mtime False
|
|
|
|
ifM check
|
|
( case iv of
|
|
Just x -> ifM (liftIO $ finalizeIncremental x)
|
|
( return (True, Verified)
|
|
, return (False, UnVerified)
|
|
)
|
|
Nothing -> return (True, UnVerified)
|
|
, return (False, UnVerified)
|
|
)
|
|
|
|
docopy' iv hdest hsrc sofar = do
|
|
s <- S.hGet hsrc defaultChunkSize
|
|
if s == S.empty
|
|
then return ()
|
|
else do
|
|
let sofar' = addBytesProcessed sofar (S.length s)
|
|
S.hPut hdest s
|
|
maybe noop (flip updateIncremental s) iv
|
|
meterupdate sofar'
|
|
docopy' iv hdest hsrc sofar'
|
|
|
|
-- Leaves hdest and hsrc seeked to wherever the two diverge,
|
|
-- so typically hdest will be seeked to end, and hsrc to the same
|
|
-- position.
|
|
compareexisting iv hdest hsrc sofar = do
|
|
s <- S.hGet hdest defaultChunkSize
|
|
if s == S.empty
|
|
then return sofar
|
|
else do
|
|
s' <- getnoshort (S.length s) hsrc
|
|
if s == s'
|
|
then do
|
|
maybe noop (flip updateIncremental s) iv
|
|
let sofar' = addBytesProcessed sofar (S.length s)
|
|
meterupdate sofar'
|
|
compareexisting iv hdest hsrc sofar'
|
|
else do
|
|
seekbefore hdest s
|
|
seekbefore hsrc s'
|
|
return sofar
|
|
|
|
seekbefore h s = hSeek h RelativeSeek (fromIntegral (-1*S.length s))
|
|
|
|
-- Like hGet, but never returns less than the requested number of
|
|
-- bytes, unless it reaches EOF.
|
|
getnoshort n h = do
|
|
s <- S.hGet h n
|
|
if S.length s == n || S.empty == s
|
|
then return s
|
|
else do
|
|
s' <- getnoshort (n - S.length s) h
|
|
return (s <> s')
|