reorg
This commit is contained in:
parent
03bcb8d8b3
commit
08236e780f
2 changed files with 49 additions and 27 deletions
|
@ -66,31 +66,10 @@ copyKeyFile key file = do
|
|||
showLocations key
|
||||
return False
|
||||
trycopy full (r:rs) = do
|
||||
-- annexLocation needs the git config to have been
|
||||
-- read for a remote, so do that now,
|
||||
-- if it hasn't been already
|
||||
result <- Remotes.tryGitConfigRead r
|
||||
case (result) of
|
||||
Left err -> trycopy full rs
|
||||
Right r' -> do
|
||||
showNote $ "copying from " ++ (Git.repoDescribe r) ++ "..."
|
||||
liftIO $ copyFromRemote r' key file
|
||||
|
||||
{- Tries to copy a file from a remote. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> IO Bool
|
||||
copyFromRemote r key file = do
|
||||
if (not $ Git.repoIsUrl r)
|
||||
then getlocal
|
||||
else if (Git.repoIsSsh r)
|
||||
then getssh
|
||||
else error "copying from non-ssh repo not supported"
|
||||
where
|
||||
getlocal = boolSystem "cp" ["-a", location, file]
|
||||
getssh = do
|
||||
liftIO $ putStrLn "" -- make way for scp progress bar
|
||||
boolSystem "scp" [sshlocation, file]
|
||||
location = annexLocation r key
|
||||
sshlocation = (Git.urlHost r) ++ ":" ++ location
|
||||
copied <- Remotes.copyFromRemote r key file
|
||||
if (copied)
|
||||
then return True
|
||||
else trycopy full rs
|
||||
|
||||
{- Checks remotes to verify that enough copies of a key exist to allow
|
||||
- for a key to be safely removed (with no data loss), and fails with an
|
||||
|
|
47
Remotes.hs
47
Remotes.hs
|
@ -4,7 +4,9 @@ module Remotes (
|
|||
list,
|
||||
keyPossibilities,
|
||||
tryGitConfigRead,
|
||||
inAnnex
|
||||
inAnnex,
|
||||
commandLineRemote,
|
||||
copyFromRemote
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
|
@ -20,10 +22,11 @@ import Types
|
|||
import qualified GitRepo as Git
|
||||
import qualified Annex
|
||||
import qualified Backend
|
||||
import qualified Core
|
||||
import LocationLog
|
||||
import Locations
|
||||
import UUID
|
||||
import qualified Core
|
||||
import Utility
|
||||
|
||||
{- Human visible list of remotes. -}
|
||||
list :: [Git.Repo] -> String
|
||||
|
@ -134,6 +137,22 @@ repoNotIgnored r = do
|
|||
config g = Git.configGet g configkey ""
|
||||
configkey = "remote." ++ (Git.repoRemoteName r) ++ ".annex-ignore"
|
||||
|
||||
{- Returns the remote specified by --from or --to, may fail with error. -}
|
||||
commandLineRemote :: Annex Git.Repo
|
||||
commandLineRemote = do
|
||||
fromName <- Annex.flagGet "fromrepository"
|
||||
toName <- Annex.flagGet "torepository"
|
||||
let name = if (not $ null fromName) then fromName else toName
|
||||
if (null name)
|
||||
then error "no remote specified"
|
||||
else do
|
||||
g <- Annex.gitRepo
|
||||
let match = filter (\r -> name == Git.repoRemoteName r) $
|
||||
Git.remotes g
|
||||
if (null match)
|
||||
then error $ "there is no git remote named \"" ++ name ++ "\""
|
||||
else return $ match !! 0
|
||||
|
||||
{- The git configs for the git repo's remotes is not read on startup
|
||||
- because reading it may be expensive. This function tries to read the
|
||||
- config for a specified remote, and updates state. If successful, it
|
||||
|
@ -161,3 +180,27 @@ tryGitConfigRead r = do
|
|||
if ((Git.repoRemoteName old) == (Git.repoRemoteName new))
|
||||
then new:(exchange ls new)
|
||||
else old:(exchange ls new)
|
||||
|
||||
{- Tries to copy a file from a remote. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file = do
|
||||
-- annexLocation needs the git config to have been read for a remote,
|
||||
-- so do that now if it hasn't been already
|
||||
result <- tryGitConfigRead r
|
||||
case (result) of
|
||||
Left err -> return False
|
||||
Right r' -> copy r'
|
||||
where
|
||||
copy r = do
|
||||
Core.showNote $ "copying from " ++ (Git.repoDescribe r) ++ "..."
|
||||
if (not $ Git.repoIsUrl r)
|
||||
then getlocal
|
||||
else if (Git.repoIsSsh r)
|
||||
then getssh
|
||||
else error "copying from non-ssh repo not supported"
|
||||
getlocal = liftIO $ boolSystem "cp" ["-a", location, file]
|
||||
getssh = do
|
||||
liftIO $ putStrLn "" -- make way for scp progress bar
|
||||
liftIO $ boolSystem "scp" [sshlocation, file]
|
||||
location = annexLocation r key
|
||||
sshlocation = (Git.urlHost r) ++ ":" ++ location
|
||||
|
|
Loading…
Reference in a new issue