bup is now supported as a special type of remote.
This commit is contained in:
parent
f3cf20d22a
commit
44c65f40b7
6 changed files with 144 additions and 3 deletions
133
Remote/Bup.hs
Normal file
133
Remote/Bup.hs
Normal 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
|
Loading…
Add table
Add a link
Reference in a new issue