fa62c98910
This eliminates the distinction between decodeBS and decodeBS', encodeBS and encodeBS', etc. The old implementation truncated at NUL, and the primed versions had to do extra work to avoid that problem. The new implementation does not truncate at NUL, and is also a lot faster. (Benchmarked at 2x faster for decodeBS and 3x for encodeBS; more for the primed versions.) Note that filepath-bytestring 1.4.2.1.8 contains the same optimisation, and upgrading to it will speed up to/fromRawFilePath. AFAIK, nothing relied on the old behavior of truncating at NUL. Some code used the faster versions in places where I was sure there would not be a NUL. So this change is unlikely to break anything. Also, moved s2w8 and w82s out of the module, as they do not involve filesystem encoding really. Sponsored-by: Shae Erisson on Patreon
375 lines
13 KiB
Haskell
375 lines
13 KiB
Haskell
{- Using borg as a remote.
|
|
-
|
|
- Copyright 2020,2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Remote.Borg (remote) where
|
|
|
|
import Annex.Common
|
|
import Types.Remote
|
|
import Types.Creds
|
|
import Types.Import
|
|
import qualified Git
|
|
import qualified Git.LsTree as LsTree
|
|
import Git.Types (toTreeItemType, TreeItemType(..))
|
|
import Git.FilePath
|
|
import Config
|
|
import Config.Cost
|
|
import Annex.Tmp
|
|
import Annex.SpecialRemote.Config
|
|
import Remote.Helper.Special
|
|
import Remote.Helper.ExportImport
|
|
import Annex.UUID
|
|
import Types.ProposedAccepted
|
|
import Utility.Metered
|
|
import Logs.Export
|
|
import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated
|
|
import Utility.Env
|
|
|
|
import Data.Either
|
|
import Text.Read
|
|
import Control.Exception (evaluate)
|
|
import Control.DeepSeq
|
|
import qualified Data.Map as M
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified System.FilePath.ByteString as P
|
|
|
|
newtype BorgRepo = BorgRepo { locBorgRepo :: String }
|
|
|
|
type BorgArchiveName = S.ByteString
|
|
|
|
remote :: RemoteType
|
|
remote = RemoteType
|
|
{ typename = "borg"
|
|
, enumerate = const (findSpecialRemotes "borgrepo")
|
|
, generate = gen
|
|
, configParser = mkRemoteConfigParser
|
|
[ optionalStringParser borgrepoField
|
|
(FieldDesc "(required) borg repository to use")
|
|
, optionalStringParser subdirField
|
|
(FieldDesc "limit to a subdirectory of the borg repository")
|
|
, yesNoParser appendonlyField (Just False)
|
|
(FieldDesc "you will not use borg to delete from the repository")
|
|
]
|
|
, setup = borgSetup
|
|
, exportSupported = exportUnsupported
|
|
, importSupported = importIsSupported
|
|
, thirdPartyPopulated = True
|
|
}
|
|
|
|
borgrepoField :: RemoteConfigField
|
|
borgrepoField = Accepted "borgrepo"
|
|
|
|
subdirField :: RemoteConfigField
|
|
subdirField = Accepted "subdir"
|
|
|
|
appendonlyField :: RemoteConfigField
|
|
appendonlyField = Accepted "appendonly"
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
|
gen r u rc gc rs = do
|
|
c <- parsedRemoteConfig remote rc
|
|
cst <- remoteCost gc $
|
|
if borgLocal borgrepo
|
|
then nearlyCheapRemoteCost
|
|
else expensiveRemoteCost
|
|
return $ Just $ Remote
|
|
{ uuid = u
|
|
, cost = cst
|
|
, name = Git.repoDescribe r
|
|
, storeKey = storeKeyDummy
|
|
, retrieveKeyFile = retrieveKeyFileDummy
|
|
, retrieveKeyFileCheap = Nothing
|
|
-- Borg cryptographically verifies content.
|
|
, retrievalSecurityPolicy = RetrievalAllKeysSecure
|
|
, removeKey = removeKeyDummy
|
|
, lockContent = Nothing
|
|
, checkPresent = checkPresentDummy
|
|
, checkPresentCheap = borgLocal borgrepo
|
|
, exportActions = exportUnsupported
|
|
, importActions = ImportActions
|
|
{ listImportableContents = listImportableContentsM u borgrepo c
|
|
, importKey = Just ThirdPartyPopulated.importKey
|
|
, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM borgrepo
|
|
, checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM borgrepo
|
|
-- This remote is thirdPartyPopulated, so these
|
|
-- actions will never be used.
|
|
, storeExportWithContentIdentifier = storeExportWithContentIdentifier importUnsupported
|
|
, removeExportDirectoryWhenEmpty = removeExportDirectoryWhenEmpty importUnsupported
|
|
, removeExportWithContentIdentifier = removeExportWithContentIdentifier importUnsupported
|
|
}
|
|
, whereisKey = Nothing
|
|
, remoteFsck = Nothing
|
|
, repairRepo = Nothing
|
|
, config = c
|
|
, getRepo = return r
|
|
, gitconfig = gc
|
|
, localpath = borgRepoLocalPath borgrepo
|
|
, remotetype = remote
|
|
, availability = if borgLocal borgrepo then LocallyAvailable else GloballyAvailable
|
|
, readonly = False
|
|
, appendonly = False
|
|
-- When the user sets the appendonly field, they are
|
|
-- promising not to delete content out from under git-annex
|
|
-- using borg, so the remote is not untrustworthy.
|
|
, untrustworthy = maybe True not $
|
|
getRemoteConfigValue appendonlyField c
|
|
, mkUnavailable = return Nothing
|
|
, getInfo = return [("repo", locBorgRepo borgrepo)]
|
|
, claimUrl = Nothing
|
|
, checkUrl = Nothing
|
|
, remoteStateHandle = rs
|
|
}
|
|
where
|
|
borgrepo = maybe
|
|
(giveup "missing borgrepo")
|
|
BorgRepo
|
|
(remoteAnnexBorgRepo gc)
|
|
|
|
borgSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
|
borgSetup _ mu _ c _gc = do
|
|
u <- maybe (liftIO genUUID) return mu
|
|
|
|
-- verify configuration is sane
|
|
let borgrepo = maybe (giveup "Specify borgrepo=") fromProposedAccepted $
|
|
M.lookup borgrepoField c
|
|
|
|
-- The borgrepo is stored in git config, as well as this repo's
|
|
-- persistant state, so it can vary between hosts.
|
|
gitConfigSpecialRemote u c [("borgrepo", borgrepo)]
|
|
|
|
return (c, u)
|
|
|
|
borgLocal :: BorgRepo -> Bool
|
|
borgLocal (BorgRepo r) = notElem ':' r
|
|
|
|
borgArchive :: BorgRepo -> BorgArchiveName -> String
|
|
borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS n
|
|
|
|
absBorgRepo :: BorgRepo -> IO BorgRepo
|
|
absBorgRepo r@(BorgRepo p)
|
|
| borgLocal r = BorgRepo . fromRawFilePath
|
|
<$> absPath (toRawFilePath p)
|
|
| otherwise = return r
|
|
|
|
borgRepoLocalPath :: BorgRepo -> Maybe FilePath
|
|
borgRepoLocalPath r@(BorgRepo p)
|
|
| borgLocal r && not (null p) = Just p
|
|
| otherwise = Nothing
|
|
|
|
listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
|
|
listImportableContentsM u borgrepo c = prompt $ do
|
|
imported <- getImported u
|
|
ls <- withborglist (locBorgRepo borgrepo) Nothing formatarchivelist $ \as ->
|
|
forM (filter (not . S.null) as) $ \archivename ->
|
|
case M.lookup archivename imported of
|
|
Just getfast -> return $ Left (archivename, getfast)
|
|
Nothing -> Right <$>
|
|
let archive = borgArchive borgrepo archivename
|
|
in withborglist archive subdir formatfilelist $
|
|
liftIO . evaluate . force . parsefilelist archivename
|
|
if all isLeft ls && M.null (M.difference imported (M.fromList (lefts ls)))
|
|
then return Nothing -- unchanged since last time, avoid work
|
|
else Just . mkimportablecontents <$> mapM (either snd pure) ls
|
|
where
|
|
withborglist what addparam format a = do
|
|
environ <- liftIO getEnvironment
|
|
let p = proc "borg" $ toCommand $ catMaybes
|
|
[ Just (Param "list")
|
|
, Just (Param "--format")
|
|
, Just (Param format)
|
|
, Just (Param what)
|
|
, addparam
|
|
]
|
|
(Nothing, Just h, Nothing, pid) <- liftIO $ createProcess $ p
|
|
{ std_out = CreatePipe
|
|
-- Run in C locale because the file list can
|
|
-- include some possibly translatable text in the
|
|
-- "extra" field.
|
|
, env = Just (addEntry "LANG" "C" environ)
|
|
}
|
|
l <- liftIO $ map L.toStrict
|
|
. L.split 0
|
|
<$> L.hGetContents h
|
|
let cleanup = liftIO $ do
|
|
hClose h
|
|
forceSuccessProcess p pid
|
|
a l `finally` cleanup
|
|
|
|
formatarchivelist = "{barchive}{NUL}"
|
|
|
|
formatfilelist = "{size}{NUL}{path}{NUL}{extra}{NUL}"
|
|
|
|
subdir = File <$> getRemoteConfigValue subdirField c
|
|
|
|
parsefilelist archivename (bsz:f:extra:rest) = case readMaybe (fromRawFilePath bsz) of
|
|
Nothing -> parsefilelist archivename rest
|
|
Just sz ->
|
|
let loc = genImportLocation archivename f
|
|
-- borg list reports hard links as 0 byte files,
|
|
-- with the extra field set to " link to ".
|
|
-- When the annex object is a hard link to
|
|
-- something else, we'll assume it has not been
|
|
-- modified, since usually git-annex does prevent
|
|
-- this. Since the 0 byte size is not the actual
|
|
-- size, report the key size instead, when available.
|
|
(reqsz, retsz) = case extra of
|
|
" link to " -> (Nothing, fromMaybe sz . fromKey keySize)
|
|
_ -> (Just sz, const sz)
|
|
-- This does a little unncessary work to parse the
|
|
-- key, which is then thrown away. But, it lets the
|
|
-- file list be shrank down to only the ones that are
|
|
-- importable keys, so avoids needing to buffer all
|
|
-- the rest of the files in memory.
|
|
in case ThirdPartyPopulated.importKey' loc reqsz of
|
|
Just k -> (loc, (borgContentIdentifier, retsz k))
|
|
: parsefilelist archivename rest
|
|
Nothing -> parsefilelist archivename rest
|
|
parsefilelist _ _ = []
|
|
|
|
-- importableHistory is not used for retrieval, so is not
|
|
-- populated with old archives. Instead, a tree of archives
|
|
-- is constructed, by genImportLocation including the archive
|
|
-- name in the ImportLocation.
|
|
mkimportablecontents l = ImportableContents
|
|
{ importableContents = concat l
|
|
, importableHistory = []
|
|
}
|
|
|
|
-- We do not need a ContentIdentifier in order to retrieve a file from
|
|
-- borg; the ImportLocation contains all that's needed. So, this is left
|
|
-- empty.
|
|
borgContentIdentifier :: ContentIdentifier
|
|
borgContentIdentifier = ContentIdentifier mempty
|
|
|
|
-- Borg does not allow / in the name of an archive, so the archive
|
|
-- name will always be the first directory in the ImportLocation.
|
|
--
|
|
-- Paths in a borg archive are always relative, not absolute, so the use of
|
|
-- </> to combine the archive name with the path will always work.
|
|
genImportLocation :: BorgArchiveName -> RawFilePath -> ImportLocation
|
|
genImportLocation archivename p =
|
|
ThirdPartyPopulated.mkThirdPartyImportLocation $
|
|
archivename P.</> p
|
|
|
|
extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath)
|
|
extractImportLocation loc = go $ P.splitDirectories $
|
|
ThirdPartyPopulated.fromThirdPartyImportLocation loc
|
|
where
|
|
go (archivename:rest) = (archivename, P.joinPath rest)
|
|
go _ = giveup $ "Unable to parse import location " ++ fromRawFilePath (fromImportLocation loc)
|
|
|
|
-- Since the ImportLocation starts with the archive name, a list of all
|
|
-- archive names we've already imported can be found by just listing the
|
|
-- last imported tree. And the contents of those archives can be retrieved
|
|
-- by listing the subtree recursively, which will likely be quite a lot
|
|
-- faster than running borg.
|
|
getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(ImportLocation, (ContentIdentifier, ByteSize))]))
|
|
getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u)
|
|
where
|
|
go t = M.fromList . mapMaybe mk
|
|
<$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeNonRecursive (LsTree.LsTreeLong False) t)
|
|
|
|
mk ti
|
|
| toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just
|
|
( getTopFilePath (LsTree.file ti)
|
|
, getcontents
|
|
(getTopFilePath (LsTree.file ti))
|
|
(LsTree.sha ti)
|
|
)
|
|
| otherwise = Nothing
|
|
|
|
getcontents archivename t = mapMaybe (mkcontents archivename)
|
|
<$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeRecursive (LsTree.LsTreeLong False) t)
|
|
|
|
mkcontents archivename ti = do
|
|
let f = ThirdPartyPopulated.fromThirdPartyImportLocation $
|
|
mkImportLocation $ getTopFilePath $ LsTree.file ti
|
|
k <- fileKey (P.takeFileName f)
|
|
return
|
|
( genImportLocation archivename f
|
|
,
|
|
( borgContentIdentifier
|
|
-- defaulting to 0 size is ok, this size
|
|
-- only gets used by
|
|
-- ThirdPartyPopulated.importKey,
|
|
-- which ignores the size when the key
|
|
-- does not have a size.
|
|
, fromMaybe 0 (fromKey keySize k)
|
|
)
|
|
)
|
|
|
|
-- Check if the file is still there in the borg archive.
|
|
-- Does not check that the content is unchanged; we assume that
|
|
-- the content of files in borg archives does not change, which is normally
|
|
-- the case. But archives may be deleted, and files may be deleted.
|
|
checkPresentExportWithContentIdentifierM :: BorgRepo -> Key -> ImportLocation -> [ContentIdentifier] -> Annex Bool
|
|
checkPresentExportWithContentIdentifierM borgrepo _ loc _ = prompt $ liftIO $ do
|
|
let p = proc "borg" $ toCommand
|
|
[ Param "list"
|
|
, Param "--format"
|
|
, Param "1"
|
|
, Param (borgArchive borgrepo archivename)
|
|
, File (fromRawFilePath archivefile)
|
|
]
|
|
-- borg list exits nonzero with an error message if an archive
|
|
-- no longer exists. But, the user can delete archives at any
|
|
-- time they want. So, hide errors, and if it exists nonzero,
|
|
-- check if the borg repository still exists, and only throw an
|
|
-- exception if not.
|
|
(Nothing, Just h, Nothing, pid) <- withNullHandle $ \nullh ->
|
|
createProcess $ p
|
|
{ std_out = CreatePipe
|
|
, std_err = UseHandle nullh
|
|
}
|
|
ok <- (== "1") <$> hGetContentsStrict h
|
|
hClose h
|
|
ifM (checkSuccessProcess pid)
|
|
( return ok
|
|
, checkrepoexists
|
|
)
|
|
where
|
|
(archivename, archivefile) = extractImportLocation loc
|
|
|
|
checkrepoexists = do
|
|
let p = proc "borg" $ toCommand
|
|
[ Param "list"
|
|
, Param "--format"
|
|
, Param "1"
|
|
, Param (locBorgRepo borgrepo)
|
|
]
|
|
(Nothing, Nothing, Nothing, pid) <- withNullHandle $ \nullh ->
|
|
createProcess $ p
|
|
{ std_out = UseHandle nullh }
|
|
ifM (checkSuccessProcess pid)
|
|
( return False -- repo exists, content not in it
|
|
, giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo
|
|
)
|
|
|
|
retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
|
|
retrieveExportWithContentIdentifierM borgrepo loc _ dest mkk _ = do
|
|
showOutput
|
|
prompt $ withOtherTmp $ \othertmp -> liftIO $ do
|
|
-- borgrepo could be relative, and borg has to be run
|
|
-- in the temp directory to get it to write there
|
|
absborgrepo <- absBorgRepo borgrepo
|
|
let p = proc "borg" $ toCommand
|
|
[ Param "extract"
|
|
, Param (borgArchive absborgrepo archivename)
|
|
, File (fromRawFilePath archivefile)
|
|
]
|
|
(Nothing, Nothing, Nothing, pid) <- createProcess $ p
|
|
{ cwd = Just (fromRawFilePath othertmp) }
|
|
forceSuccessProcess p pid
|
|
-- Filepaths in borg archives are relative, so it's ok to
|
|
-- combine with </>
|
|
moveFile (fromRawFilePath othertmp </> fromRawFilePath archivefile) dest
|
|
removeDirectoryRecursive (fromRawFilePath othertmp)
|
|
mkk
|
|
where
|
|
(archivename, archivefile) = extractImportLocation loc
|