optimisation for borg

Skip needing to list importable contents when unchanged since last time.

diff --git a/Annex/Import.hs b/Annex/Import.hs
index 9c113002d5b2c944005b8a87e445ee1b5d013c89..201d9e5f7e3e4d3e3484e878ddc4a6c83d54d746 100644 (file)
--- a/Annex/Import.hs
+++ b/Annex/Import.hs
@@ -660,12 +660,15 @@ makeImportMatcher r = load preferredContentKeylessTokens >>= \case
  - would delete the files.
  -
  - Throws exception if unable to contact the remote.
+ - Returns Nothing when there is no change since last time.
  -}
-getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (ImportableContents (ContentIdentifier, ByteSize))
+getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 getImportableContents r importtreeconfig ci matcher = do
-       importable <- Remote.listImportableContents (Remote.importActions r)
-       dbhandle <- Export.openDb (Remote.uuid r)
-       filterunwanted dbhandle importable
+       Remote.listImportableContents (Remote.importActions r) >>= \case
+               Just importable -> do
+                       dbhandle <- Export.openDb (Remote.uuid r)
+                       Just <$> filterunwanted dbhandle importable
+               Nothing -> return Nothing
   where
        filterunwanted dbhandle ic = ImportableContents
                <$> filterM (wanted dbhandle) (importableContents ic)

diff --git a/Command/Import.hs b/Command/Import.hs
index b09984c2c3b05d85ce6939e03e26c9f2ef47f0f2..e1560ce93a5e70a702bc67601de511f3ad67698d 100644 (file)
--- a/Command/Import.hs
+++ b/Command/Import.hs
@@ -325,13 +325,13 @@ seekRemote remote branch msubdir importcontent ci = do
 listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart
 listContents remote importtreeconfig ci tvar = starting "list" ai si $
        listContents' remote importtreeconfig ci $ \importable -> do
-               liftIO $ atomically $ writeTVar tvar (Just importable)
+               liftIO $ atomically $ writeTVar tvar importable
                next $ return True
   where
        ai = ActionItemOther (Just (Remote.name remote))
        si = SeekInput []
 
-listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (ImportableContents (ContentIdentifier, Remote.ByteSize) -> Annex a) -> Annex a
+listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a
 listContents' remote importtreeconfig ci a = 
        makeImportMatcher remote >>= \case
                Right matcher -> tryNonAsync (getImportableContents remote importtreeconfig ci matcher) >>= \case

diff --git a/Command/Sync.hs b/Command/Sync.hs
index 3a3839b0502ecf2b54b0d4dc4acfa42f12cc38d4..0bfe4241fb5fc734a9338e20893ea5fb8326e5e3 100644 (file)
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -495,13 +495,14 @@ importThirdPartyPopulated remote =
        void $ includeCommandAction $ starting "list" ai si $
                Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go
   where
-       go importable = importKeys remote ImportTree False True importable >>= \case
+       go (Just importable) = importKeys remote ImportTree False True importable >>= \case
                Just importablekeys -> do
                        (_imported, updatestate) <- recordImportTree remote ImportTree importablekeys
                        next $ do
                                updatestate
                                return True
                Nothing -> next $ return False
+       go Nothing = next $ return True -- unchanged from before
 
        ai = ActionItemOther (Just (Remote.name remote))
        si = SeekInput []

diff --git a/Remote/Adb.hs b/Remote/Adb.hs
index 3543051030c1923ec29792055be84336675fa87e..f67df51754b5aaa9f772136a1bd63c656685d6ac 100644 (file)
--- a/Remote/Adb.hs
+++ b/Remote/Adb.hs
@@ -286,9 +286,9 @@ renameExportM serial adir _k old new = do
                , File newloc
                ]
 
-listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (ImportableContents (ContentIdentifier, ByteSize))
+listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 listImportableContentsM serial adir = adbfind >>= \case
-       Just ls -> return $ ImportableContents (mapMaybe mk ls) []
+       Just ls -> return $ Just $ ImportableContents (mapMaybe mk ls) []
        Nothing -> giveup "adb find failed"
   where
        adbfind = adbShell serial

diff --git a/Remote/Borg.hs b/Remote/Borg.hs
index 7cc4d5e0fac3a74f85c290f14821977c7a2ad131..b1f5cd392114cddb7c14cc6d773dd86c9b205b33 100644 (file)
--- a/Remote/Borg.hs
+++ b/Remote/Borg.hs
@@ -26,6 +26,7 @@ import Utility.Metered
 import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated
 import Logs.Export
 
