avoid a second traversal of the ImportableContents
Do all filtering in one pass.
This commit is contained in:
		
					parent
					
						
							
								a9128d4b45
							
						
					
				
			
			
				commit
				
					
						0033e08193
					
				
			
		
					 2 changed files with 45 additions and 49 deletions
				
			
		| 
						 | 
				
			
			@ -14,9 +14,8 @@ module Annex.Import (
 | 
			
		|||
	buildImportTrees,
 | 
			
		||||
	canImportKeys,
 | 
			
		||||
	importKeys,
 | 
			
		||||
	filterImportableContents,
 | 
			
		||||
	makeImportMatcher,
 | 
			
		||||
	listImportableContents,
 | 
			
		||||
	getImportableContents,
 | 
			
		||||
) where
 | 
			
		||||
 | 
			
		||||
import Annex.Common
 | 
			
		||||
| 
						 | 
				
			
			@ -58,7 +57,7 @@ import Backend.Utilities
 | 
			
		|||
import Control.Concurrent.STM
 | 
			
		||||
import qualified Data.Map.Strict as M
 | 
			
		||||
import qualified Data.Set as S
 | 
			
		||||
import qualified System.FilePath.Posix as Posix
 | 
			
		||||
import qualified System.FilePath.Posix.ByteString as Posix
 | 
			
		||||
import qualified System.FilePath.ByteString as P
 | 
			
		||||
 | 
			
		||||
{- Configures how to build an import tree. -}
 | 
			
		||||
| 
						 | 
				
			
			@ -617,16 +616,31 @@ makeImportMatcher r = load preferredContentKeylessTokens >>= \case
 | 
			
		|||
  where
 | 
			
		||||
	load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t
 | 
			
		||||
 | 
			
		||||
wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool
 | 
			
		||||
wantImport matcher loc sz = checkMatcher' matcher mi mempty
 | 
			
		||||
{- Gets the ImportableContents from the remote.
 | 
			
		||||
 -
 | 
			
		||||
 - Filters out any paths that include a ".git" component, because git does
 | 
			
		||||
 - not allow storing ".git" in a git repository. While it is possible to
 | 
			
		||||
 - write a git tree that contains that, git will complain and refuse to
 | 
			
		||||
 - check it out.
 | 
			
		||||
 -
 | 
			
		||||
 - Filters out things not matching the FileMatcher.
 | 
			
		||||
 -}
 | 
			
		||||
getImportableContents :: Remote -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 | 
			
		||||
