summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Git.hs2
-rw-r--r--Remote/Rsync.hs193
-rw-r--r--Remote/S3real.hs20
3 files changed, 202 insertions, 13 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs
index bab452a33..e6df6be46 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -158,7 +158,7 @@ rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool)
rsynchelper r sending key file = do
showProgress -- make way for progress bar
p <- rsyncParams r sending key file
- res <- liftIO $ boolSystem "rsync" p
+ res <- liftIO $ rsync p
if res
then return res
else do
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
diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index 07e33368e..2e198f79d 100644
--- a/Remote/S3real.hs
+++ b/Remote/S3real.hs
@@ -19,7 +19,6 @@ import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Environment
import System.Posix.Files
-import System.Directory
import RemoteClass
import Types
@@ -33,7 +32,7 @@ import Remote.Special
import Remote.Encryptable
import Crypto
import Key
-import Utility
+import Content
remote :: RemoteType Annex
remote = RemoteType {
@@ -108,18 +107,15 @@ store r k = s3Action r False $ \(conn, bucket) -> do
s3Bool res
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> do
- g <- Annex.gitRepo
- let f = gitAnnexLocation g k
+storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.)
- let tmp = gitAnnexTmpLocation g enck
- liftIO $ createDirectoryIfMissing True (parentDir tmp)
- liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
- res <- liftIO $ storeHelper (conn, bucket) r enck tmp
- tmp_exists <- liftIO $ doesFileExist tmp
- when tmp_exists $ liftIO $ removeFile tmp
- s3Bool res
+ withTmp enck $ \tmp -> do
+ g <- Annex.gitRepo
+ let f = gitAnnexLocation g k
+ liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
+ res <- liftIO $ storeHelper (conn, bucket) r enck tmp
+ s3Bool res
storeHelper :: (AWSConnection, String) -> Remote Annex -> Key -> FilePath -> IO (AWSResult ())
storeHelper (conn, bucket) r k file = do