Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: aa8b15d966
Fetching contributors…

Cannot retrieve contributors at this time

252 lines (222 sloc) 8.044 kb
{- 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 qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.Process
import Common.Annex
import Types.Remote
import Types.Key
import qualified Git
import qualified Git.Command
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Ref
import Config
import Remote.Helper.Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Digest.Pure.SHA
type BupRepo = String
remote :: RemoteType
remote = RemoteType {
typename = "bup",
enumerate = findSpecialRemotes "buprepo",
generate = gen,
setup = bupSetup
}
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do
buprepo <- getRemoteConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
bupr <- liftIO $ bup2GitRemote buprepo
(u', bupr') <- getBupUUID bupr u
return $ encryptableRemote c
(storeEncrypted r buprepo)
(retrieveEncrypted buprepo)
Remote
{ uuid = u'
, cost = cst
, name = Git.repoDescribe r
, storeKey = store r buprepo
, retrieveKeyFile = retrieve buprepo
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = remove
, hasKey = checkPresent r bupr'
, hasKeyCheap = bupLocal buprepo
, whereisKey = Nothing
, config = c
, repo = r
, localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo
else Nothing
, remotetype = remote
, readonly = False
}
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
bupSetup u c = do
-- verify configuration is sane
let buprepo = fromMaybe (error "Specify buprepo=") $
M.lookup "buprepo" c
c' <- encryptionSetup c
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)
showAction "bup init"
unlessM (bup "init" buprepo []) $ error "bup init failed"
storeBupUUID u buprepo
-- The buprepo is stored in git config, as well as this repo's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "buprepo" buprepo
return c'
bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
bupParams command buprepo params =
Param command : [Param "-r", Param buprepo] ++ params
bup :: String -> BupRepo -> [CommandParam] -> Annex Bool
bup command buprepo params = do
showOutput -- make way for bup output
liftIO $ boolSystem "bup" $ bupParams command buprepo params
pipeBup :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
pipeBup params inh outh = do
p <- runProcess "bup" (toCommand params)
Nothing Nothing inh outh Nothing
ok <- waitForProcess p
case ok of
ExitSuccess -> return True
_ -> return False
bupSplitParams :: Git.Repo -> BupRepo -> Key -> CommandParam -> Annex [CommandParam]
bupSplitParams r buprepo k src = do
o <- getRemoteConfig r "bup-split-options" ""
let os = map Param $ words o
showOutput -- make way for bup output
return $ bupParams "split" buprepo
(os ++ [Param "-n", Param (bupRef k), src])
store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r buprepo k _f _p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo k (File src)
liftIO $ boolSystem "bup" params
storeEncrypted :: Git.Repo -> BupRepo -> (CipherKey) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k _p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo enck (Param "-")
liftIO $ catchBoolIO $
withEncryptedHandle cipher (L.readFile src) $ \h ->
pipeBup params (Just h) Nothing
retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieve buprepo k _f d = do
let params = bupParams "join" buprepo [Param $ bupRef k]
liftIO $ catchBoolIO $ do
tofile <- openFile d WriteMode
pipeBup params Nothing (Just tofile)
retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted buprepo (cipher, enck) _ f = liftIO $ catchBoolIO $
withHandle StdoutHandle createProcessSuccess p $ \h -> do
withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
return True
where
params = bupParams "join" buprepo [Param $ bupRef enck]
p = proc "bup" $ toCommand params
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).
-}
checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
checkPresent r bupr k
| Git.repoIsUrl bupr = do
showAction $ "checking " ++ Git.repoDescribe r
ok <- onBupRemote bupr boolSystem "git" params
return $ Right ok
| otherwise = liftIO $ catchMsgIO $
boolSystem "git" $ Git.Command.gitCommandLine params bupr
where
params =
[ Params "show-ref --quiet --verify"
, Param $ "refs/heads/" ++ bupRef k]
{- Store UUID in the annex.uuid setting of the bup repository. -}
storeBupUUID :: UUID -> BupRepo -> Annex ()
storeBupUUID u buprepo = do
r <- liftIO $ bup2GitRemote buprepo
if Git.repoIsUrl r
then do
showAction "storing uuid"
unlessM (onBupRemote r boolSystem "git"
[Params $ "config annex.uuid " ++ v]) $
error "ssh failed"
else liftIO $ do
r' <- Git.Config.read r
let olduuid = Git.Config.get "annex.uuid" "" r'
when (olduuid == "") $
Git.Command.run "config"
[Param "annex.uuid", Param v] r'
where
v = fromUUID u
onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
onBupRemote r a command params = do
let dir = shellEscape (Git.repoPath r)
sshparams <- sshToRepo r [Param $
"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
liftIO $ a "ssh" sshparams
{- Allow for bup repositories on removable media by checking
- local bup repositories to see if they are available, and getting their
- uuid (which may be different from the stored uuid for the bup remote).
-
- If a bup repository is not available, returns NoUUID.
- This will cause checkPresent to indicate nothing from the bup remote
- is known to be present.
-
- Also, returns a version of the repo with config read, if it is local.
-}
getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
getBupUUID r u
| Git.repoIsUrl r = return (u, r)
| otherwise = liftIO $ do
ret <- tryIO $ Git.Config.read r
case ret of
Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r')
Left _ -> return (NoUUID, r)
{- Converts a bup remote path spec into a Git.Repo. There are some
- differences in path representation between git and bup. -}
bup2GitRemote :: BupRepo -> IO Git.Repo
bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup
h <- myHomeDir
Git.Construct.fromAbsPath $ h </> ".bup"
bup2GitRemote r
| bupLocal r =
if "/" `isPrefixOf` r
then Git.Construct.fromAbsPath r
else error "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where
bits = split ":" r
host = Prelude.head bits
dir = join ":" $ drop 1 bits
-- "host:~user/dir" is not supported specially by bup;
-- "host:dir" is relative to the home directory;
-- "host:" goes in ~/.bup
slash d
| null d = "/~/.bup"
| "/" `isPrefixOf` d = d
| otherwise = "/~/" ++ d
{- Converts a key into a git ref name, which bup-split -n will use to point
- to it. -}
bupRef :: Key -> String
bupRef k
| Git.Ref.legal True shown = shown
| otherwise = "git-annex-" ++ showDigest (sha256 (fromString shown))
where
shown = key2file k
bupLocal :: BupRepo -> Bool
bupLocal = notElem ':'
Jump to Line
Something went wrong with that request. Please try again.