diff options
| -rw-r--r-- | Command/Map.hs | 6 | ||||
| -rw-r--r-- | Remote/Bup.hs | 7 | ||||
| -rw-r--r-- | Remote/Git.hs | 97 | ||||
| -rw-r--r-- | Remote/Helper/Messages.hs | 17 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 99 |
5 files changed, 130 insertions, 96 deletions
diff --git a/Command/Map.hs b/Command/Map.hs index c88520b07..41beb4b92 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -20,7 +20,7 @@ import qualified Annex import Annex.UUID import Logs.UUID import Logs.Trust -import Remote.Helper.Ssh +import qualified Remote.Helper.Ssh as Ssh import qualified Utility.Dot as Dot -- a link from the first repository to the second (its remote) @@ -203,9 +203,9 @@ tryScan r where p = proc cmd $ toCommand params - configlist = onRemote r (pipedconfig, Nothing) "configlist" [] [] + configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] [] manualconfiglist = do - sshparams <- sshToRepo r [Param sshcmd] + sshparams <- Ssh.toRepo r [Param sshcmd] liftIO $ pipedconfig "ssh" sshparams where sshcmd = cddir ++ " && " ++ 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) + |