summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-09-24 13:37:41 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-09-24 13:37:41 -0400
commita7f9ddb8de7c1e0357046d3dc9efc644bd5fb730 (patch)
treec4577129c78f9e2d9e40da67cf8d191b7dfb6b25 /Remote
parent12a8f2555e1c6d3a8d6ef7d60382265fa5be70b0 (diff)
factor out more ssh stuff from git remote
This has the dual benefits of making Remote.Git shorter, and letting Remote.GCrypt use these utilities.
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Bup.hs7
-rw-r--r--Remote/Git.hs97
-rw-r--r--Remote/Helper/Messages.hs17
-rw-r--r--Remote/Helper/Ssh.hs99
4 files changed, 127 insertions, 93 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 16fe8c8c5..1acb35c82 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -22,9 +22,10 @@ import qualified Git.Construct
import qualified Git.Ref
import Config
import Config.Cost
-import Remote.Helper.Ssh
+import qualified Remote.Helper.Ssh as Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
+import Remote.Helper.Messages
import Crypto
import Utility.Hash
import Utility.UserInfo
@@ -185,7 +186,7 @@ rollback k bupr = go =<< liftIO (bup2GitRemote bupr)
checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
checkPresent r bupr k
| Git.repoIsUrl bupr = do
- showAction $ "checking " ++ Git.repoDescribe r
+ showChecking r
ok <- onBupRemote bupr boolSystem "git" params
return $ Right ok
| otherwise = liftIO $ catchMsgIO $
@@ -220,7 +221,7 @@ storeBupUUID u buprepo = do
onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
onBupRemote r a command params = do
- sshparams <- sshToRepo r [Param $
+ sshparams <- Ssh.toRepo r [Param $
"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
liftIO $ a "ssh" sshparams
where
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 2802db9ae..2761995b2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -14,8 +14,6 @@ module Remote.Git (
) where
import Common.Annex
-import Utility.Rsync
-import Remote.Helper.Ssh
import Annex.Ssh
import Types.Remote
import Types.GitConfig
@@ -45,6 +43,8 @@ import Utility.Metered
import Utility.CopyFile
#endif
import Remote.Helper.Git
+import Remote.Helper.Messages
+import qualified Remote.Helper.Ssh as Ssh
import qualified Remote.GCrypt
import Control.Concurrent
@@ -143,7 +143,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r
| haveconfig r = return r -- already read
| Git.repoIsSsh r = store $ do
- v <- onRemote r (pipedconfig, Left undefined) "configlist" [] []
+ v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] []
case v of
Right r'
| haveconfig r' -> return r'
@@ -241,28 +241,19 @@ inAnnex r key
| otherwise = checklocal
where
checkhttp headers = do
- showchecking
+ showChecking r
liftIO $ ifM (anyM (\u -> Url.check u headers (keySize key)) (keyUrls r key))
( return $ Right True
, return $ Left "not found"
)
- checkremote = do
- showchecking
- 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
+ checkremote = Ssh.inAnnex r key
+ checklocal = guardUsable r (cantCheck r) $ 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
- showchecking = showAction $ "checking " ++ Git.repoDescribe r
+ dispatch (Right Nothing) = cantCheck r
keyUrls :: Git.Repo -> Key -> [String]
keyUrls r key = map tourl locs
@@ -285,12 +276,8 @@ dropKey r 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
- ]
- []
+ | Git.repoIsHttp (repo r) = error "dropping from http remote not supported"
+ | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
@@ -298,7 +285,7 @@ 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
+ let params = Ssh.rsyncParams r
u <- getUUID
-- run copy from perspective of remote
liftIO $ onLocal (repo r) $ do
@@ -311,10 +298,10 @@ copyFromRemote' r key file dest
(rsyncOrCopyFile params object dest)
<&&> checksuccess
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder ->
- rsyncHelper (Just feeder)
- =<< rsyncParamsRemote r Download key dest file
+ Ssh.rsyncHelper (Just feeder)
+ =<< Ssh.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"
+ | otherwise = error "copying from non-ssh, non-http remote not supported"
where
{- Feed local rsync's progress info back to the remote,
- by forking a feeder thread that runs
@@ -339,7 +326,7 @@ copyFromRemote' r key file dest
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
- Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"
+ Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo"
[Param $ key2file key] fields
v <- liftIO $ (newEmptySV :: IO (MSampleVar Integer))
tid <- liftIO $ forkIO $ void $ tryIO $ do
@@ -385,7 +372,8 @@ copyToRemote r key file p
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
+ Ssh.rsyncHelper (Just p)
+ =<< Ssh.rsyncParamsRemote r Upload key object file
| otherwise = error "copying to non-ssh repo not supported"
where
copylocal Nothing = return False
@@ -394,7 +382,7 @@ copyToRemote r key file p
-- the remote's Annex, but it needs access to the current
-- Annex monad's state.
checksuccessio <- Annex.withCurrentState checksuccess
- let params = rsyncParams r
+ let params = Ssh.rsyncParams r
u <- getUUID
-- run copy from perspective of remote
liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
@@ -446,56 +434,9 @@ rsyncOrCopyFile rsyncparams src dest p =
watchfilesize sz
_ -> watchfilesize oldsz
#endif
- dorsync = rsyncHelper (Just p) $
+ dorsync = Ssh.rsyncHelper (Just p) $
rsyncparams ++ [File src, File dest]
-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
- )
-
-{- 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
@@ -506,7 +447,7 @@ commitOnCleanup r a = go `after` a
Annex.Branch.commit "update"
| otherwise = void $ do
Just (shellcmd, shellparams) <-
- git_annex_shell (repo r) "commit" [] []
+ Ssh.git_annex_shell (repo r) "commit" [] []
-- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
new file mode 100644
index 000000000..c4b1966dc
--- /dev/null
+++ b/Remote/Helper/Messages.hs
@@ -0,0 +1,17 @@
+{- git-annex remote messages
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Messages where
+
+import Common.Annex
+import qualified Git
+
+showChecking :: Git.Repo -> Annex ()
+showChecking r = showAction $ "checking " ++ Git.repoDescribe r
+
+cantCheck :: Git.Repo -> Either String Bool
+cantCheck r = Left $ "unable to check " ++ Git.repoDescribe r
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index f8e9353b7..c71572434 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -1,6 +1,6 @@
-{- git-annex remote access with ssh
+{- git-annex remote access with ssh and git-annex-shell
-
- - Copyright 2011,2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -12,19 +12,27 @@ import qualified Git
import qualified Git.Url
import Annex.UUID
import Annex.Ssh
-import Fields
+import Fields (Field, fieldName)
+import qualified Fields
import Types.GitConfig
+import Types.Key
+import Remote.Helper.Messages
+import Utility.Metered
+import Utility.Rsync
+import Config
+import Types.Remote
+import Logs.Transfer
{- Generates parameters to ssh to a repository's host and run a command.
- Caller is responsible for doing any neccessary shellEscaping of the
- passed command. -}
-sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
-sshToRepo repo sshcmd = do
+toRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+toRepo r sshcmd = do
g <- fromRepo id
- let c = extractRemoteGitConfig g (Git.repoDescribe repo)
+ let c = extractRemoteGitConfig g (Git.repoDescribe r)
let opts = map Param $ remoteAnnexSshOptions c
- let host = Git.Url.hostuser repo
- params <- sshCachingOptions (host, Git.Url.port repo) opts
+ let host = Git.Url.hostuser r
+ params <- sshCachingOptions (host, Git.Url.port r) opts
return $ params ++ Param host : sshcmd
{- Generates parameters to run a git-annex-shell command on a remote
@@ -33,17 +41,17 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] ->
git_annex_shell r command params fields
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts)
| Git.repoIsSsh r = do
- uuid <- getRepoUUID r
- sshparams <- sshToRepo r [Param $ sshcmd uuid ]
+ u <- getRepoUUID r
+ sshparams <- toRepo r [Param $ sshcmd u ]
return $ Just ("ssh", sshparams)
| otherwise = return Nothing
where
dir = Git.repoPath r
shellcmd = "git-annex-shell"
shellopts = Param command : File dir : params
- sshcmd uuid = unwords $
+ sshcmd u = unwords $
shellcmd : map shellEscape (toCommand shellopts) ++
- uuidcheck uuid ++
+ uuidcheck u ++
map shellEscape (toCommand fieldopts)
uuidcheck NoUUID = []
uuidcheck (UUID u) = ["--uuid", u]
@@ -71,3 +79,70 @@ onRemote r (with, errorval) command params fields = do
case s of
Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval
+
+{- Checks if a remote contains a key. -}
+inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
+inAnnex r k = do
+ showChecking r
+ onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
+ where
+ check c p = dispatch <$> safeSystem c p
+ dispatch ExitSuccess = Right True
+ dispatch (ExitFailure 1) = Right False
+ dispatch _ = cantCheck r
+
+{- Removes a key from a remote. -}
+dropKey :: Git.Repo -> Key -> Annex Bool
+dropKey r key = onRemote r (boolSystem, False) "dropkey"
+ [ Params "--quiet --force"
+ , Param $ key2file key
+ ]
+ []
+
+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
+ )
+
+{- 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)
+