1{- Using bup as a remote. 2 - 3 - Copyright 2011-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE RankNTypes #-} 9 10module Remote.Bup (remote) where 11 12import qualified Data.Map as M 13import qualified Data.ByteString as S 14import qualified Data.ByteString.Lazy as L 15import Data.ByteString.Lazy.UTF8 (fromString) 16 17import Annex.Common 18import qualified Annex 19import Types.Remote 20import Types.Creds 21import Git.Types (ConfigValue(..), fromConfigKey) 22import qualified Git 23import qualified Git.Command 24import qualified Git.Config 25import qualified Git.Construct 26import qualified Git.Ref 27import Config 28import Config.Cost 29import qualified Remote.Helper.Ssh as Ssh 30import Annex.SpecialRemote.Config 31import Remote.Helper.Special 32import Remote.Helper.ExportImport 33import Utility.Hash 34import Utility.UserInfo 35import Annex.UUID 36import Annex.Ssh 37import Utility.Metered 38import Types.ProposedAccepted 39 40type BupRepo = String 41 42remote :: RemoteType 43remote = specialRemoteType $ RemoteType 44 { typename = "bup" 45 , enumerate = const (findSpecialRemotes "buprepo") 46 , generate = gen 47 , configParser = mkRemoteConfigParser 48 [ optionalStringParser buprepoField 49 (FieldDesc "(required) bup repository to use") 50 ] 51 , setup = bupSetup 52 , exportSupported = exportUnsupported 53 , importSupported = importUnsupported 54 , thirdPartyPopulated = False 55 } 56 57buprepoField :: RemoteConfigField 58buprepoField = Accepted "buprepo" 59 60gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) 61gen r u rc gc rs = do 62 c <- parsedRemoteConfig remote rc 63 bupr <- liftIO $ bup2GitRemote buprepo 64 cst <- remoteCost gc $ 65 if bupLocal buprepo 66 then nearlyCheapRemoteCost 67 else expensiveRemoteCost 68 (u', bupr') <- getBupUUID bupr u 69 70 let this = Remote 71 { uuid = u' 72 , cost = cst 73 , name = Git.repoDescribe r 74 , storeKey = storeKeyDummy 75 , retrieveKeyFile = retrieveKeyFileDummy 76 , retrieveKeyFileCheap = Nothing 77 -- Bup uses git, which cryptographically verifies content 78 -- (with SHA1, but sufficiently for this). 79 , retrievalSecurityPolicy = RetrievalAllKeysSecure 80 , removeKey = removeKeyDummy 81 , lockContent = Nothing 82 , checkPresent = checkPresentDummy 83 , checkPresentCheap = bupLocal buprepo 84 , exportActions = exportUnsupported 85 , importActions = importUnsupported 86 , whereisKey = Nothing 87 , remoteFsck = Nothing 88 , repairRepo = Nothing 89 , config = c 90 , getRepo = return r 91 , gitconfig = gc 92 , localpath = if bupLocal buprepo && not (null buprepo) 93 then Just buprepo 94 else Nothing 95 , remotetype = remote 96 , availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable 97 , readonly = False 98 , appendonly = False 99 , untrustworthy = False 100 , mkUnavailable = return Nothing 101 , getInfo = return [("repo", buprepo)] 102 , claimUrl = Nothing 103 , checkUrl = Nothing 104 , remoteStateHandle = rs 105 } 106 let specialcfg = (specialRemoteCfg c) 107 -- chunking would not improve bup 108 { chunkConfig = NoChunks 109 } 110 return $ Just $ specialRemote' specialcfg c 111 (store this buprepo) 112 (retrieve buprepo) 113 (remove buprepo) 114 (checkKey bupr') 115 this 116 where 117 buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc 118 119bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) 120bupSetup _ mu _ c gc = do 121 u <- maybe (liftIO genUUID) return mu 122 123 -- verify configuration is sane 124 let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $ 125 M.lookup buprepoField c 126 (c', _encsetup) <- encryptionSetup c gc 127 128 -- bup init will create the repository. 129 -- (If the repository already exists, bup init again appears safe.) 130 showAction "bup init" 131 unlessM (bup "init" buprepo []) $ giveup "bup init failed" 132 133 storeBupUUID u buprepo 134 135 -- The buprepo is stored in git config, as well as this repo's 136 -- persistant state, so it can vary between hosts. 137 gitConfigSpecialRemote u c' [("buprepo", buprepo)] 138 139 return (c', u) 140 141bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam] 142bupParams command buprepo params = 143 Param command : [Param "-r", Param buprepo] ++ params 144 145bup :: String -> BupRepo -> [CommandParam] -> Annex Bool 146bup command buprepo params = do 147 showOutput -- make way for bup output 148 liftIO $ boolSystem "bup" $ bupParams command buprepo params 149 150bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> [CommandParam] 151bupSplitParams r buprepo k src = 152 let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r 153 in bupParams "split" buprepo 154 (os ++ [Param "-q", Param "-n", Param (bupRef k)] ++ src) 155 156store :: Remote -> BupRepo -> Storer 157store r buprepo = byteStorer $ \k b p -> do 158 showOutput -- make way for bup output 159 quiet <- commandProgressDisabled 160 liftIO $ withNullHandle $ \nullh -> 161 let params = bupSplitParams r buprepo k [] 162 cmd = (proc "bup" (toCommand params)) 163 { std_in = CreatePipe } 164 cmd' = if quiet 165 then cmd 166 { std_out = UseHandle nullh 167 , std_err = UseHandle nullh 168 } 169 else cmd 170 feeder = \h -> do 171 meteredWrite p (S.hPut h) b 172 hClose h 173 in withCreateProcess cmd' (go feeder cmd') 174 where 175 go feeder p (Just h) _ _ pid = 176 forceSuccessProcess p pid 177 `after` 178 feeder h 179 go _ _ _ _ _ _ = error "internal" 180 181retrieve :: BupRepo -> Retriever 182retrieve buprepo = byteRetriever $ \k sink -> do 183 let params = bupParams "join" buprepo [Param $ bupRef k] 184 let p = (proc "bup" (toCommand params)) 185 { std_out = CreatePipe } 186 bracketIO (createProcess p) cleanupProcess (go sink p) 187 where 188 go sink p (_, Just h, _, pid) = do 189 r <- sink =<< liftIO (L.hGetContents h) 190 liftIO $ do 191 hClose h 192 forceSuccessProcess p pid 193 return r 194 go _ _ _ = error "internal" 195 196{- Cannot revert having stored a key in bup, but at least the data for the 197 - key will be used for deltaing data of other keys stored later. 198 - 199 - We can, however, remove the git branch that bup created for the key. 200 -} 201remove :: BupRepo -> Remover 202remove buprepo k = do 203 go =<< liftIO (bup2GitRemote buprepo) 204 warning "content cannot be completely removed from bup remote" 205 where 206 go r 207 | Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params 208 | otherwise = void $ liftIO $ catchMaybeIO $ do 209 r' <- Git.Config.read r 210 boolSystem "git" $ Git.Command.gitCommandLine params r' 211 params = [ Param "branch", Param "-q", Param "-D", Param (bupRef k) ] 212 213{- Bup does not provide a way to tell if a given dataset is present 214 - in a bup repository. One way it to check if the git repository has 215 - a branch matching the name (as created by bup split -n). 216 -} 217checkKey :: Git.Repo -> CheckPresent 218checkKey bupr k 219 | Git.repoIsUrl bupr = onBupRemote bupr boolSystem "git" params 220 | otherwise = liftIO $ boolSystem "git" $ 221 Git.Command.gitCommandLine params bupr 222 where 223 params = 224 [ Param "show-ref" 225 , Param "--quiet" 226 , Param "--verify" 227 , Param $ "refs/heads/" ++ bupRef k 228 ] 229 230{- Store UUID in the annex.uuid setting of the bup repository. -} 231storeBupUUID :: UUID -> BupRepo -> Annex () 232storeBupUUID u buprepo = do 233 r <- liftIO $ bup2GitRemote buprepo 234 if Git.repoIsUrl r 235 then do 236 showAction "storing uuid" 237 unlessM (onBupRemote r boolSystem "git" 238 [Param "config", Param (fromConfigKey configkeyUUID), Param v]) $ 239 giveup "ssh failed" 240 else liftIO $ do 241 r' <- Git.Config.read r 242 let noolduuid = case Git.Config.get configkeyUUID mempty r' of 243 ConfigValue olduuid -> S.null olduuid 244 NoConfigValue -> True 245 when noolduuid $ 246 Git.Command.run 247 [ Param "config" 248 , Param "annex.uuid" 249 , Param v 250 ] r' 251 where 252 v = fromUUID u 253 254onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a 255onBupRemote r runner command params = do 256 c <- Annex.getRemoteGitConfig r 257 let remotecmd = "cd " ++ dir ++ " && " ++ unwords (command : toCommand params) 258 (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd 259 liftIO $ runner sshcmd sshparams 260 where 261 path = fromRawFilePath $ Git.repoPath r 262 base = fromMaybe path (stripPrefix "/~/" path) 263 dir = shellEscape base 264 265{- Allow for bup repositories on removable media by checking 266 - local bup repositories to see if they are available, and getting their 267 - uuid (which may be different from the stored uuid for the bup remote). 268 - 269 - If a bup repository is not available, returns NoUUID. 270 - This will cause checkPresent to indicate nothing from the bup remote 271 - is known to be present. 272 - 273 - Also, returns a version of the repo with config read, if it is local. 274 -} 275getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo) 276getBupUUID r u 277 | Git.repoIsUrl r = return (u, r) 278 | otherwise = liftIO $ do 279 ret <- tryIO $ Git.Config.read r 280 case ret of 281 Right r' -> return (toUUID $ Git.Config.get configkeyUUID mempty r', r') 282 Left _ -> return (NoUUID, r) 283 284{- Converts a bup remote path spec into a Git.Repo. There are some 285 - differences in path representation between git and bup. -} 286bup2GitRemote :: BupRepo -> IO Git.Repo 287bup2GitRemote "" = do 288 -- bup -r "" operates on ~/.bup 289 h <- myHomeDir 290 Git.Construct.fromPath $ toRawFilePath $ h </> ".bup" 291bup2GitRemote r 292 | bupLocal r = 293 if "/" `isPrefixOf` r 294 then Git.Construct.fromPath (toRawFilePath r) 295 else giveup "please specify an absolute path" 296 | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir 297 where 298 bits = splitc ':' r 299 host = Prelude.head bits 300 dir = intercalate ":" $ drop 1 bits 301 -- "host:~user/dir" is not supported specially by bup; 302 -- "host:dir" is relative to the home directory; 303 -- "host:" goes in ~/.bup 304 slash d 305 | null d = "/~/.bup" 306 | "/" `isPrefixOf` d = d 307 | otherwise = "/~/" ++ d 308 309{- Converts a key into a git ref name, which bup-split -n will use to point 310 - to it. -} 311bupRef :: Key -> String 312bupRef k 313 | Git.Ref.legal True shown = shown 314 | otherwise = "git-annex-" ++ show (sha2_256 (fromString shown)) 315 where 316 shown = serializeKey k 317 318bupLocal :: BupRepo -> Bool 319bupLocal = notElem ':' 320