diff --git a/Remote/Borg.hs b/Remote/Borg.hs index b1f5cd3921..13b1e3e3b3 100644 --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -128,6 +128,9 @@ borgSetup _ mu _ c _gc = do borgLocal :: BorgRepo -> Bool borgLocal = notElem ':' +borgArchive :: BorgRepo -> BorgArchiveName -> String +borgArchive r n = r ++ "::" ++ decodeBS' n + -- 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? @@ -139,7 +142,7 @@ listImportableContentsM u borgrepo = prompt $ do case M.lookup archivename imported of Just getfast -> return $ Left getfast Nothing -> Right <$> - let archive = borgrepo ++ "::" ++ decodeBS' archivename + let archive = borgArchive borgrepo archivename in withborglist archive "{size}{NUL}{path}{NUL}" $ liftIO . evaluate . force . parsefilelist archivename if all isLeft ls @@ -249,5 +252,49 @@ getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key retrieveExportWithContentIdentifierM borgrepo loc cid dest k p = error "TODO" +-- 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 k loc cids = error "TODO" +checkPresentExportWithContentIdentifierM borgrepo k loc cids = liftIO $ do + let p = proc "borg" + [ "list" + , "--format" + , "1" + , borgArchive borgrepo archivename + , 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" + [ "list" + , "--format" + , "1" + , 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 " ++ borgrepo + )