- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Remote.Borg (remote) where
import Annex.Common
import Annex.UUID
import Types.ProposedAccepted
import Utility.Metered
-import qualified Remote.Helper.ThirdParty as ThirdParty
+import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated
+import Text.Read
+import Control.Exception (evaluate)
+import Control.DeepSeq
import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
type BorgRepo = String
, exportActions = exportUnsupported
, importActions = ImportActions
{ listImportableContents = listImportableContentsM borgrepo
- , importKey = Just ThirdParty.importKey
+ , importKey = Just ThirdPartyPopulated.importKey
, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM borgrepo
, checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM borgrepo
-- This remote is thirdPartyPopulated, so these
borgLocal :: BorgRepo -> Bool
borgLocal = notElem ':'
+-- TODO avoid rescanning archives that have already been scanned
+--
+-- XXX importableHistory should probably not be populated. git-annex
+-- only stores and uses the most recent imported tree, not the whole history,
+-- I think. So a key that's only in a previous archive would not have
+-- a known ImportLocation when retrieving it.
+-- Instead, maybe need to include the archive names at the top of the
+-- importlocation? (Then would not need them in the ContentIdentifier.)
+--
+-- 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 :: BorgRepo -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
-listImportableContentsM borgrepo = error "TODO"
+listImportableContentsM borgrepo = prompt $ do
+ ls <- withborglist borgrepo "{barchive}{NUL}" $ \as ->
+ forM as $ \archive ->
+ let archive' = borgrepo ++ "::" ++ decodeBS' archive
+ in withborglist archive' "{size}{NUL}{path}{NUL}" $
+ liftIO . evaluate . force . parsefilelist archive
+ return (Just (mkimportablecontents (reverse 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 archive (bsz:f:rest) = case readMaybe (fromRawFilePath bsz) of
+ Nothing -> parsefilelist archive rest
+ Just sz ->
+ let loc = ThirdPartyPopulated.mkThirdPartyImportLocation 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, (ContentIdentifier archive, sz))
+ : parsefilelist archive rest
+ Nothing -> parsefilelist archive rest
+ parsefilelist _ _ = []
+
+ mkimportablecontents [] = ImportableContents
+ { importableContents = []
+ , importableHistory = []
+ }
+ mkimportablecontents (v:vs) = ImportableContents
+ { importableContents = v
+ , importableHistory = [mkimportablecontents vs]
+ }
retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
retrieveExportWithContentIdentifierM borgrepo loc cid dest k p = error "TODO"
- Licensed under the GNU AGPL version 3 or higher.
-}
-module Remote.Helper.ThirdParty where
+{-# LANGUAGE OverloadedStrings #-}
+
+module Remote.Helper.ThirdPartyPopulated where
import Annex.Common
import Types.Remote
import Utility.Metered
import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString as S
+
+-- When a remote is thirdPartyPopulated, the files we want are probably
+-- in the .git directory. But, git does not really support .git in paths
+-- in a git tree. (Such a tree can be built, but it will lead to problems.)
+-- And so anything in .git is prevented from being imported.
+-- To work around that, this renames that directory when generating an
+-- ImportLocation.
+mkThirdPartyImportLocation :: RawFilePath -> ImportLocation
+mkThirdPartyImportLocation =
+ mkImportLocation . P.joinPath . map esc . P.splitDirectories
+ where
+ esc ".git" = "dotgit"
+ esc x
+ | "dotgit" `S.isSuffixOf` x = "dot" <> x
+ | otherwise = x
+
+fromThirdPartyImportLocation :: ImportLocation -> RawFilePath
+fromThirdPartyImportLocation =
+ P.joinPath . map unesc . P.splitDirectories . fromImportLocation
+ where
+ unesc "dotgit" = ".git"
+ unesc x
+ | "dotgit" `S.isSuffixOf` x = S.drop 3 x
+ | otherwise = x
-- When a remote is thirdPartyPopulated, and contains a backup of a
-- git-annex repository or some special remotes, this can be used to
-- find only those ImportLocations that are annex object files.
-- All other ImportLocations are ignored.
importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)
-importKey loc _cid sz _ = return $ case deserializeKey' f of
+importKey loc _cid sz _ = return $ importKey' loc sz
+
+importKey' :: ImportLocation -> ByteSize -> Maybe Key
+importKey' loc sz = case deserializeKey' f of
Just k
-- Annex objects always are in a subdirectory with the same
-- name as the filename. If this is not the case for the file
projects / git-annex.git / commitdiff