git-annex/Remote/Borg.hs

{- Using borg as a remote.
 -
 - Copyright 2020 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

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.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.ExportImport
import Annex.UUID
import Types.ProposedAccepted
import Utility.Metered
import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated
import Logs.Export

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

type BorgRepo = 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")
		]
	, setup = borgSetup
	, exportSupported = exportUnsupported
	, importSupported = importIsSupported
	, thirdPartyPopulated = True
	}

borgrepoField :: RemoteConfigField
borgrepoField = Accepted "borgrepo"

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
			, 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 = if borgLocal borgrepo && not (null borgrepo)
			then Just borgrepo
			else Nothing
		, remotetype = remote
		, availability = if borgLocal borgrepo then LocallyAvailable else GloballyAvailable
		, readonly = False
		, appendonly = False
		, mkUnavailable = return Nothing
		, getInfo = return [("repo", borgrepo)]
		, claimUrl = Nothing
		, checkUrl = Nothing
		, remoteStateHandle = rs
		}
  where
	borgrepo = fromMaybe (giveup "missing 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)]

	-- TODO: untrusted by default, but allow overriding that

	return (c, u)

borgLocal :: BorgRepo -> Bool
borgLocal = notElem ':'

-- XXX the tree generated by using this does not seem to get grafted into
-- the git-annex branch, so would be subject to being lost to GC.
-- Is this a general problem affecting importtree too?
listImportableContentsM :: UUID -> BorgRepo -> Annex (ImportableContents (ContentIdentifier, ByteSize))
listImportableContentsM u borgrepo = prompt $ do
	imported <- getImported u
	ls <- withborglist borgrepo "{barchive}{NUL}" $ \as ->
		forM as $ \archivename ->
			case M.lookup archivename imported of
				Just getfast -> getfast
				Nothing -> 
					let archive = borgrepo ++ "::" ++ decodeBS' archivename
					in withborglist archive "{size}{NUL}{path}{NUL}" $
						liftIO . evaluate . force . parsefilelist archivename
	return $ mkimportablecontents ls
  where
	withborglist what format a = do
		let p = (proc "borg" ["list", what, "--format", format])
			{ std_out = CreatePipe }
		(Nothing, Just h, Nothing, pid) <- liftIO $ createProcess p
		l <- liftIO $ map L.toStrict 
			. filter (not . L.null) 
			. L.split 0 
			<$> L.hGetContents h
		let cleanup = liftIO $ do
			hClose h
			forceSuccessProcess p pid
		a l `finally` cleanup

	parsefilelist archivename (bsz:f:rest) = case readMaybe (fromRawFilePath bsz) of
		Nothing -> parsefilelist archivename rest
		Just sz ->
			let loc = genImportLocation archivename f
			-- 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 sz of
				Just k -> (loc, (borgContentIdentifier, sz))
					: 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 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 t)
	
	mkcontents archivename ti = do
		let f = ThirdPartyPopulated.fromThirdPartyImportLocation $
			mkImportLocation $ getTopFilePath $ LsTree.file ti
		k <- deserializeKey' (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)
				)
			)

retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
retrieveExportWithContentIdentifierM borgrepo loc cid dest k p = error "TODO"

checkPresentExportWithContentIdentifierM :: BorgRepo -> Key -> ImportLocation -> [ContentIdentifier] -> Annex Bool
checkPresentExportWithContentIdentifierM borgrepo k loc cids = error "TODO"