implemented checkPresentExportWithContentIdentifier

diff --git a/Remote/Borg.hs b/Remote/Borg.hs
index b1f5cd392114cddb7c14cc6d773dd86c9b205b33..13b1e3e3b3ea6692d87c7c4a8cfb450447267a8d 100644 (file)
--- 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
+                       )