summaryrefslogtreecommitdiff
path: root/Remote/Rsync.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-04-27 20:06:07 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-04-27 20:23:09 -0400
commite68f128a9bf46c8f4ebe51fcb3b6f63955cadd2e (patch)
tree2102052ed8289efa0e44b4f9269c423753d70983 /Remote/Rsync.hs
parent4381ac062fa7cec01476e84a7bd8e154efb8aacd (diff)
rsync special remote
Fully tested and working, including resuming and encryption. (Though not resuming when sending *with* encryption; gpg doesn't produce identical output each time.) Uses same layout as the directory special remote and the .git/annex/objects/ directory.
Diffstat (limited to 'Remote/Rsync.hs')
-rw-r--r--Remote/Rsync.hs193
1 files changed, 193 insertions, 0 deletions
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
new file mode 100644
index 000000000..0a62ff92f
--- /dev/null
+++ b/Remote/Rsync.hs
@@ -0,0 +1,193 @@
+{- A remote that is only accessible by rsync.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Rsync (remote) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import Control.Exception.Extensible (IOException)
+import qualified Data.Map as M
+import Control.Monad.State (liftIO, when)
+import System.FilePath
+import System.Directory
+import System.Posix.Files
+import System.Posix.Process
+
+import RemoteClass
+import Types
+import qualified GitRepo as Git
+import qualified Annex
+import UUID
+import Locations
+import Config
+import Content
+import Utility
+import Remote.Special
+import Remote.Encryptable
+import Crypto
+import Messages
+import RsyncFile
+
+type RsyncUrl = String
+
+data RsyncOpts = RsyncOpts {
+ rsyncUrl :: RsyncUrl,
+ rsyncOptions :: [CommandParam]
+}
+
+remote :: RemoteType Annex
+remote = RemoteType {
+ typename = "rsync",
+ enumerate = findSpecialRemotes "rsyncurl",
+ generate = gen,
+ setup = rsyncSetup
+}
+
+gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
+gen r u c = do
+ url <- getConfig r "rsyncurl" (error "missing rsyncurl")
+ opts <- getConfig r "rsync-options" ""
+ let o = RsyncOpts url $ map Param $ words opts
+ cst <- remoteCost r expensiveRemoteCost
+ return $ encryptableRemote c
+ (storeEncrypted o)
+ (retrieveEncrypted o)
+ Remote {
+ uuid = u,
+ cost = cst,
+ name = Git.repoDescribe r,
+ storeKey = store o,
+ retrieveKeyFile = retrieve o,
+ removeKey = remove o,
+ hasKey = checkPresent r o,
+ hasKeyCheap = True,
+ config = Nothing
+ }
+
+rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
+rsyncSetup u c = do
+ -- verify configuration is sane
+ let url = case M.lookup "rsyncurl" c of
+ Nothing -> error "Specify rsyncurl="
+ Just d -> d
+ c' <- encryptionSetup c
+
+ -- The rsyncurl is stored in git config, not only in this remote's
+ -- persistant state, so it can vary between hosts.
+ gitConfigSpecialRemote u c' "rsyncurl" url
+ return c'
+
+rsyncKey :: RsyncOpts -> Key -> String
+rsyncKey o k = rsyncUrl o </> hashDirMixed k </> f </> f
+ where
+ f = keyFile k
+
+store :: RsyncOpts -> Key -> Annex Bool
+store o k = do
+ g <- Annex.gitRepo
+ rsyncSend o k (gitAnnexLocation g k)
+
+storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
+ g <- Annex.gitRepo
+ let f = gitAnnexLocation g k
+ liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
+ rsyncSend o enck tmp
+
+retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
+retrieve o k f = rsyncRemote o
+ -- use inplace when retrieving to support resuming
+ [ Param "--inplace"
+ , Param $ rsyncKey o k
+ , Param f
+ ]
+
+retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> FilePath -> Annex Bool
+retrieveEncrypted o (cipher, enck) f = withTmp enck $ \tmp -> do
+ res <- retrieve o enck tmp
+ if res
+ then liftIO $ catchBool $ do
+ withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
+ return True
+ else return res
+
+remove :: RsyncOpts -> Key -> Annex Bool
+remove o k = withRsyncScratchDir $ \tmp -> do
+ {- Send an empty directory to rysnc as the parent directory
+ - of the file to remove. -}
+ let dummy = tmp </> keyFile k
+ liftIO $ createDirectoryIfMissing True dummy
+ liftIO $ rsync $ rsyncOptions o ++
+ [ Params "--delete --recursive"
+ , partialParams
+ , Param $ addTrailingPathSeparator dummy
+ , Param $ parentDir $ rsyncKey o k
+ ]
+
+checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either IOException Bool)
+checkPresent r o k = do
+ showNote ("checking " ++ Git.repoDescribe r ++ "...")
+ -- note: Does not currently differnetiate between rsync failing
+ -- to connect, and the file not being present.
+ res <- liftIO $ boolSystem "sh" [Param "-c", Param cmd]
+ return $ Right res
+ where
+ cmd = "rsync --quiet " ++ testfile ++ " 2>/dev/null"
+ testfile = shellEscape $ rsyncKey o k
+
+{- Rsync params to enable resumes of sending files safely,
+ - ensure that files are only moved into place once complete
+ -}
+partialParams :: CommandParam
+partialParams = Params "--no-inplace --partial --partial-dir=.rsync-partial"
+
+{- Runs an action in an empty scratch directory that can be used to build
+ - up trees for rsync. -}
+withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool
+withRsyncScratchDir a = do
+ g <- Annex.gitRepo
+ pid <- liftIO $ getProcessID
+ let tmp = gitAnnexTmpDir g </> "rsynctmp" </> show pid
+ nuke tmp
+ liftIO $ createDirectoryIfMissing True $ tmp
+ res <- a tmp
+ nuke tmp
+ return res
+ where
+ nuke d = liftIO $ do
+ e <- doesDirectoryExist d
+ when e $ liftIO $ removeDirectoryRecursive d
+
+rsyncRemote :: RsyncOpts -> [CommandParam] -> Annex Bool
+rsyncRemote o params = do
+ showProgress -- make way for progress bar
+ res <- liftIO $ rsync $ rsyncOptions o ++ defaultParams ++ params
+ if res
+ then return res
+ else do
+ showLongNote "rsync failed -- run git annex again to resume file transfer"
+ return res
+ where
+ defaultParams = [Params "--progress"]
+
+{- To send a single key is slightly tricky; need to build up a temporary
+ directory structure to pass to rsync so it can create the hash
+ directories. -}
+rsyncSend :: RsyncOpts -> Key -> FilePath -> Annex Bool
+rsyncSend o k src = withRsyncScratchDir $ \tmp -> do
+ let dest = tmp </> hashDirMixed k </> f </> f
+ liftIO $ createDirectoryIfMissing True $ parentDir $ dest
+ liftIO $ createLink src dest
+ res <- rsyncRemote o
+ [ Param "--recursive"
+ , partialParams
+ -- tmp/ to send contents of tmp dir
+ , Param $ addTrailingPathSeparator tmp
+ , Param $ rsyncUrl o
+ ]
+ return res
+ where
+ f = keyFile k