bup is now supported as a special type of remote.

6 files changed, 144 insertions, 3 deletions

diff --git a/Remote.hs b/Remote.hs
index 26097da74..bb661c5a9 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -46,12 +46,14 @@ import Config
 
 import qualified Remote.Git
 import qualified Remote.S3
+import qualified Remote.Bup
 import qualified Remote.Directory
 
 remoteTypes :: [RemoteType Annex]
 remoteTypes =
 	[ Remote.Git.remote
 	, Remote.S3.remote
+	, Remote.Bup.remote
 	, Remote.Directory.remote
 	]
 
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
new file mode 100644
index 000000000..ef34e2c63
--- /dev/null
+++ b/Remote/Bup.hs
@@ -0,0 +1,133 @@
+{- Using bup as a remote.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Bup (remote) where
+
+import IO
+import Control.Exception.Extensible (IOException)
+import qualified Data.Map as M
+import Control.Monad (unless)
+import Control.Monad.State (liftIO)
+import System.Process
+import System.Exit
+
+import RemoteClass
+import Types
+import qualified GitRepo as Git
+import qualified Annex
+import UUID
+import Locations
+import LocationLog
+import Config
+import Utility
+import Messages
+import Remote.Special
+
+remote :: RemoteType Annex
+remote = RemoteType {
+	typename = "bup",
+	enumerate = findSpecialRemotes "bupremote",
+	generate = gen,
+	setup = bupSetup
+}
+
+gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex)
+gen r u c = do
+	cst <- remoteCost r expensiveRemoteCost
+	bupremote <- getConfig r "bupremote" (error "missing bupremote")
+	return $ this cst bupremote
+	where
+		this cst bupremote = Remote {
+			uuid = u,
+			cost = cst,
+			name = Git.repoDescribe r,
+ 			storeKey = store r bupremote,
+			retrieveKeyFile = retrieve bupremote,
+			removeKey = remove,
+			hasKey = checkPresent u,
+			hasKeyCheap = True,
+			config = c
+		}
+
+bupSetup :: UUID -> M.Map String String -> Annex (M.Map String String)
+bupSetup u c = do
+	-- verify configuration is sane
+	let bupremote = case M.lookup "remote" c of
+		Nothing -> error "Specify remote="
+		Just r -> r
+	case M.lookup "encryption" c of
+		Nothing -> error "Specify encryption=key or encryption=none"
+		Just "none" -> return ()
+		Just _ -> error "encryption keys not yet supported"
+
+	-- bup init will create the repository.
+	-- (If the repository already exists, bup init again appears safe.)
+	showNote "bup init"
+	ok <- bup "init" bupremote []
+	unless ok $ error "bup init failed"
+
+	-- The bup remote is stored in git config, as well as this remote's
+	-- persistant state, so it can vary between hosts.
+	gitConfigSpecialRemote u c "bupremote" bupremote
+
+	return $ M.delete "directory" c
+
+bupParams :: String -> String -> [CommandParam] -> [CommandParam]
+bupParams command bupremote params = 
+	(Param command) : [Param "-r", Param bupremote] ++ params
+
+bup :: String -> String -> [CommandParam] -> Annex Bool
+bup command bupremote params = do
+	showProgress -- make way for bup output
+	liftIO $ boolSystem "bup" $ bupParams command bupremote params
+
+store :: Git.Repo -> String -> Key -> Annex Bool
+store r bupremote k = do
+	g <- Annex.gitRepo
+	let src = gitAnnexLocation g k
+	o <- getConfig r "bup-split-options" ""
+	let os = map Param $ words o
+	bup "split" bupremote $ os ++ [Param "-n", Param (show k), File src]
+
+retrieve :: String -> Key -> FilePath -> Annex Bool
+retrieve bupremote k f = do
+	let params = bupParams "join" bupremote [Param $ show k]
+	ret <- liftIO $ try $ do
+		-- pipe bup's stdout directly to file
+		tofile <- openFile f WriteMode
+		p <- runProcess "bup" (toCommand params) 
+			Nothing Nothing Nothing (Just tofile) Nothing
+		r <- waitForProcess p
+		case r of
+			ExitSuccess -> return True
+			_ -> return False
+	case ret of
+		Right r -> return r
+		Left e -> return False
+
+remove :: Key -> Annex Bool
+remove _ = do
+	warning "content cannot be removed from bup remote"
+	return False
+
+{- Bup does not provide a way to tell if a given dataset is present
+ - in a bup repository. One way it to check if the git repository has
+ - a branch matching the name (as created by bup split -n).
+ -
+ - However, git-annex's ususal reasons for checking if a remote really
+ - has a key also don't really apply in the case of bup, since, short
+ - of deleting bup's git repository, data cannot be removed from it.
+ - 
+ - So, trust git-annex's location log; if it says a bup repository has
+ - content, assume it's right.
+ -}
+checkPresent :: UUID -> Key -> Annex (Either IOException Bool)
+checkPresent u k = do
+	g <- Annex.gitRepo
+	liftIO $ try $ do
+		uuids <- keyLocations g k
+		return $ u `elem` uuids
diff --git a/configure.hs b/configure.hs
index d340f937d..4ab305239 100644
--- a/configure.hs
+++ b/configure.hs
@@ -15,6 +15,7 @@ tests =
 	, TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null"
 	, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
 	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
+	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
 	, TestCase "unicode FilePath support" $ unicodeFilePath
 	] ++ shaTestCases [1, 256, 512, 224, 384]
 
diff --git a/debian/changelog b/debian/changelog
index 7f104be10..91c0c8f4b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,5 +1,6 @@
 git-annex (0.20110402) UNRELEASED; urgency=low
 
+  * bup is now supported as a special type of remote.
   * Use lowercase hash directories for locationlog files, to avoid
     some issues with git on OSX with the mixed-case directories.
     No migration is needed; the old mixed case hash directories are still
diff --git a/debian/control b/debian/control
index 37e622043..15155b9b4 100644
--- a/debian/control
+++ b/debian/control
@@ -11,7 +11,7 @@ Package: git-annex
 Architecture: any
 Section: utils
 Depends: ${misc:Depends}, ${shlibs:Depends}, git | git-core, uuid, openssh-client, rsync
-Suggests: graphviz
+Suggests: graphviz, bup
 Description: manage files with git, without checking their contents into git
  git-annex allows managing files with git, without checking the file
  contents into git. While that may seem paradoxical, it is useful when
diff --git a/doc/walkthrough/using_bup.mdwn b/doc/walkthrough/using_bup.mdwn
index 1a506c281..7e1562d12 100644
--- a/doc/walkthrough/using_bup.mdwn
+++ b/doc/walkthrough/using_bup.mdwn
@@ -6,13 +6,17 @@ git-annex, you can have git on both the frontend and the backend.
 Here's how to create a bup remote, and describe it.
 
 	# git annex initremote mybup type=bup encryption=none remote=example.com/big/mybup
-	initremote bup (init) ok
+	initremote bup (bup init)
+	Initialized empty Git repository in /big/mybup/
+	ok
 	# git annex describe mybup "my bup repository at example.com"
 	describe mybup ok
 
 Now the remote can be used like any other remote.
 
 	# git annex move my_cool_big_file --to mybup
-	move my_cool_big_file (to mybup...) ok
+	move my_cool_big_file (to mybup...)
+	Receiving index from server: 1100/1100, done.
+	ok
 
 See [[special_remotes/bup]] for details.