getImportableContents r matcher = 
 | 
			
		||||
	Remote.listImportableContents (Remote.importActions r) >>= \case
 | 
			
		||||
		Nothing -> return Nothing
 | 
			
		||||
		Just importable -> do
 | 
			
		||||
			dbhandle <- Export.openDb (Remote.uuid r)
 | 
			
		||||
			Just <$> filterunwanted dbhandle importable
 | 
			
		||||
  where
 | 
			
		||||
	mi = MatchingInfo $ ProvidedInfo
 | 
			
		||||
		{ providedFilePath = fromImportLocation loc
 | 
			
		||||
		, providedKey = Nothing
 | 
			
		||||
		, providedFileSize = sz
 | 
			
		||||
		, providedMimeType = Nothing
 | 
			
		||||
		, providedMimeEncoding = Nothing
 | 
			
		||||
		}
 | 
			
		||||
	filterunwanted dbhandle ic = ImportableContents
 | 
			
		||||
		<$> filterM (wanted dbhandle) (importableContents ic)
 | 
			
		||||
		<*> mapM (filterunwanted dbhandle) (importableHistory ic)
 | 
			
		||||
	
 | 
			
		||||
	wanted dbhandle (loc, (_cid, sz))
 | 
			
		||||
		| ".git" `elem` Posix.splitDirectories (fromImportLocation loc) =
 | 
			
		||||
			pure False
 | 
			
		||||
		| otherwise = shouldImport dbhandle matcher loc sz
 | 
			
		||||
 | 
			
		||||
{- If a file is not preferred content, but it was previously exported or
 | 
			
		||||
 - imported to the remote, not importing it would result in a remote
 | 
			
		||||
| 
						 | 
				
			
			@ -641,34 +655,13 @@ shouldImport dbhandle matcher loc sz =
 | 
			
		|||
		<||>
 | 
			
		||||
	liftIO (not . null <$> Export.getExportTreeKey dbhandle loc)
 | 
			
		||||
 | 
			
		||||
filterImportableContents :: Remote -> FileMatcher Annex -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (ImportableContents (ContentIdentifier, ByteSize))
 | 
			
		||||
filterImportableContents r matcher importable
 | 
			
		||||
	| Utility.Matcher.isEmpty matcher = return importable
 | 
			
		||||
	| otherwise = do
 | 
			
		||||
		dbhandle <- Export.openDb (Remote.uuid r)
 | 
			
		||||
		go dbhandle importable
 | 
			
		||||
wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool
 | 
			
		||||
wantImport matcher loc sz = checkMatcher' matcher mi mempty
 | 
			
		||||
  where
 | 
			
		||||
	go dbhandle ic = ImportableContents
 | 
			
		||||
		<$> filterM (match dbhandle) (importableContents ic)
 | 
			
		||||
		<*> mapM (go dbhandle) (importableHistory ic)
 | 
			
		||||
	
 | 
			
		||||
	match dbhandle (loc, (_cid, sz)) = shouldImport dbhandle matcher loc sz
 | 
			
		||||
	
 | 
			
		||||
{- Gets the ImportableContents from the remote.
 | 
			
		||||
 -
 | 
			
		||||
 - Filters out any paths that include a ".git" component, because git does
 | 
			
		||||
 - not allow storing ".git" in a git repository. While it is possible to
 | 
			
		||||
 - write a git tree that contains that, git will complain and refuse to
 | 
			
		||||
 - check it out.
 | 
			
		||||
 -}
 | 
			
		||||
listImportableContents :: Remote -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
 | 
			
		||||
listImportableContents r = fmap removegitspecial
 | 
			
		||||
	<$> Remote.listImportableContents (Remote.importActions r)
 | 
			
		||||
  where
 | 
			
		||||
	removegitspecial ic = ImportableContents
 | 
			
		||||
		{ importableContents = 
 | 
			
		||||
			filter (not . gitspecial . fst) (importableContents ic)
 | 
			
		||||
		, importableHistory =
 | 
			
		||||
			map removegitspecial (importableHistory ic)
 | 
			
		||||
	mi = MatchingInfo $ ProvidedInfo
 | 
			
		||||
		{ providedFilePath = fromImportLocation loc
 | 
			
		||||
		, providedKey = Nothing
 | 
			
		||||
		, providedFileSize = sz
 | 
			
		||||
		, providedMimeType = Nothing
 | 
			
		||||
		, providedMimeEncoding = Nothing
 | 
			
		||||
		}
 | 
			
		||||
	gitspecial l = ".git" `elem` Posix.splitDirectories (fromRawFilePath (fromImportLocation l))
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -307,15 +307,18 @@ seekRemote remote branch msubdir importcontent = do
 | 
			
		|||
 | 
			
		||||
listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart
 | 
			
		||||
listContents remote tvar = starting "list" ai si $
 | 
			
		||||
	listImportableContents remote >>= \case
 | 
			
		||||
		Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
 | 
			
		||||
		Just importable -> do
 | 
			
		||||
			importable' <- makeImportMatcher remote >>= \case
 | 
			
		||||
				Right matcher -> filterImportableContents remote matcher importable
 | 
			
		||||
				Left err -> giveup $ "Cannot import from " ++ Remote.name remote ++ " because of a problem with its configuration: " ++ err
 | 
			
		||||
			next $ do
 | 
			
		||||
				liftIO $ atomically $ writeTVar tvar (Just importable')
 | 
			
		||||
	makeImportMatcher remote >>= \case
 | 
			
		||||
		Right matcher -> getImportableContents remote matcher >>= \case
 | 
			
		||||
			Just importable -> next $ do
 | 
			
		||||
				liftIO $ atomically $ writeTVar tvar (Just importable)
 | 
			
		||||
				return True
 | 
			
		||||
			Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
 | 
			
		||||
		Left err -> giveup $ unwords 
 | 
			
		||||
			[ "Cannot import from"
 | 
			
		||||
			, Remote.name remote
 | 
			
		||||
			, "because of a problem with its configuration:"
 | 
			
		||||
			, err
 | 
			
		||||
			]
 | 
			
		||||
  where
 | 
			
		||||
	ai = ActionItemOther (Just (Remote.name remote))
 | 
			
		||||
	si = SeekInput []
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue