incomplete action to download files from import

This commit is contained in:
Joey Hess 2019-02-26 15:25:28 -04:00
parent b6e2a5e9c2
commit f4b773e9a1
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 100 additions and 13 deletions

View file

@ -5,13 +5,16 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Annex.Import (
RemoteTrackingBranch(..),
mkRemoteTrackingBranch,
ImportTreeConfig(..),
ImportCommitConfig(..),
buildImportCommit,
buildImportTrees
buildImportTrees,
downloadImport
) where
import Annex.Common
@ -26,8 +29,14 @@ import qualified Git.Branch
import qualified Annex
import Annex.Link
import Annex.LockFile
import Utility.Metered
import Logs.Export
import Database.Export
import Logs.ContentIdentifier
import qualified Database.Export as Export
import qualified Database.ContentIdentifier as CID
import Control.Concurrent.STM
import qualified Data.Map.Strict as M
newtype RemoteTrackingBranch = RemoteTrackingBranch
{ fromRemoteTrackingBranch :: Ref }
@ -120,14 +129,14 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
updateexportdb importedtree =
withExclusiveLock (gitAnnexExportLock (Remote.uuid remote)) $ do
db <- openDb (Remote.uuid remote)
db <- Export.openDb (Remote.uuid remote)
prevtree <- liftIO $ fromMaybe emptyTree
<$> getExportTreeCurrent db
<$> Export.getExportTreeCurrent db
when (importedtree /= prevtree) $ do
updateExportTree db prevtree importedtree
liftIO $ recordExportTreeCurrent db importedtree
Export.updateExportTree db prevtree importedtree
liftIO $ Export.recordExportTreeCurrent db importedtree
-- TODO: addExportedLocation etc
liftIO $ flushDbQueue db
Export.closeDb db
updateexportlog importedtree = do
old <- getExport (Remote.uuid remote)
@ -170,3 +179,63 @@ buildImportTrees basetree msubdir importable = History
symlink <- calcRepo $ gitAnnexLink relf k
linksha <- hashSymlink symlink
return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha
{- Downloads all new ContentIdentifiers. Supports concurrency when enabled.
-
- If any download fails, the whole thing fails, but it will resume where
- it left off.
-}
downloadImport :: Remote -> ImportableContents ContentIdentifier -> Annex (Maybe (ImportableContents Key))
downloadImport remote importablecontents = do
-- This map is used to remember content identifiers that
-- were just downloaded, before they have necessarily been
-- stored in the database. This way, if the same content
-- identifier appears multiple times in the
-- importablecontents (eg when it has a history),
-- they will only be downloaded once.
cidmap <- liftIO $ newTVarIO M.empty
bracket CID.openDb CID.closeDb (go cidmap importablecontents)
-- TODO really support concurrency; avoid donwloading the same
-- ContentIdentifier twice.
where
go cidmap (ImportableContents l h) db = do
l' <- mapM (download cidmap db) l
if any isNothing l'
then return Nothing
else do
h' <- mapM (\ic -> go cidmap ic db) h
if any isNothing h'
then return Nothing
else return $ Just $
ImportableContents
(catMaybes l')
(catMaybes h')
download cidmap db (loc, cid) = getcidkey cidmap db cid >>= \case
(k:_) -> return $ Just (loc, k)
[] -> do
-- TODO progresss bar
let p = nullMeterUpdate
let ia = Remote.importActions remote
Remote.retrieveExportWithContentIdentifier ia loc cid mkkey p >>= \case
Just k -> do
recordcidkey cidmap db cid k
return $ Just (loc, k)
Nothing -> return Nothing
mkkey f = error "TODO"
getcidkey cidmap db cid = liftIO $
CID.getContentIdentifierKeys db (Remote.uuid remote) cid >>= \case
[] -> atomically $ do
m <- readTVar cidmap
-- force lookup inside STM transaction
let !v = maybeToList $ M.lookup cid m
return v
l -> return l
recordcidkey cidmap db cid k = do
liftIO $ atomically $ modifyTVar' cidmap $
M.insert cid k
liftIO $ CID.recordContentIdentifier db (Remote.uuid remote) cid k
recordContentIdentifier (Remote.uuid remote) cid k