1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
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 _ -> 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
|
