9e11699c76
Most remotes have meters in their implementations of retrieveKeyFile already. Simply hooking these up to the transfer log makes that information available. Easy peasy. This is particularly valuable information for encrypted remotes, which otherwise bypass the assistant's polling of temp files, and so don't have good progress bars yet. Still some work to do here (see progressbars.mdwn changes), but this is entirely an improvement from the lack of progress bars for encrypted downloads.
469 lines
16 KiB
Haskell
469 lines
16 KiB
Haskell
{- Standard git remotes.
|
|
-
|
|
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Remote.Git (
|
|
remote,
|
|
configRead,
|
|
repoAvail,
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import Control.Exception.Extensible
|
|
|
|
import Common.Annex
|
|
import Utility.CopyFile
|
|
import Utility.Rsync
|
|
import Remote.Helper.Ssh
|
|
import Types.Remote
|
|
import Types.GitConfig
|
|
import qualified Git
|
|
import qualified Git.Config
|
|
import qualified Git.Construct
|
|
import qualified Git.Command
|
|
import qualified Annex
|
|
import Logs.Presence
|
|
import Logs.Transfer
|
|
import Annex.UUID
|
|
import Annex.Exception
|
|
import qualified Annex.Content
|
|
import qualified Annex.BranchState
|
|
import qualified Annex.Branch
|
|
import qualified Utility.Url as Url
|
|
import Utility.TempFile
|
|
import Config
|
|
import Config.Cost
|
|
import Init
|
|
import Types.Key
|
|
import qualified Fields
|
|
import Logs.Location
|
|
import Utility.Metered
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.MSampleVar
|
|
import System.Process (std_in, std_err)
|
|
|
|
remote :: RemoteType
|
|
remote = RemoteType {
|
|
typename = "git",
|
|
enumerate = list,
|
|
generate = gen,
|
|
setup = error "not supported"
|
|
}
|
|
|
|
list :: Annex [Git.Repo]
|
|
list = do
|
|
c <- fromRepo Git.config
|
|
rs <- mapM (tweakurl c) =<< fromRepo Git.remotes
|
|
mapM configRead rs
|
|
where
|
|
annexurl n = "remote." ++ n ++ ".annexurl"
|
|
tweakurl c r = do
|
|
let n = fromJust $ Git.remoteName r
|
|
case M.lookup (annexurl n) c of
|
|
Nothing -> return r
|
|
Just url -> inRepo $ \g ->
|
|
Git.Construct.remoteNamed n $
|
|
Git.Construct.fromRemoteLocation url g
|
|
|
|
{- 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.
|
|
-
|
|
- Conversely, the config of an URL remote is only read when there is no
|
|
- cached UUID value. -}
|
|
configRead :: Git.Repo -> Annex Git.Repo
|
|
configRead r = do
|
|
g <- fromRepo id
|
|
let c = extractRemoteGitConfig g (Git.repoDescribe r)
|
|
u <- getRepoUUID r
|
|
case (repoCheap r, remoteAnnexIgnore c, u) of
|
|
(_, True, _) -> return r
|
|
(True, _, _) -> tryGitConfigRead r
|
|
(False, _, NoUUID) -> tryGitConfigRead r
|
|
_ -> return r
|
|
|
|
repoCheap :: Git.Repo -> Bool
|
|
repoCheap = not . Git.repoIsUrl
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
|
gen r u _ gc = go <$> remoteCost gc defcst
|
|
where
|
|
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
|
go cst = new
|
|
where
|
|
new = Remote
|
|
{ uuid = u
|
|
, cost = cst
|
|
, name = Git.repoDescribe r
|
|
, storeKey = copyToRemote new
|
|
, retrieveKeyFile = copyFromRemote new
|
|
, retrieveKeyFileCheap = copyFromRemoteCheap new
|
|
, removeKey = dropKey new
|
|
, hasKey = inAnnex r
|
|
, hasKeyCheap = repoCheap r
|
|
, whereisKey = Nothing
|
|
, config = M.empty
|
|
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
|
then Just $ Git.repoPath r
|
|
else Nothing
|
|
, repo = r
|
|
, gitconfig = gc
|
|
{ remoteGitConfig = Just $ extractGitConfig r }
|
|
, readonly = Git.repoIsHttp r
|
|
, globallyAvailable = not $ Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
|
, remotetype = remote
|
|
}
|
|
|
|
{- Checks relatively inexpensively if a repository is available for use. -}
|
|
repoAvail :: Git.Repo -> Annex Bool
|
|
repoAvail r
|
|
| Git.repoIsHttp r = return True
|
|
| Git.repoIsUrl r = return True
|
|
| Git.repoIsLocalUnknown r = return False
|
|
| otherwise = liftIO $ catchBoolIO $ onLocal r $ return True
|
|
|
|
{- Avoids performing an action on a local repository that's not usable.
|
|
- Does not check that the repository is still available on disk. -}
|
|
guardUsable :: Git.Repo -> a -> Annex a -> Annex a
|
|
guardUsable r onerr a
|
|
| Git.repoIsLocalUnknown r = return onerr
|
|
| otherwise = a
|
|
|
|
{- Tries to read the config for a specified remote, updates state, and
|
|
- returns the updated repo. -}
|
|
tryGitConfigRead :: Git.Repo -> Annex Git.Repo
|
|
tryGitConfigRead r
|
|
| not $ M.null $ Git.config r = return r -- already read
|
|
| Git.repoIsSsh r = store $ do
|
|
v <- onRemote r (pipedsshconfig, Left undefined) "configlist" [] []
|
|
case (v, Git.remoteName r) of
|
|
(Right r', _) -> return r'
|
|
(Left _, Just n) -> do
|
|
{- Is this remote just not available, or does
|
|
- it not have git-annex-shell?
|
|
- Find out by trying to fetch from the remote. -}
|
|
whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do
|
|
let k = "remote." ++ n ++ ".annex-ignore"
|
|
warning $ "Remote " ++ n ++ " does not have git-annex installed; setting " ++ k
|
|
inRepo $ Git.Command.run [Param "config", Param k, Param "true"]
|
|
return r
|
|
_ -> return r
|
|
| Git.repoIsHttp r = do
|
|
headers <- getHttpHeaders
|
|
store $ safely $ geturlconfig headers
|
|
| Git.repoIsUrl r = return r
|
|
| otherwise = store $ safely $ onLocal r $ do
|
|
ensureInitialized
|
|
Annex.getState Annex.repo
|
|
where
|
|
-- Reading config can fail due to IO error or
|
|
-- for other reasons; catch all possible exceptions.
|
|
safely a = either (const $ return r) return
|
|
=<< liftIO (try a :: IO (Either SomeException Git.Repo))
|
|
|
|
pipedconfig cmd params =
|
|
withHandle StdoutHandle createProcessSuccess p $ \h -> do
|
|
fileEncoding h
|
|
val <- hGetContentsStrict h
|
|
r' <- Git.Config.store val r
|
|
when (getUncachedUUID r' == NoUUID && not (null val)) $ do
|
|
warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
|
warningIO $ "Instead, got: " ++ show val
|
|
warningIO $ "This is unexpected; please check the network transport!"
|
|
return r'
|
|
where
|
|
p = proc cmd $ toCommand params
|
|
|
|
pipedsshconfig cmd params =
|
|
liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo))
|
|
|
|
geturlconfig headers = do
|
|
s <- Url.get (Git.repoLocation r ++ "/config") headers
|
|
withTempFile "git-annex.tmp" $ \tmpfile h -> do
|
|
hPutStr h s
|
|
hClose h
|
|
safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
|
|
|
|
store = observe $ \r' -> do
|
|
g <- gitRepo
|
|
let l = Git.remotes g
|
|
let g' = g { Git.remotes = exchange l r' }
|
|
Annex.changeState $ \s -> s { Annex.repo = g' }
|
|
|
|
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 inAnnex.
|
|
- If the remote cannot be accessed, or if it cannot determine
|
|
- whether it has the content, returns a Left error message.
|
|
-}
|
|
inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
|
|
inAnnex r key
|
|
| Git.repoIsHttp r = checkhttp =<< getHttpHeaders
|
|
| Git.repoIsUrl r = checkremote
|
|
| otherwise = checklocal
|
|
where
|
|
checkhttp headers = liftIO $ go undefined $ keyUrls r key
|
|
where
|
|
go e [] = return $ Left e
|
|
go _ (u:us) = do
|
|
res <- catchMsgIO $
|
|
Url.check u headers (keySize key)
|
|
case res of
|
|
Left e -> go e us
|
|
v -> return v
|
|
checkremote = do
|
|
showAction $ "checking " ++ Git.repoDescribe r
|
|
onRemote r (check, unknown) "inannex" [Param (key2file key)] []
|
|
where
|
|
check c p = dispatch <$> safeSystem c p
|
|
dispatch ExitSuccess = Right True
|
|
dispatch (ExitFailure 1) = Right False
|
|
dispatch _ = unknown
|
|
checklocal = guardUsable r unknown $ dispatch <$> check
|
|
where
|
|
check = liftIO $ catchMsgIO $ onLocal r $
|
|
Annex.Content.inAnnexSafe key
|
|
dispatch (Left e) = Left e
|
|
dispatch (Right (Just b)) = Right b
|
|
dispatch (Right Nothing) = unknown
|
|
unknown = Left $ "unable to check " ++ Git.repoDescribe r
|
|
|
|
{- Runs an action on a local repository inexpensively, by making an annex
|
|
- monad using that repository. -}
|
|
onLocal :: Git.Repo -> Annex a -> IO a
|
|
onLocal r a = do
|
|
s <- Annex.new r
|
|
Annex.eval s $ do
|
|
-- No need to update the branch; its data is not used
|
|
-- for anything onLocal is used to do.
|
|
Annex.BranchState.disableUpdate
|
|
a
|
|
|
|
keyUrls :: Git.Repo -> Key -> [String]
|
|
keyUrls r key = map tourl (annexLocations key)
|
|
where
|
|
tourl l = Git.repoLocation r ++ "/" ++ l
|
|
|
|
dropKey :: Remote -> Key -> Annex Bool
|
|
dropKey r key
|
|
| not $ Git.repoIsUrl (repo r) =
|
|
guardUsable (repo r) False $ commitOnCleanup r $ liftIO $ onLocal (repo r) $ do
|
|
ensureInitialized
|
|
whenM (Annex.Content.inAnnex key) $ do
|
|
Annex.Content.lockContent key $
|
|
Annex.Content.removeAnnex key
|
|
logStatus key InfoMissing
|
|
Annex.Content.saveState True
|
|
return True
|
|
| Git.repoIsHttp (repo r) = error "dropping from http repo not supported"
|
|
| otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey"
|
|
[ Params "--quiet --force"
|
|
, Param $ key2file key
|
|
]
|
|
[]
|
|
|
|
{- Tries to copy a key's content from a remote's annex to a file. -}
|
|
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
|
copyFromRemote r key file dest _p = copyFromRemote' r key file dest
|
|
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
|
copyFromRemote' r key file dest
|
|
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
|
|
let params = rsyncParams r
|
|
u <- getUUID
|
|
-- run copy from perspective of remote
|
|
liftIO $ onLocal (repo r) $ do
|
|
ensureInitialized
|
|
v <- Annex.Content.prepSendAnnex key
|
|
case v of
|
|
Nothing -> return False
|
|
Just (object, checksuccess) ->
|
|
upload u key file noRetry
|
|
(rsyncOrCopyFile params object dest)
|
|
<&&> checksuccess
|
|
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder ->
|
|
rsyncHelper (Just feeder)
|
|
=<< rsyncParamsRemote r Download key dest file
|
|
| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest
|
|
| otherwise = error "copying from non-ssh, non-http repo not supported"
|
|
where
|
|
{- 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.
|
|
-
|
|
- 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 = do
|
|
u <- getUUID
|
|
let fields = (Fields.remoteUUID, fromUUID u)
|
|
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
|
|
Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"
|
|
[Param $ key2file key] fields
|
|
v <- liftIO $ (newEmptySV :: IO (MSampleVar Integer))
|
|
tid <- liftIO $ forkIO $ void $ tryIO $ do
|
|
bytes <- readSV v
|
|
p <- createProcess $
|
|
(proc cmd (toCommand params))
|
|
{ std_in = CreatePipe
|
|
, std_err = CreatePipe
|
|
}
|
|
hClose $ stderrHandle p
|
|
let h = stdinHandle p
|
|
let send b = do
|
|
hPutStrLn h $ show b
|
|
hFlush h
|
|
send bytes
|
|
forever $
|
|
send =<< readSV v
|
|
let feeder = writeSV v . fromBytesProcessed
|
|
bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
|
|
|
|
copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
|
|
copyFromRemoteCheap r key file
|
|
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
|
|
loc <- liftIO $ gitAnnexLocation key (repo r) $
|
|
fromJust $ remoteGitConfig $ gitconfig r
|
|
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
|
|
| Git.repoIsSsh (repo r) =
|
|
ifM (Annex.Content.preseedTmp key file)
|
|
( copyFromRemote' r key Nothing file
|
|
, return False
|
|
)
|
|
| otherwise = return False
|
|
|
|
{- Tries to copy a key's content to a remote's annex. -}
|
|
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
|
copyToRemote r key file p
|
|
| not $ Git.repoIsUrl (repo r) =
|
|
guardUsable (repo r) False $ commitOnCleanup r $
|
|
copylocal =<< Annex.Content.prepSendAnnex key
|
|
| Git.repoIsSsh (repo r) = commitOnCleanup r $
|
|
Annex.Content.sendAnnex key noop $ \object ->
|
|
rsyncHelper (Just p) =<< rsyncParamsRemote r Upload key object file
|
|
| otherwise = error "copying to non-ssh repo not supported"
|
|
where
|
|
copylocal Nothing = return False
|
|
copylocal (Just (object, checksuccess)) = do
|
|
-- The checksuccess action is going to be run in
|
|
-- the remote's Annex, but it needs access to the current
|
|
-- Annex monad's state.
|
|
checksuccessio <- Annex.withCurrentState checksuccess
|
|
let params = rsyncParams r
|
|
u <- getUUID
|
|
-- run copy from perspective of remote
|
|
liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
|
|
( return True
|
|
, do
|
|
ensureInitialized
|
|
download u key file noRetry $ const $
|
|
Annex.Content.saveState True `after`
|
|
Annex.Content.getViaTmpChecked (liftIO checksuccessio) key
|
|
(\d -> rsyncOrCopyFile params object d p)
|
|
)
|
|
|
|
rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
|
|
rsyncHelper callback params = do
|
|
showOutput -- make way for progress bar
|
|
ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
|
|
( return True
|
|
, do
|
|
showLongNote "rsync failed -- run git annex again to resume file transfer"
|
|
return False
|
|
)
|
|
|
|
{- Copys a file with rsync unless both locations are on the same
|
|
- filesystem. Then cp could be faster. -}
|
|
rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool
|
|
rsyncOrCopyFile rsyncparams src dest p =
|
|
ifM (sameDeviceIds src dest) (docopy, dorsync)
|
|
where
|
|
sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
|
|
getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
|
|
dorsync = rsyncHelper (Just p) $
|
|
rsyncparams ++ [Param src, Param dest]
|
|
docopy = liftIO $ bracket
|
|
(forkIO $ watchfilesize zeroBytesProcessed)
|
|
(void . tryIO . killThread)
|
|
(const $ copyFileExternal src dest)
|
|
watchfilesize oldsz = do
|
|
threadDelay 500000 -- 0.5 seconds
|
|
v <- catchMaybeIO $
|
|
toBytesProcessed . fileSize
|
|
<$> getFileStatus dest
|
|
case v of
|
|
Just sz
|
|
| sz /= oldsz -> do
|
|
p sz
|
|
watchfilesize sz
|
|
_ -> watchfilesize oldsz
|
|
|
|
{- Generates rsync parameters that ssh to the remote and asks it
|
|
- to either receive or send the key's content. -}
|
|
rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
|
|
rsyncParamsRemote r direction key file afile = do
|
|
u <- getUUID
|
|
direct <- isDirect
|
|
let fields = (Fields.remoteUUID, fromUUID u)
|
|
: (Fields.direct, if direct then "1" else "")
|
|
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
|
|
Just (shellcmd, shellparams) <- git_annex_shell (repo r)
|
|
(if direction == Download then "sendkey" else "recvkey")
|
|
[ Param $ key2file key ]
|
|
fields
|
|
-- Convert the ssh command into rsync command line.
|
|
let eparam = rsyncShell (Param shellcmd:shellparams)
|
|
let o = rsyncParams r
|
|
if direction == Download
|
|
then return $ o ++ rsyncopts eparam dummy (File file)
|
|
else return $ o ++ rsyncopts eparam (File file) dummy
|
|
where
|
|
rsyncopts ps source dest
|
|
| end ps == [dashdash] = ps ++ [source, dest]
|
|
| otherwise = ps ++ [dashdash, source, dest]
|
|
dashdash = Param "--"
|
|
{- The rsync shell parameter controls where rsync
|
|
- goes, so the source/dest parameter can be a dummy value,
|
|
- that just enables remote rsync mode.
|
|
- For maximum compatability with some patched rsyncs,
|
|
- the dummy value needs to still contain a hostname,
|
|
- even though this hostname will never be used. -}
|
|
dummy = Param "dummy:"
|
|
|
|
-- --inplace to resume partial files
|
|
rsyncParams :: Remote -> [CommandParam]
|
|
rsyncParams r = [Params "--progress --inplace"] ++
|
|
map Param (remoteAnnexRsyncOptions $ gitconfig r)
|
|
|
|
commitOnCleanup :: Remote -> Annex a -> Annex a
|
|
commitOnCleanup r a = go `after` a
|
|
where
|
|
go = Annex.addCleanup (Git.repoLocation $ repo r) cleanup
|
|
cleanup
|
|
| not $ Git.repoIsUrl (repo r) = liftIO $ onLocal (repo r) $
|
|
doQuietSideAction $
|
|
Annex.Branch.commit "update"
|
|
| otherwise = void $ do
|
|
Just (shellcmd, shellparams) <-
|
|
git_annex_shell (repo r) "commit" [] []
|
|
|
|
-- Throw away stderr, since the remote may not
|
|
-- have a new enough git-annex shell to
|
|
-- support committing.
|
|
liftIO $ catchMaybeIO $ do
|
|
withQuietOutput createProcessSuccess $
|
|
proc shellcmd $
|
|
toCommand shellparams
|