bup is now supported as a special type of remote.

This commit is contained in:
Joey Hess 2011-04-08 16:44:43 -04:00
parent f3cf20d22a
commit 44c65f40b7
6 changed files with 144 additions and 3 deletions

133
Remote/Bup.hs Normal file
View file

@ -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