+import Data.Either
 import Text.Read
 import Control.Exception (evaluate)
 import Control.DeepSeq
@@ -122,8 +123,6 @@ borgSetup _ mu _ c _gc = do
        -- 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
@@ -132,18 +131,20 @@ 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 :: UUID -> BorgRepo -> Annex (Maybe (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 -> 
+                               Just getfast -> return $ Left getfast
+                               Nothing -> Right <$>
                                        let archive = borgrepo ++ "::" ++ decodeBS' archivename
                                        in withborglist archive "{size}{NUL}{path}{NUL}" $
                                                liftIO . evaluate . force . parsefilelist archivename
-       return $ mkimportablecontents ls
+       if all isLeft ls
+               then return Nothing -- unchanged since last time, avoid work
+               else Just . mkimportablecontents <$> mapM (either id pure) ls
   where
        withborglist what format a = do
                let p = (proc "borg" ["list", what, "--format", format])

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index ed2a9dce74931a2780f5d2e73772a50f08efd988..6de71fffe94626a46a787fea2d88da8d3d8ee81e 100644 (file)
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -337,11 +337,11 @@ removeExportLocation topdir loc =
                        mkExportLocation loc'
                in go (upFrom loc') =<< tryIO (removeDirectory p)
 
-listImportableContentsM :: RawFilePath -> Annex (ImportableContents (ContentIdentifier, ByteSize))
+listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 listImportableContentsM dir = liftIO $ do
        l <- dirContentsRecursive (fromRawFilePath dir)
        l' <- mapM (go . toRawFilePath) l
-       return $ ImportableContents (catMaybes l') []
+       return $ Just $ ImportableContents (catMaybes l') []
   where
        go f = do
                st <- R.getFileStatus f

diff --git a/Remote/S3.hs b/Remote/S3.hs
index ec9a16d1b44deee2d9a1d700f3b2f92d6ddbd4b4..90db63bb1deb3146b334a270b74c4498a2129b6d 100644 (file)
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -550,13 +550,14 @@ renameExportS3 hv r rs info k src dest = Just <$> go
        srcobject = T.pack $ bucketExportLocation info src
        dstobject = T.pack $ bucketExportLocation info dest
 
-listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (ImportableContents (ContentIdentifier, ByteSize))
+listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 listImportableContentsS3 hv r info =
        withS3Handle hv $ \case
                Nothing -> giveup $ needS3Creds (uuid r)
-               Just h -> liftIO $ runResourceT $
-                       extractFromResourceT =<< startlist h
+               Just h -> Just <$> go h
   where
+       go h = liftIO $ runResourceT $ extractFromResourceT =<< startlist h
+
        startlist h
                | versioning info = do
                        rsp <- sendS3Handle h $ 

diff --git a/Types/Remote.hs b/Types/Remote.hs
index 2404c523646a987967634719a63b39536a7cb5b2..cc5fb47a232bdfbe0af181a0e3d8862c79d81d2c 100644 (file)
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -283,7 +283,8 @@ data ImportActions a = ImportActions
        -- remote.
        --
        -- Throws exception on failure to access the remote.
-       { listImportableContents :: a (ImportableContents (ContentIdentifier, ByteSize))
+       -- May return Nothing when the remote is unchanged since last time.
+       { listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
        -- Generates a Key (of any type) for the file stored on the
        -- remote at the ImportLocation. Does not download the file
        -- from the remote.

diff --git a/doc/special_remotes/borg.mdwn b/doc/special_remotes/borg.mdwn
index 42f7fefde16f223294eea6d353dfb7d1a61279dc..a97afd0b2c5521538601092d350cb36d4906898f 100644 (file)
--- a/doc/special_remotes/borg.mdwn
+++ b/doc/special_remotes/borg.mdwn
@@ -62,3 +62,7 @@ So either keep the borg special remote as untrusted, and use such borg
 commands to delete old archives as needed, or avoid using `borg delete`
 and `borg prune`, and then the remote can safely be made semitrusted or
 trusted.
+
+Also, if you do choose to delete old archives, make sure to never reuse
+that archive name for a new archive. git-annex may think it's the same
+archive it saw before, and not notice the change.