diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -66,13 +66,13 @@ import Types.DesktopNotify import Types.CleanupActions import Types.AdjustedBranch +import Types.WorkerPool import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url import "mtl" Control.Monad.Reader import Control.Concurrent -import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Monad.Fail as Fail import qualified Data.Map.Strict as M @@ -142,7 +142,7 @@ , tempurls :: M.Map Key URLString , existinghooks :: M.Map Git.Hook.Hook Bool , desktopnotify :: DesktopNotify - , workers :: [Either AnnexState (Async AnnexState)] + , workers :: WorkerPool AnnexState , activekeys :: TVar (M.Map Key ThreadId) , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) , keysdbhandle :: Maybe Keys.DbHandle @@ -199,7 +199,7 @@ , tempurls = M.empty , existinghooks = M.empty , desktopnotify = mempty - , workers = [] + , workers = UnallocatedWorkerPool , activekeys = emptyactivekeys , activeremotes = emptyactiveremotes , keysdbhandle = Nothing diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -265,7 +265,12 @@ adjustTree :: Adjustment -> BasisBranch -> Annex Sha adjustTree adj (BasisBranch basis) = do let toadj = adjustTreeItem adj - treesha <- Git.Tree.adjustTree toadj [] [] basis =<< Annex.gitRepo + treesha <- Git.Tree.adjustTree + toadj + [] + (\_old new -> new) + [] + basis =<< Annex.gitRepo return treesha type CommitsPrevented = Git.LockFile.LockHandle @@ -544,6 +549,7 @@ treesha <- Git.Tree.adjustTree (propchanges changes) adds' + (\_old new -> new) (map Git.DiffTree.file removes) basis =<< Annex.gitRepo diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -11,6 +11,7 @@ import Annex.Common import Annex.Action import qualified Annex.Queue +import Types.WorkerPool import qualified Data.Map as M @@ -42,7 +43,7 @@ dupState = do st <- Annex.getState id return $ st - { Annex.workers = [] + { Annex.workers = UnallocatedWorkerPool -- each thread has its own repoqueue , Annex.repoqueue = Nothing -- avoid sharing eg, open file handles diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -125,10 +125,12 @@ ) dropl fs n = checkdrop fs n Nothing $ \numcopies -> - Command.Drop.startLocal afile (mkActionItem afile) numcopies key preverified + Command.Drop.startLocal afile ai numcopies key preverified dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote afile (mkActionItem afile) numcopies key r + Command.Drop.startRemote afile ai numcopies key r + + ai = mkActionItem (key, afile) slocs = S.fromList locs diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matching - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,8 +12,13 @@ checkFileMatcher, checkFileMatcher', checkMatcher, + checkMatcher', matchAll, + PreferredContentData(..), + preferredContentTokens, + preferredContentKeylessTokens, preferredContentParser, + ParseToken, parsedToMatcher, mkLargeFilesParser, largeFilesMatcher, @@ -59,8 +64,12 @@ (Just key, _) -> go (MatchingKey key afile) _ -> d where - go mi = matchMrun matcher $ \a -> a notpresent mi + go mi = checkMatcher' matcher mi notpresent +checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool +checkMatcher' matcher mi notpresent = + matchMrun matcher $ \a -> a notpresent mi + fileMatchInfo :: FilePath -> Annex MatchInfo fileMatchInfo file = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) @@ -72,21 +81,21 @@ matchAll :: FileMatcher Annex matchAll = generate [] -parsedToMatcher :: [ParseResult] -> Either String (FileMatcher Annex) +parsedToMatcher :: [ParseResult (MatchFiles Annex)] -> Either String (FileMatcher Annex) parsedToMatcher parsed = case partitionEithers parsed of ([], vs) -> Right $ generate vs (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es -data ParseToken - = SimpleToken String ParseResult - | ValueToken String (String -> ParseResult) +data ParseToken t + = SimpleToken String (ParseResult t) + | ValueToken String (String -> ParseResult t) -type ParseResult = Either String (Token (MatchFiles Annex)) +type ParseResult t = Either String (Token t) -parseToken :: [ParseToken] -> String -> ParseResult -parseToken l t - | t `elem` tokens = Right $ token t - | otherwise = go l +parseToken :: [ParseToken t] -> String -> ParseResult t +parseToken l t = case syntaxToken t of + Right st -> Right st + Left _ -> go l where go [] = Left $ "near " ++ show t go (SimpleToken s r : _) | s == t = r @@ -94,10 +103,17 @@ go (_ : ps) = go ps (k, v) = separate (== '=') t -commonTokens :: [ParseToken] -commonTokens = - [ SimpleToken "unused" (simply limitUnused) - , SimpleToken "anything" (simply limitAnything) +{- This is really dumb tokenization; there's no support for quoted values. + - Open and close parens are always treated as standalone tokens; + - otherwise tokens must be separated by whitespace. -} +tokenizeMatcher :: String -> [String] +tokenizeMatcher = filter (not . null) . concatMap splitparens . words + where + splitparens = segmentDelim (`elem` "()") + +commonKeylessTokens :: [ParseToken (MatchFiles Annex)] +commonKeylessTokens = + [ SimpleToken "anything" (simply limitAnything) , SimpleToken "nothing" (simply limitNothing) , ValueToken "include" (usev limitInclude) , ValueToken "exclude" (usev limitExclude) @@ -105,35 +121,57 @@ , ValueToken "smallerthan" (usev $ limitSize (<)) ] -{- This is really dumb tokenization; there's no support for quoted values. - - Open and close parens are always treated as standalone tokens; - - otherwise tokens must be separated by whitespace. -} -tokenizeMatcher :: String -> [String] -tokenizeMatcher = filter (not . null ) . concatMap splitparens . words - where - splitparens = segmentDelim (`elem` "()") +commonKeyedTokens :: [ParseToken (MatchFiles Annex)] +commonKeyedTokens = + [ SimpleToken "unused" (simply limitUnused) + ] -preferredContentParser :: FileMatcher Annex -> FileMatcher Annex -> Annex GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [ParseResult] -preferredContentParser matchstandard matchgroupwanted getgroupmap configmap mu expr = - map parse $ tokenizeMatcher expr +data PreferredContentData = PCD + { matchStandard :: Either String (FileMatcher Annex) + , matchGroupWanted :: Either String (FileMatcher Annex) + , getGroupMap :: Annex GroupMap + , configMap :: M.Map UUID RemoteConfig + , repoUUID :: Maybe UUID + } + +-- Tokens of preferred content expressions that do not need a Key to be +-- known. +-- +-- When importing from a special remote, this is used to match +-- some preferred content expressions before the content is downloaded, +-- so the Key is not known. +preferredContentKeylessTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] +preferredContentKeylessTokens pcd = + [ SimpleToken "standard" (call $ matchStandard pcd) + , SimpleToken "groupwanted" (call $ matchGroupWanted pcd) + , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir) + ] ++ commonKeylessTokens where - parse = parseToken $ - [ SimpleToken "standard" (call matchstandard) - , SimpleToken "groupwanted" (call matchgroupwanted) - , SimpleToken "present" (simply $ limitPresent mu) - , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir) - , SimpleToken "securehash" (simply limitSecureHash) - , ValueToken "copies" (usev limitCopies) - , ValueToken "lackingcopies" (usev $ limitLackingCopies False) - , ValueToken "approxlackingcopies" (usev $ limitLackingCopies True) - , ValueToken "inbacked" (usev limitInBackend) - , ValueToken "metadata" (usev limitMetaData) - , ValueToken "inallgroup" (usev $ limitInAllGroup getgroupmap) - ] ++ commonTokens preferreddir = fromMaybe "public" $ - M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + M.lookup "preferreddir" =<< (`M.lookup` configMap pcd) =<< repoUUID pcd -mkLargeFilesParser :: Annex (String -> [ParseResult]) +preferredContentKeyedTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] +preferredContentKeyedTokens pcd = + [ SimpleToken "present" (simply $ limitPresent $ repoUUID pcd) + , SimpleToken "securehash" (simply limitSecureHash) + , ValueToken "copies" (usev limitCopies) + , ValueToken "lackingcopies" (usev $ limitLackingCopies False) + , ValueToken "approxlackingcopies" (usev $ limitLackingCopies True) + , ValueToken "inbacked" (usev limitInBackend) + , ValueToken "metadata" (usev limitMetaData) + , ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd) + ] ++ commonKeyedTokens + +preferredContentTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] +preferredContentTokens pcd = concat + [ preferredContentKeylessTokens pcd + , preferredContentKeyedTokens pcd + ] + +preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)] +preferredContentParser tokens = map (parseToken tokens) . tokenizeMatcher + +mkLargeFilesParser :: Annex (String -> [ParseResult (MatchFiles Annex)]) mkLargeFilesParser = do magicmime <- liftIO initMagicMime #ifdef WITH_MAGICMIME @@ -142,7 +180,7 @@ let mimer n = ValueToken n $ const $ Left $ "\""++n++"\" not supported; not built with MagicMime support" #endif - let parse = parseToken $ commonTokens ++ + let parse = parseToken $ commonKeyedTokens ++ commonKeylessTokens ++ #ifdef WITH_MAGICMIME [ mimer "mimetype" $ matchMagic "mimetype" getMagicMimeType providedMimeType @@ -176,12 +214,13 @@ either badexpr return $ parsedToMatcher $ parser expr badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e -simply :: MatchFiles Annex -> ParseResult +simply :: MatchFiles Annex -> ParseResult (MatchFiles Annex) simply = Right . Operation -usev :: MkLimit Annex -> String -> ParseResult +usev :: MkLimit Annex -> String -> ParseResult (MatchFiles Annex) usev a v = Operation <$> a v -call :: FileMatcher Annex -> ParseResult -call sub = Right $ Operation $ \notpresent mi -> +call :: Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex) +call (Right sub) = Right $ Operation $ \notpresent mi -> matchMrun sub $ \a -> a notpresent mi +call (Left err) = Left err diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -13,7 +13,10 @@ ImportCommitConfig(..), buildImportCommit, buildImportTrees, - downloadImport + downloadImport, + filterImportableContents, + makeImportMatcher, + listImportableContents, ) where import Annex.Common @@ -41,6 +44,10 @@ import Utility.DataUnits import Logs.Export import Logs.Location +import Logs.PreferredContent +import Types.FileMatcher +import Annex.FileMatcher +import Utility.Matcher (isEmpty) import qualified Database.Export as Export import qualified Database.ContentIdentifier as CIDDb import qualified Logs.ContentIdentifier as CIDLog @@ -48,6 +55,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S +import qualified System.FilePath.Posix as Posix {- Configures how to build an import tree. -} data ImportTreeConfig @@ -103,7 +111,7 @@ go trackingcommit = do imported@(History finaltree _) <- buildImportTrees basetree subdir importable - buildImportCommit' importcommitconfig trackingcommit imported >>= \case + buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case Just finalcommit -> do updatestate finaltree return (Just finalcommit) @@ -160,54 +168,66 @@ Export.runExportDiffUpdater updater db oldtree finaltree Export.closeDb db -buildImportCommit' :: ImportCommitConfig -> Maybe Sha -> History Sha -> Annex (Maybe Sha) -buildImportCommit' importcommitconfig mtrackingcommit imported@(History ti _) = +buildImportCommit' :: Remote -> ImportCommitConfig -> Maybe Sha -> History Sha -> Annex (Maybe Sha) +buildImportCommit' remote importcommitconfig mtrackingcommit imported@(History ti _) = case mtrackingcommit of - Nothing -> Just <$> mkcommits imported + Nothing -> Just <$> mkcommitsunconnected imported Just trackingcommit -> do -- Get history of tracking branch to at most -- one more level deep than what was imported, -- so we'll have enough history to compare, -- but not spend too much time getting it. - let maxdepth = succ (historyDepth imported) + let maxdepth = succ importeddepth inRepo (getHistoryToDepth maxdepth trackingcommit) >>= go trackingcommit where - go _ Nothing = Just <$> mkcommits imported + go _ Nothing = Just <$> mkcommitsunconnected imported go trackingcommit (Just h) -- If the tracking branch head is a merge commit - -- with a tree that matches the head of the history, -- and one side of the merge matches the history, -- nothing new needs to be committed. - | t == ti && any (sametodepth imported) (S.toList s) = return Nothing + | t == ti && any sametodepth (S.toList s) = return Nothing -- If the tracking branch matches the history, -- nothing new needs to be committed. -- (This is unlikely to happen.) - | sametodepth imported h' = return Nothing + | sametodepth h' = return Nothing | otherwise = do importedcommit <- case getRemoteTrackingBranchImportHistory h of - Nothing -> - mkcommits imported - Just oldimported@(History oldhc _) -> do - let oldimportedtrees = mapHistory historyCommitTree oldimported - mknewcommits oldhc oldimportedtrees imported + Nothing -> mkcommitsunconnected imported + Just oldimported@(History oldhc _) + | importeddepth == 1 -> + mkcommitconnected imported oldimported + | otherwise -> do + let oldimportedtrees = mapHistory historyCommitTree oldimported + mknewcommits oldhc oldimportedtrees imported + ti' <- addBackExportExcluded remote ti Just <$> makeRemoteTrackingBranchMergeCommit' - trackingcommit importedcommit ti + trackingcommit importedcommit ti' where h'@(History t s) = mapHistory historyCommitTree h - sametodepth a b = a == truncateHistoryToDepth (historyDepth a) b + importeddepth = historyDepth imported + sametodepth b = imported == truncateHistoryToDepth importeddepth b + mkcommit parents tree = inRepo $ Git.Branch.commitTree (importCommitMode importcommitconfig) (importCommitMessage importcommitconfig) parents tree - mkcommits (History importedtree hs) = do - parents <- mapM mkcommits (S.toList hs) + -- Start a new history of import commits, not connected to any + -- prior import commits. + mkcommitsunconnected (History importedtree hs) = do + parents <- mapM mkcommitsunconnected (S.toList hs) mkcommit parents importedtree + -- Commit the new history connected with the old history. + -- Used when the import is not versioned, so the history depth is 1. + mkcommitconnected (History importedtree _) (History oldhc _) = do + let parents = [historyCommit oldhc] + mkcommit parents importedtree + -- Reuse the commits from the old imported History when possible. mknewcommits oldhc old new@(History importedtree hs) | old == new = return $ historyCommit oldhc @@ -380,3 +400,104 @@ , keyVariety = OtherKey "CID" , keySize = Just size } + +{-- Export omits non-preferred content from the tree stored on the + -- remote. So the import will normally have that content + -- omitted (unless something else added files with the same names to the + -- special remote). + -- + -- That presents a problem: Merging the imported tree would result + -- in deletion of the files that were excluded from export. + -- To avoid that happening, this adds them back to the imported tree. + --} +addBackExportExcluded :: Remote -> Sha -> Annex Sha +addBackExportExcluded remote importtree = + getExportExcluded (Remote.uuid remote) >>= \case + [] -> return importtree + excludedlist -> inRepo $ + adjustTree + -- don't remove any + (pure . Just) + excludedlist + -- if something was imported with the same + -- name as a file that was previously + -- excluded from import, use what was imported + (\imported _excluded -> imported) + [] + importtree + +{- Match the preferred content of the remote at import time. + - + - Only keyless tokens are supported, because the keys are not known + - until an imported file is downloaded, which is too late to bother + - excluding it from an import. + -} +makeImportMatcher :: Remote -> Annex (Either String (FileMatcher Annex)) +makeImportMatcher r = load preferredContentKeylessTokens >>= \case + Nothing -> return $ Right matchAll + Just (Right v) -> return $ Right v + Just (Left err) -> load preferredContentTokens >>= \case + Just (Left err') -> return $ Left err' + _ -> return $ Left $ + "The preferred content expression contains terms that cannot be checked when importing: " ++ err + 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 + where + mi = MatchingInfo $ ProvidedInfo + { providedFilePath = Right $ fromImportLocation loc + , providedKey = unavail "key" + , providedFileSize = Right sz + , providedMimeType = unavail "mime" + , providedMimeEncoding = unavail "mime" + } + -- This should never run, as long as the FileMatcher was generated + -- using the preferredContentKeylessTokens. + unavail v = Left $ error $ "Internal error: unavailable " ++ v + +{- 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 + - tracking branch that, when merged, would delete the file. + - + - To avoid that problem, such files are included in the import. + - The next export will remove them from the remote. + -} +shouldImport :: Export.ExportHandle -> FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool +shouldImport dbhandle matcher loc sz = + wantImport 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 + | isEmpty matcher = return importable + | otherwise = do + dbhandle <- Export.openDb (Remote.uuid r) + go dbhandle importable + 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) + } + gitspecial l = ".git" `elem` Posix.splitDirectories (fromImportLocation l) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -30,7 +30,6 @@ import Annex.Content import Annex.Content.Direct import Annex.Perms -import Annex.Tmp import Annex.Link import Annex.MetaData import Annex.CurrentBranch @@ -58,8 +57,10 @@ deriving (Show) data LockDownConfig = LockDownConfig - { lockingFile :: Bool -- ^ write bit removed during lock down - , hardlinkFileTmp :: Bool -- ^ hard link to temp directory + { lockingFile :: Bool + -- ^ write bit removed during lock down + , hardlinkFileTmpDir :: Maybe FilePath + -- ^ hard link to temp directory } deriving (Show) @@ -83,27 +84,35 @@ =<< lockDown' cfg file lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown) -lockDown' cfg file = ifM (pure (not (hardlinkFileTmp cfg)) <||> crippledFileSystem) - ( withTSDelta $ liftIO . tryIO . nohardlink - , tryIO $ withOtherTmp $ \tmp -> do - when (lockingFile cfg) $ - freezeContent file - withTSDelta $ \delta -> liftIO $ do - (tmpfile, h) <- openTempFile tmp $ - relatedTemplate $ "ingest-" ++ takeFileName file - hClose h - nukeFile tmpfile - withhardlink delta tmpfile `catchIO` const (nohardlink delta) +lockDown' cfg file = tryIO $ ifM crippledFileSystem + ( nohardlink + , case hardlinkFileTmpDir cfg of + Nothing -> nohardlink + Just tmpdir -> withhardlink tmpdir ) where - nohardlink delta = do + nohardlink = withTSDelta $ liftIO . nohardlink' + + nohardlink' delta = do cache <- genInodeCache file delta return $ LockedDown cfg $ KeySource { keyFilename = file , contentLocation = file , inodeCache = cache } - withhardlink delta tmpfile = do + + withhardlink tmpdir = do + when (lockingFile cfg) $ + freezeContent file + withTSDelta $ \delta -> liftIO $ do + (tmpfile, h) <- openTempFile tmpdir $ + relatedTemplate $ "ingest-" ++ takeFileName file + hClose h + nukeFile tmpfile + withhardlink' delta tmpfile + `catchIO` const (nohardlink' delta) + + withhardlink' delta tmpfile = do createLink file tmpfile cache <- genInodeCache tmpfile delta return $ LockedDown cfg $ KeySource diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -1,6 +1,6 @@ {- git-annex repository initialization - - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -43,15 +43,17 @@ import Annex.Hook import Annex.InodeSentinal import Upgrade -import Annex.Perms import Annex.Tmp import Utility.UserInfo #ifndef mingw32_HOST_OS +import Annex.Perms import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix #endif +import qualified Data.Map as M + checkCanInitialize :: Annex a -> Annex a checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case Nothing -> a @@ -88,7 +90,10 @@ initSharedClone sharedclone u <- getUUID - describeUUID u =<< genDescription mdescription + {- Avoid overwriting existing description with a default + - description. -} + whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMap) $ + describeUUID u =<< genDescription mdescription -- Everything except for uuid setup, shared clone setup, and initial -- description. diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -31,6 +31,7 @@ gitAnnexTmpOtherDir, gitAnnexTmpOtherLock, gitAnnexTmpOtherDirOld, + gitAnnexTmpWatcherDir, gitAnnexTmpObjectDir, gitAnnexTmpObjectLocation, gitAnnexTmpWorkDir, @@ -49,6 +50,7 @@ gitAnnexExportDbDir, gitAnnexExportLock, gitAnnexExportUpdateLock, + gitAnnexExportExcludeLog, gitAnnexContentIdentifierDbDir, gitAnnexContentIdentifierLock, gitAnnexScheduleState, @@ -264,10 +266,14 @@ gitAnnexTmpOtherLock :: Git.Repo -> FilePath gitAnnexTmpOtherLock r = gitAnnexDir r "othertmp.lck" -{- Directory used by old versions of git-annex. -} +{- Tmp directory used by old versions of git-annex. -} gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ gitAnnexDir r "misctmp" +{- .git/annex/watchtmp/ is used by the watcher and assistant -} +gitAnnexTmpWatcherDir :: Git.Repo -> FilePath +gitAnnexTmpWatcherDir r = addTrailingPathSeparator $ gitAnnexDir r "watchtmp" + {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r keyFile key @@ -355,6 +361,11 @@ {- Lock file for updating the export state for a special remote. -} gitAnnexExportUpdateLock :: UUID -> Git.Repo -> FilePath gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl" + +{- Log file used to keep track of files that were in the tree exported to a + - remote, but were excluded by its preferred content settings. -} +gitAnnexExportExcludeLog :: UUID -> Git.Repo -> FilePath +gitAnnexExportExcludeLog u r = gitAnnexDir r "export.ex" fromUUID u {- Directory containing database used to record remote content ids. - diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -12,7 +12,9 @@ import Annex.Common import Annex.Tmp import Utility.Tmp.Dir +#ifndef mingw32_HOST_OS import Utility.Path.Max +#endif {- Replaces a possibly already existing file with a new version, - atomically, by running an action. diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -189,8 +189,9 @@ let socketlock = socket2lock socketfile Annex.getState Annex.concurrency >>= \case + NonConcurrent -> return () Concurrent {} -> makeconnection socketlock - _ -> return () + ConcurrentPerCpu -> makeconnection socketlock lockFileCached socketlock where diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -247,20 +247,29 @@ where go [] _ = return observeFailure go (r:[]) _ = a r - go rs (Concurrent n) | n > 1 = do - mv <- Annex.getState Annex.activeremotes - active <- liftIO $ takeMVar mv - let rs' = sortBy (lessActiveFirst active) rs - goconcurrent mv active rs' - go (r:rs) _ = do + go rs NonConcurrent = gononconcurrent rs + go rs (Concurrent n) + | n <= 1 = gononconcurrent rs + | otherwise = goconcurrent rs + go rs ConcurrentPerCpu = goconcurrent rs + + gononconcurrent [] = return observeFailure + gononconcurrent (r:rs) = do ok <- a r if observeBool ok then return ok - else go rs NonConcurrent - goconcurrent mv active [] = do + else gononconcurrent rs + + goconcurrent rs = do + mv <- Annex.getState Annex.activeremotes + active <- liftIO $ takeMVar mv + let rs' = sortBy (lessActiveFirst active) rs + goconcurrent' mv active rs' + + goconcurrent' mv active [] = do liftIO $ putMVar mv active return observeFailure - goconcurrent mv active (r:rs) = do + goconcurrent' mv active (r:rs) = do let !active' = M.insertWith (+) r 1 active liftIO $ putMVar mv active' let getnewactive = do @@ -279,7 +288,7 @@ -- because other threads could have -- been assigned them in the meantime. let rs' = sortBy (lessActiveFirst active'') rs - goconcurrent mv active'' rs' + goconcurrent' mv active'' rs' lessActiveFirst :: M.Map Remote Integer -> Remote -> Remote -> Ordering lessActiveFirst active a b diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -11,7 +11,7 @@ withUrlOptions, getUrlOptions, getUserAgent, - httpAddressesUnlimited, + ipAddressesUnlimited, ) where import Annex.Common @@ -52,14 +52,15 @@ Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) Nothing -> annexHttpHeaders <$> Annex.getGitConfig - checkallowedaddr = words . annexAllowedHttpAddresses <$> Annex.getGitConfig >>= \case + checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case ["all"] -> do -- Only allow curl when all are allowed, -- as its interface does not allow preventing -- it from accessing specific IP addresses. curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig let urldownloader = if null curlopts - then U.DownloadWithConduit + then U.DownloadWithConduit $ + U.DownloadWithCurlRestricted mempty else U.DownloadWithCurl curlopts manager <- liftIO $ U.newManager U.managerSettings return (urldownloader, manager) @@ -76,9 +77,9 @@ | isPrivateAddress addr = False | otherwise = True let connectionrestricted = addrConnectionRestricted - ("Configuration of annex.security.allowed-http-addresses does not allow accessing address " ++) + ("Configuration of annex.security.allowed-ip-addresses does not allow accessing address " ++) let r = Restriction - { addressRestriction = \addr -> + { checkAddressRestriction = \addr -> if isallowed (addrAddress addr) then Nothing else Just (connectionrestricted addr) @@ -88,13 +89,15 @@ case pr of Nothing -> return () Just ProxyRestricted -> toplevelWarning True - "http proxy settings not used due to annex.security.allowed-http-addresses configuration" + "http proxy settings not used due to annex.security.allowed-ip-addresses configuration" manager <- liftIO $ U.newManager settings - return (U.DownloadWithConduit, manager) + let urldownloader = U.DownloadWithConduit $ + U.DownloadWithCurlRestricted r + return (urldownloader, manager) -httpAddressesUnlimited :: Annex Bool -httpAddressesUnlimited = - ("all" == ) . annexAllowedHttpAddresses <$> Annex.getGitConfig +ipAddressesUnlimited :: Annex Bool +ipAddressesUnlimited = + ("all" == ) . annexAllowedIPAddresses <$> Annex.getGitConfig withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptions a = a =<< getUrlOptions diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -31,13 +31,13 @@ -- localhost or a private address. So, it's only allowed to download -- content if the user has allowed access to all addresses. youtubeDlAllowed :: Annex Bool -youtubeDlAllowed = httpAddressesUnlimited +youtubeDlAllowed = ipAddressesUnlimited youtubeDlNotAllowedMessage :: String youtubeDlNotAllowedMessage = unwords [ "This url is supported by youtube-dl, but" , "youtube-dl could potentially access any address, and the" - , "configuration of annex.security.allowed-http-addresses" + , "configuration of annex.security.allowed-ip-addresses" , "does not allow that. Not using youtube-dl." ] @@ -55,7 +55,7 @@ -- (Note that we can't use --output to specifiy the file to download to, -- due to ) youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath)) -youtubeDl url workdir = ifM httpAddressesUnlimited +youtubeDl url workdir = ifM ipAddressesUnlimited ( withUrlOptions $ youtubeDl' url workdir , return $ Left youtubeDlNotAllowedMessage ) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -1,6 +1,6 @@ {- git-annex assistant commit thread - - - Copyright 2012 Joey Hess + - Copyright 2012, 2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,7 +29,7 @@ import Annex.Content import Annex.Ingest import Annex.Link -import Annex.Tmp +import Annex.Perms import Annex.CatFile import Annex.InodeSentinal import Annex.Version @@ -56,8 +56,14 @@ maybe delayaddDefault (return . Just . Seconds) =<< annexDelayAdd <$> Annex.getGitConfig msg <- liftAnnex Command.Sync.commitMsg + lockdowndir <- liftAnnex $ fromRepo gitAnnexTmpWatcherDir + liftAnnex $ do + -- Clean up anything left behind by a previous process + -- on unclean shutdown. + void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir + void $ createAnnexDirectory lockdowndir waitChangeTime $ \(changes, time) -> do - readychanges <- handleAdds havelsof delayadd $ + readychanges <- handleAdds lockdowndir havelsof delayadd $ simplifyChanges changes if shouldCommit False time (length readychanges) readychanges then do @@ -265,21 +271,21 @@ - Any pending adds that are not ready yet are put back into the ChangeChan, - where they will be retried later. -} -handleAdds :: Bool -> Maybe Seconds -> [Change] -> Assistant [Change] -handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do +handleAdds :: FilePath -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do let (pending, inprocess) = partition isPendingAddChange incomplete direct <- liftAnnex isDirect unlocked <- liftAnnex versionSupportsUnlockedPointers let lockingfiles = not (unlocked || direct) let lockdownconfig = LockDownConfig { lockingFile = lockingfiles - , hardlinkFileTmp = True + , hardlinkFileTmpDir = Just lockdowndir } (pending', cleanup) <- if unlocked || direct then return (pending, noop) else findnew pending (postponed, toadd) <- partitionEithers - <$> safeToAdd lockdownconfig havelsof delayadd pending' inprocess + <$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending' inprocess cleanup unless (null postponed) $ @@ -294,7 +300,7 @@ if DirWatcher.eventsCoalesce || null added || unlocked || direct then return $ added ++ otherchanges else do - r <- handleAdds havelsof delayadd =<< getChanges + r <- handleAdds lockdowndir havelsof delayadd =<< getChanges return $ r ++ added ++ otherchanges where (incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs @@ -341,7 +347,7 @@ delta <- liftAnnex getTSDelta let cfg = LockDownConfig { lockingFile = False - , hardlinkFileTmp = True + , hardlinkFileTmpDir = Just lockdowndir } if M.null m then forM toadd (add cfg) @@ -429,9 +435,9 @@ - - Check by running lsof on the repository. -} -safeToAdd :: LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] -safeToAdd _ _ _ [] [] = return [] -safeToAdd lockdownconfig havelsof delayadd pending inprocess = do +safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] +safeToAdd _ _ _ _ [] [] = return [] +safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do maybe noop (liftIO . threadDelaySeconds) delayadd liftAnnex $ do lockeddown <- forM pending $ lockDown lockdownconfig . changeFile @@ -478,7 +484,7 @@ allRight = return . map Right - {- Normally the KeySources are locked down inside the temp directory, + {- Normally the KeySources are locked down inside the lockdowndir, - so can just lsof that, which is quite efficient. - - In crippled filesystem mode, there is no lock down, so must run lsof @@ -488,7 +494,7 @@ ( liftIO $ do let segments = segmentXargsUnordered $ map keyFilename keysources concat <$> forM segments (\fs -> Lsof.query $ "--" : fs) - , withOtherTmp $ liftIO . Lsof.queryDir + , liftIO $ Lsof.queryDir lockdowndir ) {- After a Change is committed, queue any necessary transfers or drops diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -23,6 +23,7 @@ import Git.Types import Git.FilePath import qualified Annex.Branch +import Annex.FileMatcher import qualified Data.Set as S @@ -73,7 +74,7 @@ reloadConfigs :: Configs -> Assistant () reloadConfigs changedconfigs = do sequence_ as - void $ liftAnnex preferredRequiredMapsLoad + void $ liftAnnex $ preferredRequiredMapsLoad preferredContentTokens {- Changes to the remote log, or the trust log, can affect the - syncRemotes list. Changes to the uuid log may affect its - display so are also included. -} diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,41 @@ +git-annex (7.20190615) upstream; urgency=medium + + * Fixed bug that caused git-annex to fail to add a file when another + git-annex process cleaned up the temp directory it was using. + * Makefile: Added install-completions to install target. + * Added the ability to run one job per CPU (core), by setting + annex.jobs=cpus, or using option --jobs=cpus or -Jcpus. + * Honor preferred content of a special remote when exporting trees to it; + unwanted files are filtered out of the tree that is exported. + * Importing from a special remote honors its preferred content too; + unwanted files are not imported. But, some preferred content + expressions can't be checked before files are imported, and trying to + import with such an expression will fail. + * Don't try to import .git directories from special remotes, because + git does not support storing git repositories inside a git repository. + * Improve shape of commit tree when importing from unversioned special + remotes. + * init: When the repository already has a description, don't change it. + * describe: When run with no description parameter it used to set + the description to "", now it will error out. + * Android: Improve installation process when the user's login shell is not + bash. + * When a remote is configured to be readonly, don't allow changing + what's exported to it. + * Renamed annex.security.allowed-http-addresses to + annex.security.allowed-ip-addresses because it is not really specific + to the http protocol, also limiting eg, git-annex's use of ftp. + The old name for the config will still work. + * Add back support for ftp urls, which was disabled as part of the fix for + security hole CVE-2018-10857 (except for configurations which enabled curl + and bypassed public IP address restrictions). Now it will work + if allowed by annex.security.allowed-ip-addresses. + * Avoid a delay at startup when concurrency is enabled and there are + rsync or gcrypt special remotes, which was caused by git-annex + opening a ssh connection to the remote too early. + + -- Joey Hess Sat, 15 Jun 2019 12:38:25 -0400 + git-annex (7.20190507) upstream; urgency=medium * Fix reversion in last release that caused wrong tree to be written diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -16,12 +16,14 @@ import Types.Concurrency import Messages.Concurrent import Types.Messages +import Types.WorkerPool import Remote.List import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception (throwIO) +import GHC.Conc import Data.Either import qualified Data.Map.Strict as M import qualified System.Console.Regions as Regions @@ -51,12 +53,17 @@ - This should only be run in the seek stage. -} commandAction :: CommandStart -> Annex () -commandAction a = go =<< Annex.getState Annex.concurrency +commandAction a = Annex.getState Annex.concurrency >>= \case + NonConcurrent -> run + Concurrent n -> runconcurrent n + ConcurrentPerCpu -> runconcurrent =<< liftIO getNumProcessors where - go (Concurrent n) = do - ws <- Annex.getState Annex.workers - (st, ws') <- if null ws - then do + run = void $ includeCommandAction a + + runconcurrent n = do + ws <- liftIO . drainTo (n-1) =<< Annex.getState Annex.workers + (st, ws') <- case ws of + UnallocatedWorkerPool -> do -- Generate the remote list now, to avoid -- each thread generating it, which would -- be more expensive and could cause @@ -64,15 +71,12 @@ -- setConfig. _ <- remoteList st <- dupState - return (st, replicate (n-1) (Left st)) - else do - l <- liftIO $ drainTo (n-1) ws - findFreeSlot l - w <- liftIO $ async - $ snd <$> Annex.run st (inOwnConsoleRegion (Annex.output st) run) - Annex.changeState $ \s -> s { Annex.workers = Right w:ws' } - go NonConcurrent = run - run = void $ includeCommandAction a + return (st, allocateWorkerPool st (n-1)) + WorkerPool l -> findFreeSlot l + w <- liftIO $ async $ snd <$> Annex.run st + (inOwnConsoleRegion (Annex.output st) run) + Annex.changeState $ \s -> s + { Annex.workers = addWorkerPool ws' (Right w) } commandActions :: [CommandStart] -> Annex () commandActions = mapM_ commandAction @@ -87,42 +91,41 @@ finishCommandActions :: Annex () finishCommandActions = do ws <- Annex.getState Annex.workers - Annex.changeState $ \s -> s { Annex.workers = [] } - l <- liftIO $ drainTo 0 ws - forM_ (lefts l) mergeState + Annex.changeState $ \s -> s { Annex.workers = UnallocatedWorkerPool } + ws' <- liftIO $ drainTo 0 ws + forM_ (idleWorkers ws') mergeState -{- Wait for Asyncs from the list to finish, replacing them with their - - final AnnexStates, until the list of remaining Asyncs is not larger - - than the specified size, then returns the new list. +{- Wait for jobs from the WorkerPool to complete, until + - the number of running jobs is not larger than the specified number. - - - If the action throws an exception, it is propigated, but first - - all other actions are waited for, to allow for a clean shutdown. + - If a job throws an exception, it is propigated, but first + - all other jobs are waited for, to allow for a clean shutdown. -} -drainTo - :: Int - -> [Either Annex.AnnexState (Async Annex.AnnexState)] - -> IO [Either Annex.AnnexState (Async Annex.AnnexState)] -drainTo sz l - | null as || sz >= length as = return l +drainTo :: Int -> WorkerPool t -> IO (WorkerPool t) +drainTo _ UnallocatedWorkerPool = pure UnallocatedWorkerPool +drainTo sz (WorkerPool l) + | null as || sz >= length as = pure (WorkerPool l) | otherwise = do (done, ret) <- waitAnyCatch as let as' = filter (/= done) as case ret of Left e -> do - void $ drainTo 0 (map Left sts ++ map Right as') + void $ drainTo 0 $ WorkerPool $ + map Left sts ++ map Right as' throwIO e Right st -> do - drainTo sz $ map Left (st:sts) ++ map Right as' + drainTo sz $ WorkerPool $ + map Left (st:sts) ++ map Right as' where (sts, as) = partitionEithers l -findFreeSlot :: [Either Annex.AnnexState (Async Annex.AnnexState)] -> Annex (Annex.AnnexState, [Either Annex.AnnexState (Async Annex.AnnexState)]) +findFreeSlot :: [Worker Annex.AnnexState] -> Annex (Annex.AnnexState, WorkerPool Annex.AnnexState) findFreeSlot = go [] where go c [] = do st <- dupState - return (st, c) - go c (Left st:rest) = return (st, c ++ rest) + return (st, WorkerPool c) + go c (Left st:rest) = return (st, WorkerPool (c ++ rest)) go c (v:rest) = go (v:c) rest {- Like commandAction, but without the concurrency. -} @@ -170,18 +173,23 @@ allowConcurrentOutput a = do fromcmdline <- Annex.getState Annex.concurrency fromgitcfg <- annexJobs <$> Annex.getGitConfig + let usegitcfg = Annex.changeState $ + \c -> c { Annex.concurrency = fromgitcfg } case (fromcmdline, fromgitcfg) of (NonConcurrent, NonConcurrent) -> a - (Concurrent n, _) -> goconcurrent n + (Concurrent n, _) -> do + raisecapabilitiesto n + goconcurrent + (ConcurrentPerCpu, _) -> goconcurrent (NonConcurrent, Concurrent n) -> do - Annex.changeState $ - \c -> c { Annex.concurrency = fromgitcfg } - goconcurrent n + usegitcfg + raisecapabilitiesto n + goconcurrent + (NonConcurrent, ConcurrentPerCpu) -> do + usegitcfg + goconcurrent where - goconcurrent n = do - c <- liftIO getNumCapabilities - when (n > c) $ - liftIO $ setNumCapabilities n + goconcurrent = do withMessageState $ \s -> case outputType s of NormalOutput -> ifM (liftIO concurrentOutputSupported) ( Regions.displayConsoleRegions $ @@ -190,13 +198,21 @@ ) _ -> goconcurrent' False goconcurrent' b = bracket_ (setup b) cleanup a + setup = setconcurrentoutputenabled + cleanup = do finishCommandActions setconcurrentoutputenabled False + setconcurrentoutputenabled b = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { concurrentOutputEnabled = b } } + raisecapabilitiesto n = do + c <- liftIO getNumCapabilities + when (n > c) $ + liftIO $ setNumCapabilities n + {- Ensures that only one thread processes a key at a time. - Other threads will block until it's done. -} onlyActionOn :: Key -> CommandStart -> CommandStart @@ -212,7 +228,9 @@ onlyActionOn' k a = go =<< Annex.getState Annex.concurrency where go NonConcurrent = a - go (Concurrent _) = do + go (Concurrent _) = goconcurrent + go ConcurrentPerCpu = goconcurrent + goconcurrent = do tv <- Annex.getState Annex.activekeys bracket (setup tv) id (const a) setup tv = liftIO $ do diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -324,8 +324,8 @@ , shortopt ')' "close group of options" ] where - longopt o h = globalFlag (Limit.addToken o) ( long o <> help h <> hidden ) - shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden ) + longopt o h = globalFlag (Limit.addSyntaxToken o) ( long o <> help h <> hidden ) + shortopt o h = globalFlag (Limit.addSyntaxToken [o]) ( short o <> help h <> hidden ) jsonOptions :: [GlobalOption] jsonOptions = @@ -366,14 +366,15 @@ jobsOption :: [GlobalOption] jobsOption = [ globalSetter set $ - option auto - ( long "jobs" <> short 'J' <> metavar paramNumber + option (maybeReader parseConcurrency) + ( long "jobs" <> short 'J' + <> metavar (paramNumber `paramOr` "cpus") <> help "enable concurrent jobs" <> hidden ) ] where - set n = Annex.changeState $ \s -> s { Annex.concurrency = Concurrent n } + set v = Annex.changeState $ \s -> s { Annex.concurrency = v } timeLimitOption :: [GlobalOption] timeLimitOption = diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -186,7 +186,7 @@ matcher <- Limit.getMatcher return $ \v@(k, ai) -> let i = case ai of - ActionItemBranchFilePath (BranchFilePath _ topf) -> + ActionItemBranchFilePath (BranchFilePath _ topf) _ -> MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) _ -> MatchingKey k (AssociatedFile Nothing) in whenM (matcher i) $ @@ -229,10 +229,11 @@ keyaction <- mkkeyaction forM_ bs $ \b -> do (l, cleanup) <- inRepo $ LsTree.lsTree LsTree.LsTreeRecursive b - forM_ l $ \i -> do - let bfp = mkActionItem $ BranchFilePath b (LsTree.file i) - maybe noop (\k -> keyaction (k, bfp)) - =<< catKey (LsTree.sha i) + forM_ l $ \i -> catKey (LsTree.sha i) >>= \case + Nothing -> noop + Just k -> + let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k) + in keyaction (k, bfp) unlessM (liftIO cleanup) $ error ("git ls-tree " ++ Git.fromRef b ++ " failed") runfailedtransfers = do diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -19,6 +19,7 @@ import Annex.FileMatcher import Annex.Link import Annex.Version +import Annex.Tmp import Git.FilePath cmd :: Command @@ -137,11 +138,11 @@ next $ next $ addFile file perform :: FilePath -> CommandPerform -perform file = do +perform file = withOtherTmp $ \tmpdir -> do lockingfile <- not <$> addUnlocked let cfg = LockDownConfig { lockingFile = lockingfile - , hardlinkFileTmp = True + , hardlinkFileTmpDir = Just tmpdir } lockDown cfg file >>= ingestAdd >>= finish where diff --git a/Command/Describe.hs b/Command/Describe.hs --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -21,7 +21,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start (name:description) = do +start (name:description) | not (null description) = do showStart' "describe" (Just name) u <- Remote.nameToUUID name next $ perform u $ unwords description diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -63,9 +63,10 @@ go = whenAnnexed $ start o start :: DropOptions -> FilePath -> Key -> CommandStart -start o file key = start' o key afile (mkActionItem afile) +start o file key = start' o key afile ai where afile = AssociatedFile (Just file) + ai = mkActionItem (key, afile) start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart start' o key afile ai = onlyActionOn key $ do diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -14,6 +14,7 @@ import qualified Git import qualified Git.DiffTree import qualified Git.LsTree +import qualified Git.Tree import qualified Git.Ref import Git.Types import Git.FilePath @@ -24,13 +25,17 @@ import Annex.Content import Annex.Transfer import Annex.CatFile +import Annex.FileMatcher +import Types.FileMatcher import Annex.RemoteTrackingBranch import Logs.Location import Logs.Export +import Logs.PreferredContent import Database.Export import Config import Utility.Tmp import Utility.Metered +import Utility.Matcher import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -79,7 +84,8 @@ setConfig (remoteConfig r "annex-tracking-branch") (fromRef $ exportTreeish o) - tree <- fromMaybe (giveup "unknown tree") <$> + tree <- filterPreferredContent r =<< + fromMaybe (giveup "unknown tree") <$> inRepo (Git.Ref.tree (exportTreeish o)) mtbcommitsha <- getExportCommit r (exportTreeish o) @@ -112,8 +118,8 @@ -- | Changes what's exported to the remote. Does not upload any new -- files, but does delete and rename files already exported to the remote. -changeExport :: Remote -> ExportHandle -> Git.Ref -> CommandSeek -changeExport r db new = do +changeExport :: Remote -> ExportHandle -> PreferredFiltered Git.Ref -> CommandSeek +changeExport r db (PreferredFiltered new) = do old <- getExport (uuid r) recordExportBeginning (uuid r) new @@ -223,8 +229,8 @@ -- -- Once all exported files have reached the remote, updates the -- remote tracking branch. -fillExport :: Remote -> ExportHandle -> Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool -fillExport r db newtree mtbcommitsha = do +fillExport :: Remote -> ExportHandle -> PreferredFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool +fillExport r db (PreferredFiltered newtree) mtbcommitsha = do (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive newtree cvar <- liftIO $ newMVar (FileUploaded False) allfilledvar <- liftIO $ newMVar (AllFilled True) @@ -431,3 +437,46 @@ ( removeexportdirectory d , return True ) + +-- | A value that has been filtered through the remote's preferred content +-- expression. +newtype PreferredFiltered t = PreferredFiltered t + +-- | Filters the tree to files that are preferred content of the remote. +-- +-- A log is written with files that were filtered out, so they can be added +-- back in when importing from the remote. +filterPreferredContent :: Remote -> Git.Ref -> Annex (PreferredFiltered Git.Ref) +filterPreferredContent r tree = logExportExcluded (uuid r) $ \logwriter -> do + m <- preferredContentMap + case M.lookup (uuid r) m of + Just matcher | not (isEmpty matcher) -> do + PreferredFiltered <$> go matcher logwriter + _ -> return (PreferredFiltered tree) + where + go matcher logwriter = do + g <- Annex.gitRepo + Git.Tree.adjustTree + (checkmatcher matcher logwriter) + [] + (\_old new -> new) + [] + tree + g + + checkmatcher matcher logwriter ti@(Git.Tree.TreeItem topf _ sha) = + catKey sha >>= \case + Just k -> do + -- Match filename relative to the + -- top of the tree. + let af = AssociatedFile $ Just $ + getTopFilePath topf + let mi = MatchingKey k af + ifM (checkMatcher' matcher mi mempty) + ( return (Just ti) + , do + () <- liftIO $ logwriter ti + return Nothing + ) + -- Always export non-annexed files. + Nothing -> return (Just ti) diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -73,7 +73,7 @@ ) startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart -startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf)) = +startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = start o (getTopFilePath topf) key startKeys _ _ = stop diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -114,7 +114,7 @@ Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key afile backend numcopies r where - go = runFsck inc (mkActionItem afile) key + go = runFsck inc (mkActionItem (key, afile)) key afile = AssociatedFile (Just file) perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool @@ -134,7 +134,7 @@ ] where afile = AssociatedFile (Just file) - ai = ActionItemAssociatedFile afile + ai = mkActionItem (key, afile) {- To fsck a remote, the content is retrieved to a tmp file, - and checked locally. -} @@ -161,7 +161,7 @@ , withLocalCopy localcopy $ checkBackendRemote backend key remote ai , checkKeyNumCopies key afile numcopies ] - ai = ActionItemAssociatedFile afile + ai = mkActionItem (key, afile) withtmp a = do pid <- liftIO getPID t <- fromRepo gitAnnexTmpObjectDir @@ -275,7 +275,7 @@ fix InfoMissing warning $ "** Based on the location log, " ++ - actionItemDesc ai key ++ + actionItemDesc ai ++ "\n** was expected to be present, " ++ "but its content is missing." return False @@ -295,7 +295,7 @@ {- Verifies that all repos that are required to contain the content do, - checking against the location log. -} verifyRequiredContent :: Key -> ActionItem -> Annex Bool -verifyRequiredContent key ai@(ActionItemAssociatedFile afile) = do +verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = do requiredlocs <- S.fromList . M.keys <$> requiredContentMap if S.null requiredlocs then return True @@ -310,7 +310,7 @@ missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs warning $ "** Required content " ++ - actionItemDesc ai key ++ + actionItemDesc ai ++ " is missing from these repositories:\n" ++ missingrequired return False @@ -401,7 +401,7 @@ badsize a b = do msg <- bad key warning $ concat - [ actionItemDesc ai key + [ actionItemDesc ai , ": Bad file size (" , compareSizes storageUnits True a b , "); " @@ -419,7 +419,7 @@ case Types.Backend.canUpgradeKey backend of Just a | a key -> do warning $ concat - [ actionItemDesc ai key + [ actionItemDesc ai , ": Can be upgraded to an improved key format. " , "You can do so by running: git annex migrate --backend=" , decodeBS (formatKeyVariety (keyVariety key)) ++ " " @@ -451,18 +451,20 @@ content <- calcRepo $ gitAnnexLocation key ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck - , checkBackendOr badContent backend key content (mkActionItem afile) + , checkBackendOr badContent backend key content ai ) go True = case afile of AssociatedFile Nothing -> nocheck AssociatedFile (Just f) -> checkdirect f checkdirect file = ifM (Direct.goodContent key file) - ( checkBackendOr' (badContentDirect file) backend key file (mkActionItem afile) + ( checkBackendOr' (badContentDirect file) backend key file ai (Direct.goodContent key file) , nocheck ) nocheck = return True + ai = mkActionItem (key, afile) + checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> FilePath -> Annex Bool checkBackendRemote backend key remote ai localcopy = checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai @@ -485,7 +487,7 @@ unless ok $ do msg <- bad key warning $ concat - [ actionItemDesc ai key + [ actionItemDesc ai , ": Bad file content; " , msg ] diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -49,9 +49,10 @@ =<< workTreeItems (getFiles o) start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart -start o from file key = start' expensivecheck from key afile (mkActionItem afile) +start o from file key = start' expensivecheck from key afile ai where afile = AssociatedFile (Just file) + ai = mkActionItem (key, afile) expensivecheck | autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) afile diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -214,7 +214,7 @@ -- has to be done to clean up from it. let cfg = LockDownConfig { lockingFile = lockingfile - , hardlinkFileTmp = False + , hardlinkFileTmpDir = Nothing } v <- lockDown cfg srcfile case v of @@ -291,11 +291,15 @@ listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart listContents remote tvar = do showStart' "list" (Just (Remote.name remote)) - next $ Remote.listImportableContents (Remote.importActions remote) >>= \case + next $ listImportableContents remote >>= \case Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote - Just importable -> next $ do - liftIO $ atomically $ writeTVar tvar (Just importable) - return True + 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') + return True commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = do diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -445,9 +445,8 @@ desc = "transfers in progress" line uuidmap t i = unwords [ formatDirection (transferDirection t) ++ "ing" - , actionItemDesc - (ActionItemAssociatedFile (associatedFile i)) - (transferKey t) + , actionItemDesc $ mkActionItem + (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -76,8 +76,15 @@ seek o = do parser <- if largeFilesExpression o then mkLargeFilesParser - else preferredContentParser - matchAll matchAll groupMap M.empty . Just <$> getUUID + else do + u <- getUUID + pure $ preferredContentParser $ preferredContentTokens $ PCD + { matchStandard = Right matchAll + , matchGroupWanted = Right matchAll + , getGroupMap = groupMap + , configMap = M.empty + , repoUUID = Just u + } case parsedToMatcher $ parser ((matchexpr o)) of Left e -> liftIO $ bail $ "bad expression: " ++ e Right matcher -> ifM (checkmatcher matcher) diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -93,7 +93,7 @@ _ -> giveup "--batch is currently only supported in --json mode" start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart -start c o file k = startKeys c o (k, mkActionItem afile) +start c o file k = startKeys c o (k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) @@ -164,7 +164,7 @@ Left f -> do mk <- lookupFile f case mk of - Just k -> go k (mkActionItem (AssociatedFile (Just f))) + Just k -> go k (mkActionItem (k, AssociatedFile (Just f))) Nothing -> giveup $ "not an annexed file: " ++ f Right k -> go k (mkActionItem k) where diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -48,9 +48,10 @@ =<< workTreeItems (mirrorFiles o) start :: MirrorOptions -> FilePath -> Key -> CommandStart -start o file k = startKey o afile (k, mkActionItem afile) +start o file k = startKey o afile (k, ai) where afile = AssociatedFile (Just file) + ai = mkActionItem (k, afile) startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart startKey o afile (key, ai) = onlyActionOn key $ case fromToOptions o of diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -64,10 +64,10 @@ =<< workTreeItems (moveFiles o) start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart -start fromto removewhen f k = - start' fromto removewhen afile k (mkActionItem afile) +start fromto removewhen f k = start' fromto removewhen afile k ai where afile = AssociatedFile (Just f) + ai = mkActionItem (k, afile) startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart startKey fromto removewhen = diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -132,7 +132,7 @@ cfg = LockDownConfig { lockingFile = False - , hardlinkFileTmp = False + , hardlinkFileTmpDir = Nothing } -- git diff can run the clean filter on files outside the diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -690,7 +690,7 @@ , return [] ) get have = includeCommandAction $ do - showStartKey "get" k (mkActionItem af) + showStartKey "get" k ai next $ next $ getKey' k af have wantput r @@ -705,8 +705,10 @@ , return [] ) put dest = includeCommandAction $ - Command.Move.toStart' dest Command.Move.RemoveNever af k (mkActionItem af) + Command.Move.toStart' dest Command.Move.RemoveNever af k ai + ai = mkActionItem (k, af) + {- When a remote has an annex-tracking-branch configuration, change the export - to contain the current content of the branch. Otherwise, transfer any files - that were part of an export but are not in the remote yet. @@ -723,23 +725,22 @@ (Export.openDb (Remote.uuid r)) Export.closeDb (\db -> Export.writeLockDbWhile db (go' r db)) - go' r db = do - (exported, mtbcommitsha) <- case remoteAnnexTrackingBranch (Remote.gitconfig r) of - Nothing -> nontracking r - Just b -> do - mtree <- inRepo $ Git.Ref.tree b - mtbcommitsha <- Command.Export.getExportCommit r b - case (mtree, mtbcommitsha) of - (Just tree, Just _) -> do - Command.Export.changeExport r db tree - return ([mkExported tree []], mtbcommitsha) - _ -> nontracking r - fillexport r db (exportedTreeishes exported) mtbcommitsha - - nontracking r = do + go' r db = case remoteAnnexTrackingBranch (Remote.gitconfig r) of + Nothing -> nontracking r db + Just b -> do + mtree <- inRepo $ Git.Ref.tree b + mtbcommitsha <- Command.Export.getExportCommit r b + case (mtree, mtbcommitsha) of + (Just tree, Just _) -> do + filteredtree <- Command.Export.filterPreferredContent r tree + Command.Export.changeExport r db filteredtree + Command.Export.fillExport r db filteredtree mtbcommitsha + _ -> nontracking r db + + nontracking r db = do exported <- getExport (Remote.uuid r) maybe noop (warnnontracking r exported) currbranch - return (exported, Nothing) + fillexport r db (exportedTreeishes exported) Nothing warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case Just currt | not (any (== currt) (exportedTreeishes exported)) -> @@ -754,7 +755,9 @@ gitconfig = show (remoteConfig r "tracking-branch") fillexport _ _ [] _ = return False - fillexport r db (t:[]) mtbcommitsha = Command.Export.fillExport r db t mtbcommitsha + fillexport r db (tree:[]) mtbcommitsha = do + let filteredtree = Command.Export.PreferredFiltered tree + Command.Export.fillExport r db filteredtree mtbcommitsha fillexport r _ _ _ = do warnExportImportConflict r return False diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -48,7 +48,7 @@ =<< workTreeItems (whereisFiles o) start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart -start remotemap file key = startKeys remotemap (key, mkActionItem afile) +start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile)) where afile = AssociatedFile (Just file) diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -15,6 +15,7 @@ lsTreeParams, lsTreeFiles, parseLsTree, + formatLsTree, ) where import Common @@ -90,3 +91,12 @@ !f = drop 1 past_s !smode = fst $ Prelude.head $ readOct m !sfile = asTopFilePath $ Git.Filename.decode f + +{- Inverse of parseLsTree -} +formatLsTree :: TreeItem -> String +formatLsTree ti = unwords + [ showOct (mode ti) "" + , typeobj ti + , fromRef (sha ti) + , getTopFilePath (file ti) + ] diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -15,6 +15,8 @@ recordTree', TreeItem(..), treeItemsToTree, + treeItemToLsTreeItem, + lsTreeItemToTreeItem, adjustTree, graftTree, graftTree', @@ -127,6 +129,20 @@ treeItemToTreeContent :: TreeItem -> TreeContent treeItemToTreeContent (TreeItem f m s) = TreeBlob f m s +treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem +treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem + { LsTree.mode = mode + , LsTree.typeobj = show BlobObject + , LsTree.sha = sha + , LsTree.file = f + } + +lsTreeItemToTreeItem :: LsTree.TreeItem -> TreeItem +lsTreeItemToTreeItem ti = TreeItem + (LsTree.file ti) + (LsTree.mode ti) + (LsTree.sha ti) + treeItemsToTree :: [TreeItem] -> Tree treeItemsToTree = go M.empty where @@ -179,12 +195,16 @@ -- Cannot move the item to a different tree. -> [TreeItem] -- ^ New items to add to the tree. + -> (TreeContent -> TreeContent -> TreeContent) + -- ^ When adding a new item to the tree and an item with the same + -- name already exists, this function picks which to use. + -- The first one is the item that was already in the tree. -> [TopFilePath] -- ^ Files to remove from the tree. -> Ref -> Repo -> m Sha -adjustTree adjusttreeitem addtreeitems removefiles r repo = +adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = withMkTreeHandle repo $ \h -> do (l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo (l', _, _) <- go h False [] 1 inTopTree l @@ -223,16 +243,30 @@ adjustlist h depth ishere underhere l = do let (addhere, rest) = partition ishere addtreeitems let l' = filter (not . removed) $ - map treeItemToTreeContent addhere ++ l + addoldnew l (map treeItemToTreeContent addhere) let inl i = any (\t -> beneathSubTree t i) l' let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $ filter (\i -> underhere i && not (inl i)) rest addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere - return (addunderhere'++l') + return (addoldnew l' addunderhere') removeset = S.fromList $ map (normalise . gitPath) removefiles removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset removed _ = False + + addoldnew [] new = new + addoldnew old [] = old + addoldnew old new = addoldnew' (M.fromList $ map (\i -> (mkk i, i)) old) new + addoldnew' oldm (n:ns) = + let k = mkk n + in case M.lookup k oldm of + Just o -> + resolveaddconflict o n + : + addoldnew' (M.delete k oldm) ns + Nothing -> n : addoldnew' oldm ns + addoldnew' oldm [] = M.elems oldm + mkk = normalise . gitPath {- Grafts subtree into the basetree at the specified location, replacing - anything that the basetree already had at that location. diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -63,9 +63,9 @@ prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls prepend _ = error "internal" -{- Adds a new token. -} -addToken :: String -> Annex () -addToken = add . Utility.Matcher.token +{- Adds a new syntax token. -} +addSyntaxToken :: String -> Annex () +addSyntaxToken = either error add . Utility.Matcher.syntaxToken {- Adds a new limit. -} addLimit :: Either String (MatchFiles Annex) -> Annex () diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -15,6 +15,8 @@ incompleteExportedTreeishes, recordExport, recordExportBeginning, + logExportExcluded, + getExportExcluded, ) where import qualified Data.Map as M @@ -26,6 +28,9 @@ import Git.FilePath import Logs import Logs.MapLog +import Logs.File +import qualified Git.LsTree +import qualified Git.Tree import Annex.UUID import qualified Data.ByteString.Lazy as L @@ -156,3 +161,23 @@ where refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') ) <* ((const () <$> A8.char ' ') <|> A.endOfInput) + +logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a +logExportExcluded u a = do + logf <- fromRepo $ gitAnnexExportExcludeLog u + withLogHandle logf $ \logh -> do + liftIO $ hSetNewlineMode logh noNewlineTranslation + a (writer logh) + where + writer logh = hPutStrLn logh + . Git.LsTree.formatLsTree + . Git.Tree.treeItemToLsTreeItem + +getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] +getExportExcluded u = do + logf <- fromRepo $ gitAnnexExportExcludeLog u + liftIO $ catchDefaultIO [] $ + (map parser . lines) + <$> readFile logf + where + parser = Git.Tree.lsTreeItemToTreeItem . Git.LsTree.parseLsTree diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -5,11 +5,12 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Logs.File (writeLogFile, appendLogFile, streamLogFile) where +module Logs.File (writeLogFile, withLogHandle, appendLogFile, streamLogFile) where import Annex.Common import Annex.Perms import Annex.LockFile +import Annex.ReplaceFile import qualified Git import Utility.Tmp @@ -22,6 +23,19 @@ writelog f' c' = do liftIO $ writeFile f' c' setAnnexFilePerm f' + +-- | Runs the action with a handle connected to a temp file. +-- The temp file replaces the log file once the action succeeds. +withLogHandle :: FilePath -> (Handle -> Annex a) -> Annex a +withLogHandle f a = do + createAnnexDirectory (parentDir f) + replaceFile f $ \tmp -> + bracket (setup tmp) cleanup a + where + setup tmp = do + setAnnexFilePerm tmp + liftIO $ openFile tmp WriteMode + cleanup h = liftIO $ hClose h -- | Appends a line to a log file, first locking it to prevent -- concurrent writers. diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -20,6 +20,7 @@ setStandardGroup, defaultStandardGroup, preferredRequiredMapsLoad, + preferredRequiredMapsLoad', prop_standardGroups_parse, ) where @@ -34,7 +35,7 @@ import qualified Annex import Logs import Logs.UUIDBased -import Utility.Matcher hiding (tokens) +import Utility.Matcher import Annex.FileMatcher import Annex.UUID import Types.Group @@ -62,30 +63,46 @@ Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d) preferredContentMap :: Annex (FileMatcherMap Annex) -preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad) return +preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return =<< Annex.getState Annex.preferredcontentmap requiredContentMap :: Annex (FileMatcherMap Annex) -requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad) return +requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad preferredContentTokens) return =<< Annex.getState Annex.requiredcontentmap -preferredRequiredMapsLoad :: Annex (FileMatcherMap Annex, FileMatcherMap Annex) -preferredRequiredMapsLoad = do +preferredRequiredMapsLoad :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (FileMatcherMap Annex, FileMatcherMap Annex) +preferredRequiredMapsLoad mktokens = do + (pc, rc) <- preferredRequiredMapsLoad' mktokens + let pc' = handleunknown pc + let rc' = handleunknown rc + Annex.changeState $ \s -> s + { Annex.preferredcontentmap = Just pc' + , Annex.requiredcontentmap = Just rc' + } + return (pc', rc') + where + handleunknown = M.mapWithKey $ \u -> + either (const $ unknownMatcher u) id + +preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex))) +preferredRequiredMapsLoad' mktokens = do groupmap <- groupMap configmap <- readRemoteLog - let genmap l gm = simpleMap - . parseLogOldWithUUID (\u -> makeMatcher groupmap configmap gm u . decodeBS <$> A.takeByteString) - <$> Annex.Branch.get l + let genmap l gm = + let mk u = makeMatcher groupmap configmap gm u mktokens + in simpleMap + . parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString) + <$> Annex.Branch.get l pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw rc <- genmap requiredContentLog M.empty - -- Required content is implicitly also preferred content, so - -- combine. - let m = M.unionWith combineMatchers pc rc - Annex.changeState $ \s -> s - { Annex.preferredcontentmap = Just m - , Annex.requiredcontentmap = Just rc - } - return (m, rc) + -- Required content is implicitly also preferred content, so combine. + let pc' = M.unionWith combiner pc rc + return (pc', rc) + where + combiner (Right a) (Right b) = Right (combineMatchers a b) + combiner (Left a) (Left b) = Left (a ++ " " ++ b) + combiner (Left a) (Right _) = Left a + combiner (Right _) (Left b) = Left b {- This intentionally never fails, even on unparsable expressions, - because the configuration is shared among repositories and newer @@ -95,23 +112,31 @@ -> M.Map UUID RemoteConfig -> M.Map Group PreferredContentExpression -> UUID + -> (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> PreferredContentExpression - -> FileMatcher Annex -makeMatcher groupmap configmap groupwantedmap u = go True True + -> Either String (FileMatcher Annex) +makeMatcher groupmap configmap groupwantedmap u mktokens = go True True where go expandstandard expandgroupwanted expr - | null (lefts tokens) = generate $ rights tokens - | otherwise = unknownMatcher u + | null (lefts tokens) = Right $ generate $ rights tokens + | otherwise = Left (unwords (lefts tokens)) where - tokens = preferredContentParser matchstandard matchgroupwanted (pure groupmap) configmap (Just u) expr + tokens = preferredContentParser (mktokens pcd) expr + pcd = PCD + { matchStandard = matchstandard + , matchGroupWanted = matchgroupwanted + , getGroupMap = pure groupmap + , configMap = configmap + , repoUUID = Just u + } matchstandard - | expandstandard = maybe (unknownMatcher u) (go False False) + | expandstandard = maybe (Right $ unknownMatcher u) (go False False) (standardPreferredContent <$> getStandardGroup mygroups) - | otherwise = unknownMatcher u + | otherwise = Right $ unknownMatcher u matchgroupwanted - | expandgroupwanted = maybe (unknownMatcher u) (go True False) + | expandgroupwanted = maybe (Right $ unknownMatcher u) (go True False) (groupwanted mygroups) - | otherwise = unknownMatcher u + | otherwise = Right $ unknownMatcher u mygroups = fromMaybe S.empty (u `M.lookup` groupsByUUID groupmap) groupwanted s = case M.elems $ M.filterWithKey (\k _ -> S.member k s) groupwantedmap of [pc] -> Just pc @@ -134,7 +159,14 @@ Left e -> Just e Right _ -> Nothing where - tokens = preferredContentParser matchAll matchAll (pure emptyGroupMap) M.empty Nothing expr + tokens = preferredContentParser (preferredContentTokens pcd) expr + pcd = PCD + { matchStandard = Right matchAll + , matchGroupWanted = Right matchAll + , getGroupMap = pure emptyGroupMap + , configMap = M.empty + , repoUUID = Nothing + } {- Puts a UUID in a standard group, and sets its preferred content to use - the standard expression for that group (unless preferred content is diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -12,7 +12,6 @@ import Types.Transfer import Types.ActionItem import Annex.Common -import Annex.Perms import qualified Git import Utility.Metered import Utility.Percentage @@ -20,6 +19,9 @@ import Annex.LockPool import Utility.TimeStamp import Logs.File +#ifndef mingw32_HOST_OS +import Annex.Perms +#endif import Data.Time.Clock import Data.Time.Clock.POSIX @@ -29,8 +31,8 @@ describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t - , actionItemDesc - (ActionItemAssociatedFile (associatedFile info)) + , actionItemDesc $ ActionItemAssociatedFile + (associatedFile info) (transferKey t) , show $ bytesComplete info ] diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -77,7 +77,7 @@ showStartKey :: String -> Key -> ActionItem -> Annex () showStartKey command key i = outputMessage json $ - command ++ " " ++ actionItemDesc i key ++ " " + command ++ " " ++ actionItemDesc i ++ " " where json = JSON.start command (actionItemWorkTreeFile i) (Just key) @@ -262,10 +262,12 @@ - the user. -} prompt :: Annex a -> Annex a -prompt a = debugLocks $ go =<< Annex.getState Annex.concurrency +prompt a = debugLocks $ Annex.getState Annex.concurrency >>= \case + NonConcurrent -> a + (Concurrent _) -> goconcurrent + ConcurrentPerCpu -> goconcurrent where - go NonConcurrent = a - go (Concurrent {}) = withMessageState $ \s -> do + goconcurrent = withMessageState $ \s -> do let l = promptLock s bracketIO (takeMVar l) diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -81,6 +81,8 @@ , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir , storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir , removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir + -- Not needed because removeExportWithContentIdentifier + -- auto-removes empty directories. , removeExportDirectoryWhenEmpty = Nothing , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM dir } diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -150,12 +150,12 @@ { displayProgress = False } | otherwise = specialRemoteCfg c -rsyncTransportToObjects :: Git.Repo -> RemoteGitConfig -> Annex ([CommandParam], String) +rsyncTransportToObjects :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String) rsyncTransportToObjects r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc return (rsynctransport, rsyncurl ++ "/annex/objects") -rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex ([CommandParam], String, AccessMethod) +rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod) rsyncTransport r gc | "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc | "//:" `isInfixOf` loc = othertransport @@ -168,9 +168,10 @@ then drop 3 path else path let sshhost = either error id (mkSshHost host) - opts <- sshOptions ConsumeStdin (sshhost, Nothing) gc [] - return (rsyncShell $ Param "ssh" : opts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell) - othertransport = return ([], loc, AccessDirect) + let mkopts = rsyncShell . (Param "ssh" :) + <$> sshOptions ConsumeStdin (sshhost, Nothing) gc [] + return (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell) + othertransport = return (pure [], loc, AccessDirect) noCrypto :: Annex a noCrypto = giveup "cannot use gcrypt remote without encryption enabled" @@ -263,14 +264,15 @@ dummycfg <- liftIO dummyRemoteGitConfig (rsynctransport, rsyncurl, _) <- rsyncTransport r dummycfg let tmpconfig = tmp "config" - void $ liftIO $ rsync $ rsynctransport ++ + opts <- rsynctransport + void $ liftIO $ rsync $ opts ++ [ Param $ rsyncurl ++ "/config" , Param tmpconfig ] liftIO $ do void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False) - ok <- liftIO $ rsync $ rsynctransport ++ + ok <- liftIO $ rsync $ opts ++ [ Param "--recursive" , Param $ tmp ++ "/" , Param rsyncurl @@ -456,9 +458,10 @@ getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, String)) getConfigViaRsync r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc + opts <- rsynctransport liftIO $ do withTmpFile "tmpconfig" $ \tmpconfig _ -> do - void $ rsync $ rsynctransport ++ + void $ rsync $ opts ++ [ Param $ rsyncurl ++ "/config" , Param tmpconfig ] diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -1,6 +1,6 @@ {- Adds readonly support to remotes. - - - Copyright 2013, 2015 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,6 +15,8 @@ import Annex.Common import Types.Remote import Types.StoreRetrieve +import Types.Import +import Types.Export import Utility.Metered {- Adds support for read-only remotes, by replacing the @@ -28,6 +30,17 @@ { storeKey = readonlyStoreKey , removeKey = readonlyRemoveKey , repairRepo = Nothing + , exportActions = (exportActions r) + { storeExport = readonlyStoreExport + , removeExport = readonlyRemoveExport + , removeExportDirectory = Just readonlyRemoveExportDirectory + , renameExport = readonlyRenameExport + } + , importActions = (importActions r) + { storeExportWithContentIdentifier = readonlyStoreExportWithContentIdentifier + , removeExportWithContentIdentifier = readonlyRemoveExportWithContentIdentifier + , removeExportDirectoryWhenEmpty = Just readonlyRemoveExportDirectory + } } | otherwise = r @@ -40,7 +53,30 @@ readonlyStorer :: Storer readonlyStorer _ _ _ = readonlyFail +readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +readonlyStoreExport _ _ _ _ = readonlyFail + +readonlyRemoveExport :: Key -> ExportLocation -> Annex Bool +readonlyRemoveExport _ _ = readonlyFail + +readonlyRemoveExportDirectory :: ExportDirectory -> Annex Bool +readonlyRemoveExportDirectory _ = readonlyFail + +readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +readonlyRenameExport _ _ _ = return Nothing + +readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier) +readonlyStoreExportWithContentIdentifier _ _ _ _ _ = do + readonlyWarning + return Nothing + +readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail + readonlyFail :: Annex Bool readonlyFail = do - warning "this remote is readonly" + readonlyWarning return False + +readonlyWarning :: Annex () +readonlyWarning = warning "this remote is readonly" diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -110,15 +110,18 @@ -- Rsync displays its own progress. { displayProgress = False } -genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> [CommandParam] -> RsyncUrl -> RsyncOpts +genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts genRsyncOpts c gc transport url = RsyncOpts { rsyncUrl = url - , rsyncOptions = transport ++ opts [] - , rsyncUploadOptions = transport ++ opts (remoteAnnexRsyncUploadOptions gc) - , rsyncDownloadOptions = transport ++ opts (remoteAnnexRsyncDownloadOptions gc) + , rsyncOptions = appendtransport $ opts [] + , rsyncUploadOptions = appendtransport $ + opts (remoteAnnexRsyncUploadOptions gc) + , rsyncDownloadOptions = appendtransport $ + opts (remoteAnnexRsyncDownloadOptions gc) , rsyncShellEscape = (yesNo =<< M.lookup "shellescape" c) /= Just False } where + appendtransport l = (++ l) <$> transport opts specificopts = map Param $ filter safe $ remoteAnnexRsyncOptions gc ++ specificopts safe opt @@ -129,23 +132,23 @@ | opt == "--delete-excluded" = False | otherwise = True -rsyncTransport :: RemoteGitConfig -> RsyncUrl -> Annex ([CommandParam], RsyncUrl) +rsyncTransport :: RemoteGitConfig -> RsyncUrl -> Annex (Annex [CommandParam], RsyncUrl) rsyncTransport gc url | rsyncUrlIsShell url = - (\rsh -> return (rsyncShell rsh, url)) =<< + (\transport -> return (rsyncShell <$> transport, url)) =<< case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of "ssh":sshopts -> do let (port, sshopts') = sshReadPort sshopts userhost = either error id $ mkSshHost $ takeWhile (/= ':') url - (Param "ssh":) <$> sshOptions ConsumeStdin + return $ (Param "ssh":) <$> sshOptions ConsumeStdin (userhost, port) gc (map Param $ loginopt ++ sshopts') - "rsh":rshopts -> return $ map Param $ "rsh" : + "rsh":rshopts -> return $ pure $ map Param $ "rsh" : loginopt ++ rshopts rsh -> giveup $ "Unknown Rsync transport: " ++ unwords rsh - | otherwise = return ([], url) + | otherwise = return (pure [], url) where login = case separate (=='@') url of (_h, "") -> Nothing @@ -232,9 +235,10 @@ removeGeneric :: RsyncOpts -> [String] -> Annex Bool removeGeneric o includes = do ps <- sendParams + opts <- rsyncOptions o withRsyncScratchDir $ \tmp -> liftIO $ do {- Send an empty directory to rysnc to make it delete. -} - rsync $ rsyncOptions o ++ ps ++ + rsync $ opts ++ ps ++ map (\s -> Param $ "--include=" ++ s) includes ++ [ Param "--exclude=*" -- exclude everything else , Param "--quiet", Param "--delete", Param "--recursive" @@ -249,14 +253,14 @@ checkPresentGeneric o (rsyncUrls o k) checkPresentGeneric :: RsyncOpts -> [RsyncUrl] -> Annex Bool -checkPresentGeneric o rsyncurls = +checkPresentGeneric o rsyncurls = do + opts <- rsyncOptions o -- note: Does not currently differentiate between rsync failing -- to connect, and the file not being present. untilTrue rsyncurls $ \u -> liftIO $ catchBoolIO $ do withQuietOutput createProcessSuccess $ - proc "rsync" $ toCommand $ - rsyncOptions o ++ [Param u] + proc "rsync" $ toCommand $ opts ++ [Param u] return True storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool @@ -341,13 +345,14 @@ rsyncRemote :: Direction -> RsyncOpts -> Maybe MeterUpdate -> [CommandParam] -> Annex Bool rsyncRemote direction o m params = do showOutput -- make way for progress bar + opts <- mkopts + let ps = opts ++ Param "--progress" : params case m of Nothing -> liftIO $ rsync ps Just meter -> do oh <- mkOutputHandler liftIO $ rsyncProgress oh meter ps where - ps = opts ++ Param "--progress" : params - opts + mkopts | direction == Download = rsyncDownloadOptions o | otherwise = rsyncUploadOptions o diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -25,9 +25,9 @@ data RsyncOpts = RsyncOpts { rsyncUrl :: RsyncUrl - , rsyncOptions :: [CommandParam] - , rsyncUploadOptions :: [CommandParam] - , rsyncDownloadOptions :: [CommandParam] + , rsyncOptions :: Annex [CommandParam] + , rsyncUploadOptions :: Annex [CommandParam] + , rsyncDownloadOptions :: Annex [CommandParam] , rsyncShellEscape :: Bool } diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -1,6 +1,6 @@ {- items that a command can act on - - - Copyright 2016 Joey Hess + - Copyright 2016-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,36 +14,45 @@ import Git.FilePath data ActionItem - = ActionItemAssociatedFile AssociatedFile - | ActionItemKey - | ActionItemBranchFilePath BranchFilePath + = ActionItemAssociatedFile AssociatedFile Key + | ActionItemKey Key + | ActionItemBranchFilePath BranchFilePath Key | ActionItemFailedTransfer Transfer TransferInfo class MkActionItem t where mkActionItem :: t -> ActionItem -instance MkActionItem AssociatedFile where - mkActionItem = ActionItemAssociatedFile +instance MkActionItem (AssociatedFile, Key) where + mkActionItem = uncurry ActionItemAssociatedFile +instance MkActionItem (Key, AssociatedFile) where + mkActionItem = uncurry $ flip ActionItemAssociatedFile + instance MkActionItem Key where - mkActionItem _ = ActionItemKey + mkActionItem = ActionItemKey -instance MkActionItem BranchFilePath where - mkActionItem = ActionItemBranchFilePath +instance MkActionItem (BranchFilePath, Key) where + mkActionItem = uncurry ActionItemBranchFilePath instance MkActionItem (Transfer, TransferInfo) where mkActionItem = uncurry ActionItemFailedTransfer -actionItemDesc :: ActionItem -> Key -> String -actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f -actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = serializeKey k -actionItemDesc ActionItemKey k = serializeKey k -actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp -actionItemDesc (ActionItemFailedTransfer _ i) k = - actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k +actionItemDesc :: ActionItem -> String +actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f +actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k +actionItemDesc (ActionItemKey k) = serializeKey k +actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp +actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ + ActionItemAssociatedFile (associatedFile i) (transferKey t) +actionItemKey :: ActionItem -> Key +actionItemKey (ActionItemAssociatedFile _ k) = k +actionItemKey (ActionItemKey k) = k +actionItemKey (ActionItemBranchFilePath _ k) = k +actionItemKey (ActionItemFailedTransfer t _) = transferKey t + actionItemWorkTreeFile :: ActionItem -> Maybe FilePath -actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af)) = af +actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemWorkTreeFile _ = Nothing actionItemTransferDirection :: ActionItem -> Maybe Direction diff --git a/Types/Command.hs b/Types/Command.hs --- a/Types/Command.hs +++ b/Types/Command.hs @@ -27,7 +27,7 @@ type CommandSeek = Annex () {- d. The start stage is run before anything is printed about the - command, is passed some input, and can early abort it - - if the input does not make sense. It should run quickly and + - if nothing needs to be done. It should run quickly and - should not modify Annex state. -} type CommandStart = Annex (Maybe CommandPerform) {- e. The perform stage is run after a message is printed about the command diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -5,4 +5,11 @@ module Types.Concurrency where -data Concurrency = NonConcurrent | Concurrent Int +import Utility.PartialPrelude + +data Concurrency = NonConcurrent | Concurrent Int | ConcurrentPerCpu + +parseConcurrency :: String -> Maybe Concurrency +parseConcurrency "cpus" = Just ConcurrentPerCpu +parseConcurrency "cpu" = Just ConcurrentPerCpu +parseConcurrency s = Concurrent <$> readish s diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -31,7 +31,7 @@ } -- This is used when testing a matcher, with values to match against --- provided by the user, rather than queried from files. +-- provided in some way, rather than queried from files on disk. data ProvidedInfo = ProvidedInfo { providedFilePath :: OptInfo FilePath , providedKey :: OptInfo Key @@ -48,7 +48,7 @@ getInfo (Right i) = return i getInfo (Left e) = liftIO e -type FileMatcherMap a = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> MatchInfo -> a Bool)) +type FileMatcherMap a = M.Map UUID (FileMatcher a) type MkLimit a = String -> Either String (MatchFiles a) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -98,7 +98,7 @@ , annexRetry :: Maybe Integer , annexRetryDelay :: Maybe Seconds , annexAllowedUrlSchemes :: S.Set Scheme - , annexAllowedHttpAddresses :: String + , annexAllowedIPAddresses :: String , annexAllowUnverifiedDownloads :: Bool , annexMaxExtensionLength :: Maybe Int , annexJobs :: Concurrency @@ -172,12 +172,15 @@ , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ maybe ["http", "https", "ftp"] words $ getmaybe (annex "security.allowed-url-schemes") - , annexAllowedHttpAddresses = fromMaybe "" $ - getmaybe (annex "security.allowed-http-addresses") + , annexAllowedIPAddresses = fromMaybe "" $ + getmaybe (annex "security.allowed-ip-addresses") + <|> + getmaybe (annex "security.allowed-http-addresses") -- old name , annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe (annex "security.allow-unverified-downloads") , annexMaxExtensionLength = getmayberead (annex "maxextensionlength") - , annexJobs = maybe NonConcurrent Concurrent $ getmayberead (annex "jobs") + , annexJobs = fromMaybe NonConcurrent $ + parseConcurrency =<< getmaybe (annex "jobs") , annexCacheCreds = getbool (annex "cachecreds") True , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -231,11 +231,11 @@ -- Removes an exported file (succeeds if the contents are not present) , removeExport :: Key -> ExportLocation -> a Bool -- Removes an exported directory. Typically the directory will be - -- empty, but it could possbly contain files or other directories, - -- and it's ok to delete those. If the remote does not use - -- directories, or automatically cleans up empty directories, - -- this can be Nothing. Should not fail if the directory was - -- already removed. + -- empty, but it could possibly contain files or other directories, + -- and it's ok to delete those (but not required to). + -- If the remote does not use directories, or automatically cleans + -- up empty directories, this can be Nothing. + -- Should not fail if the directory was already removed. , removeExportDirectory :: Maybe (ExportDirectory -> a Bool) -- Checks if anything is exported to the remote at the specified -- ExportLocation. diff --git a/Types/WorkerPool.hs b/Types/WorkerPool.hs new file mode 100644 --- /dev/null +++ b/Types/WorkerPool.hs @@ -0,0 +1,30 @@ +{- Command worker pool. + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.WorkerPool where + +import Control.Concurrent.Async +import Data.Either + +-- | Pool of worker threads. +data WorkerPool t + = UnallocatedWorkerPool + | WorkerPool [Worker t] + +-- | A worker can either be idle or running an Async action. +type Worker t = Either t (Async t) + +allocateWorkerPool :: t -> Int -> WorkerPool t +allocateWorkerPool t n = WorkerPool $ replicate n (Left t) + +addWorkerPool :: WorkerPool t -> Worker t -> WorkerPool t +addWorkerPool (WorkerPool l) w = WorkerPool (w:l) +addWorkerPool UnallocatedWorkerPool w = WorkerPool [w] + +idleWorkers :: WorkerPool t -> [t] +idleWorkers UnallocatedWorkerPool = [] +idleWorkers (WorkerPool l) = lefts l diff --git a/Utility/HttpManagerRestricted.hs b/Utility/HttpManagerRestricted.hs --- a/Utility/HttpManagerRestricted.hs +++ b/Utility/HttpManagerRestricted.hs @@ -30,11 +30,39 @@ import Data.Default import Data.Typeable import Control.Applicative +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif +import Data.Monoid +import Prelude data Restriction = Restriction - { addressRestriction :: AddrInfo -> Maybe ConnectionRestricted + { checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted } +appendRestrictions :: Restriction -> Restriction -> Restriction +appendRestrictions a b = Restriction + { checkAddressRestriction = \addr -> + checkAddressRestriction a addr <|> checkAddressRestriction b addr + } + +-- | mempty does not restrict HTTP connections in any way +instance Monoid Restriction where + mempty = Restriction + { checkAddressRestriction = \_ -> Nothing + } +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendRestrictions +#endif + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup Restriction where + (<>) = appendRestrictions +#endif + -- | An exception used to indicate that the connection was restricted. data ConnectionRestricted = ConnectionRestricted String deriving (Show, Typeable) @@ -117,7 +145,7 @@ return $ proxy $ f $ dummyreq https mkproxy Nothing = (noProxy, Nothing) - mkproxy (Just proxyaddr) = case addressRestriction cfg proxyaddr of + mkproxy (Just proxyaddr) = case checkAddressRestriction cfg proxyaddr of Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing) Just _ -> (noProxy, Just ProxyRestricted) @@ -200,7 +228,7 @@ close (\sock -> NC.connectFromSocket context sock connparams) where - tryToConnect addr = case addressRestriction cfg addr of + tryToConnect addr = case checkAddressRestriction cfg addr of Nothing -> bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close diff --git a/Utility/IPAddress.hs b/Utility/IPAddress.hs --- a/Utility/IPAddress.hs +++ b/Utility/IPAddress.hs @@ -12,8 +12,21 @@ import Network.Socket import Data.Word import Data.Memory.Endian +import Data.List import Control.Applicative +import Text.Printf import Prelude + +extractIPAddress :: SockAddr -> Maybe String +extractIPAddress (SockAddrInet _ ipv4) = + let (a,b,c,d) = hostAddressToTuple ipv4 + in Just $ intercalate "." [show a, show b, show c, show d] +extractIPAddress (SockAddrInet6 _ _ ipv6 _) = + let (a,b,c,d,e,f,g,h) = hostAddress6ToTuple ipv6 + in Just $ intercalate ":" [s a, s b, s c, s d, s e, s f, s g, s h] + where + s = printf "%x" +extractIPAddress _ = Nothing {- Check if an IP address is a loopback address; connecting to it - may connect back to the local host. -} diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -20,8 +20,7 @@ module Utility.Matcher ( Token(..), Matcher(..), - token, - tokens, + syntaxToken, generate, match, matchM, @@ -47,16 +46,13 @@ deriving (Show, Eq) {- Converts a word of syntax into a token. Doesn't handle operations. -} -token :: String -> Token op -token "and" = And -token "or" = Or -token "not" = Not -token "(" = Open -token ")" = Close -token t = error $ "unknown token " ++ t - -tokens :: [String] -tokens = words "and or not ( )" +syntaxToken :: String -> Either String (Token op) +syntaxToken "and" = Right And +syntaxToken "or" = Right Or +syntaxToken "not" = Right Not +syntaxToken "(" = Right Open +syntaxToken ")" = Right Close +syntaxToken t = Left $ "unknown token " ++ t {- Converts a list of Tokens into a Matcher. -} generate :: [Token op] -> Matcher op diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -1,6 +1,6 @@ {- Url downloading. - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - License: BSD-2-clause -} @@ -19,6 +19,7 @@ mkScheme, allowedScheme, UrlDownloader(..), + NonHttpUrlDownloader(..), UrlOptions(..), defUrlOptions, mkUrlOptions, @@ -40,18 +41,26 @@ import Common import Utility.Metered import Utility.HttpManagerRestricted +import Utility.IPAddress import Network.URI import Network.HTTP.Types +import qualified Network.Connection as NC import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Set as S +import Control.Exception (throwIO) import Control.Monad.Trans.Resource import Network.HTTP.Conduit import Network.HTTP.Client +import Network.HTTP.Simple (getResponseHeader) +import Network.Socket +import Network.BSD (getProtocolNumber) +import Data.Either import Data.Conduit +import Text.Read import System.Log.Logger #if ! MIN_VERSION_http_client(0,5,0) @@ -92,14 +101,17 @@ } data UrlDownloader - = DownloadWithConduit + = DownloadWithConduit NonHttpUrlDownloader | DownloadWithCurl [CommandParam] +data NonHttpUrlDownloader + = DownloadWithCurlRestricted Restriction + defUrlOptions :: IO UrlOptions defUrlOptions = UrlOptions <$> pure Nothing <*> pure [] - <*> pure DownloadWithConduit + <*> pure (DownloadWithConduit (DownloadWithCurlRestricted mempty)) <*> pure id <*> newManager managerSettings <*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"]) @@ -132,7 +144,7 @@ Just ua -> [Param "--user-agent", Param ua] headerparams = concatMap (\h -> [Param "-H", Param h]) (reqHeaders uo) addedparams = case urlDownloader uo of - DownloadWithConduit -> [] + DownloadWithConduit _ -> [] DownloadWithCurl l -> l schemeparams = [ Param "--proto" @@ -197,28 +209,39 @@ getUrlInfo url uo = case parseURIRelaxed url of Just u -> checkPolicy uo u dne warnError $ case (urlDownloader uo, parseUrlRequest (show u)) of - (DownloadWithConduit, Just req) -> - existsconduit req + (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust + -- When http redirects to a protocol which + -- conduit does not support, it will throw + -- a StatusCodeException with found302 + -- and a Response with the redir Location. + (matchStatusCodeException (== found302)) + (existsconduit req) + (followredir r) `catchNonAsync` (const $ return dne) - (DownloadWithConduit, Nothing) + (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> existsfile u + | isftpurl u -> existscurlrestricted r u url ftpport + `catchNonAsync` (const $ return dne) | otherwise -> do unsupportedUrlScheme u warnError return dne (DownloadWithCurl _, _) | isfileurl u -> existsfile u - | otherwise -> existscurl u + | otherwise -> existscurl u (basecurlparams url) Nothing -> return dne where dne = UrlInfo False Nothing Nothing found sz f = return $ UrlInfo True sz f isfileurl u = uriScheme u == "file:" + isftpurl u = uriScheme u == "ftp:" - curlparams = curlParams uo $ + ftpport = 21 + + basecurlparams u = curlParams uo $ [ Param "-s" , Param "--head" - , Param "-L", Param url + , Param "-L", Param u , Param "-w", Param "%{http_code}" ] @@ -247,7 +270,7 @@ (extractfilename resp) else return dne - existscurl u = do + existscurl u curlparams = do output <- catchDefaultIO "" $ readProcess "curl" $ toCommand curlparams let len = extractlencurl output @@ -264,6 +287,9 @@ _ | isftp && isJust len -> good _ -> return dne + existscurlrestricted r u url' defport = existscurl u + =<< curlRestrictedParams r u defport (basecurlparams url') + existsfile u = do let f = unEscapeString (uriPath u) s <- catchMaybeIO $ getFileStatus f @@ -272,6 +298,23 @@ sz <- getFileSize' f stat found (Just sz) Nothing Nothing -> return dne +#if MIN_VERSION_http_client(0,5,0) + followredir r (HttpExceptionRequest _ (StatusCodeException resp _)) = + case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of +#else + followredir r (StatusCodeException _ respheaders _) = + case headMaybe $ map (decodeBS . snd) $ filter (\(h, _) -> h == hLocation) respheaders +#endif + Just url' -> case parseURIRelaxed url' of + -- only follow http to ftp redirects; + -- http to file redirect would not be secure, + -- and http-conduit follows http to http. + Just u' | isftpurl u' -> + checkPolicy uo u' dne warnError $ + existscurlrestricted r u' url' ftpport + _ -> return dne + Nothing -> return dne + followredir _ _ = return dne -- Parse eg: attachment; filename="fname.ext" -- per RFC 2616 @@ -310,20 +353,27 @@ go = case parseURIRelaxed url of Just u -> checkPolicy uo u False dlfailed $ case (urlDownloader uo, parseUrlRequest (show u)) of - (DownloadWithConduit, Just req) -> - downloadconduit req - (DownloadWithConduit, Nothing) + (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust + (matchStatusCodeException (== found302)) + (downloadconduit req) + (followredir r) + (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> downloadfile u + | isftpurl u -> downloadcurlrestricted r u url ftpport + `catchNonAsync` (dlfailed . show) | otherwise -> unsupportedUrlScheme u dlfailed (DownloadWithCurl _, _) | isfileurl u -> downloadfile u - | otherwise -> downloadcurl + | otherwise -> downloadcurl url basecurlparams Nothing -> do liftIO $ debugM "url" url dlfailed "invalid url" isfileurl u = uriScheme u == "file:" + isftpurl u = uriScheme u == "ftp:" + ftpport = 21 + downloadconduit req = catchMaybeIO (getFileSize file) >>= \case Nothing -> runResourceT $ do liftIO $ debugM "url" (show req') @@ -405,27 +455,46 @@ sinkResponseFile meterupdate initialp file mode resp return True - downloadcurl = do + basecurlparams = curlParams uo + [ if noerror + then Param "-S" + else Param "-sS" + , Param "-f" + , Param "-L" + , Param "-C", Param "-" + ] + + downloadcurl rawurl curlparams = do -- curl does not create destination file -- if the url happens to be empty, so pre-create. unlessM (doesFileExist file) $ writeFile file "" - let ps = curlParams uo - [ if noerror - then Param "-S" - else Param "-sS" - , Param "-f" - , Param "-L" - , Param "-C", Param "-" - ] - boolSystem "curl" (ps ++ [Param "-o", File file, File url]) - + boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl]) + + downloadcurlrestricted r u rawurl defport = + downloadcurl rawurl =<< curlRestrictedParams r u defport basecurlparams + downloadfile u = do let src = unEscapeString (uriPath u) withMeteredFile src meterupdate $ L.writeFile file return True +#if MIN_VERSION_http_client(0,5,0) + followredir r ex@(HttpExceptionRequest _ (StatusCodeException resp _)) = + case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of +#else + followredir r ex@(StatusCodeException _ respheaders _) = + case headMaybe $ map (decodeBS . snd) $ filter (\(h, _) -> h == hLocation) respheaders +#endif + Just url' -> case parseURIRelaxed url' of + Just u' | isftpurl u' -> + checkPolicy uo u' False dlfailed $ + downloadcurlrestricted r u' url' ftpport + _ -> throwIO ex + Nothing -> throwIO ex + followredir _ ex = throwIO ex + {- Sinks a Response's body to a file. The file can either be opened in - WriteMode or AppendMode. Updates the meter as data is received. - @@ -554,3 +623,57 @@ | want e = Just e | otherwise = Nothing #endif + +{- Constructs parameters that prevent curl from accessing any IP addresses + - blocked by the Restriction. These are added to the input parameters, + - which should tell curl what to do. + - + - This has to disable redirects because it looks up the IP addresses + - of the host and after limiting to those allowed by the Restriction, + - makes curl resolve the host to those IP addresses. It doesn't make sense + - to use this for http anyway, only for ftp or perhaps other protocols + - supported by curl. + - + - Throws an exception if the Restriction blocks all addresses, or + - if the dns lookup fails. A malformed url will also cause an exception. + -} +curlRestrictedParams :: Restriction -> URI -> Int -> [CommandParam] -> IO [CommandParam] +curlRestrictedParams r u defport ps = case uriAuthority u of + Nothing -> giveup "malformed url" + Just uath -> case uriPort uath of + "" -> go (uriRegName uath) defport + -- strict parser because the port we provide to curl + -- needs to match the port in the url + (':':s) -> case readMaybe s :: Maybe Int of + Just p -> go (uriRegName uath) p + Nothing -> giveup "malformed url" + _ -> giveup "malformed url" + where + go hostname p = do + proto <- getProtocolNumber "tcp" + let serv = show p + let hints = defaultHints + { addrFlags = [AI_ADDRCONFIG] + , addrProtocol = proto + , addrSocketType = Stream + } + addrs <- getAddrInfo (Just hints) (Just hostname) (Just serv) + case partitionEithers (map checkrestriction addrs) of + ((e:_es), []) -> throwIO e + (_, as) + | null as -> throwIO $ + NC.HostNotResolved hostname + | otherwise -> return $ + (limitresolve p) as ++ ps + checkrestriction addr = maybe (Right addr) Left $ + checkAddressRestriction r addr + limitresolve p addrs = + [ Param "--resolve" + , Param $ "*:" ++ show p ++ ":" ++ intercalate ":" + (mapMaybe (bracketaddr <$$> extractIPAddress . addrAddress) addrs) + -- Don't let a ftp server provide an IP address. + , Param "--ftp-skip-pasv-ip" + -- Prevent all http redirects. + , Param "--max-redirs", Param "0" + ] + bracketaddr a = "[" ++ a ++ "]" diff --git a/doc/git-annex-add.mdwn b/doc/git-annex-add.mdwn --- a/doc/git-annex-add.mdwn +++ b/doc/git-annex-add.mdwn @@ -56,6 +56,8 @@ Adds multiple files in parallel. This may be faster. For example: `-J4` + Setting this to "cpus" will run one job per CPU core. + * `--update` `-u` Like `git add --update`, this does not add new files, but any updates diff --git a/doc/git-annex-addurl.mdwn b/doc/git-annex-addurl.mdwn --- a/doc/git-annex-addurl.mdwn +++ b/doc/git-annex-addurl.mdwn @@ -13,7 +13,7 @@ When `youtube-dl` is installed, it can be used to check for a video embedded in a web page at the url, and that is added to the annex instead. (However, this is disabled by default as it can be a security risk. -See the documentation of annex.security.allowed-http-addresses +See the documentation of annex.security.allowed-ip-addresses in [[git-annex]](1) for details.) Urls to torrent files (including magnet links) will cause the content of @@ -77,6 +77,8 @@ Enables parallel downloads when multiple urls are being added. For example: `-J4` + + Setting this to "cpus" will run one job per CPU core. * `--batch` diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn --- a/doc/git-annex-copy.mdwn +++ b/doc/git-annex-copy.mdwn @@ -34,6 +34,8 @@ Enables parallel transfers with up to the specified number of jobs running at once. For example: `-J10` + Setting this to "cpus" will run one job per CPU core. + * `--auto` Rather than copying all files, only copy files that don't yet have diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -77,6 +77,8 @@ when git-annex has to contact remotes to check if it can drop files. For example: `-J4` + Setting this to "cpus" will run one job per CPU core. + * `--batch` Enables batch mode, in which lines containing names of files to drop diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn --- a/doc/git-annex-export.mdwn +++ b/doc/git-annex-export.mdwn @@ -23,6 +23,9 @@ other treeish accepted by git, including eg master:subdir to only export a subdirectory from a branch. +When the remote has a preferred content setting, the treeish is filtered +through it, excluding files it does not want from being exported to it. + Repeated exports are done efficiently, by diffing the old and new tree, and transferring only the changed files, and renaming files as necessary. @@ -131,6 +134,8 @@ [[git-annex-import]](1) [[git-annex-sync]](1) + +[[git-annex-preferred-content]](1) # HISTORY diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -93,6 +93,8 @@ Runs multiple fsck jobs in parallel. For example: `-J4` + Setting this to "cpus" will run one job per CPU core. + * `--json` Enable JSON output. This is intended to be parsed by programs that use diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn --- a/doc/git-annex-get.mdwn +++ b/doc/git-annex-get.mdwn @@ -33,6 +33,8 @@ Enables parallel download with up to the specified number of jobs running at once. For example: `-J10` + Setting this to "cpus" will run one job per CPU core. + When files can be downloaded from multiple remotes, enabling parallel downloads will split the load between the remotes. For example, if the files are available on remotes A and B, then one file will be diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -12,7 +12,7 @@ repository. It can import files from a directory into your repository, or it can import files from a git-annex special remote. -## IMPORTING FROM A SPECIAL REMOTE +# IMPORTING FROM A SPECIAL REMOTE Importing from a special remote first downloads all new content from it, and then constructs a git commit that reflects files that have changed on @@ -49,10 +49,10 @@ `git annex export` files to a remote, and then `git annex import` from it, you won't need that option. -You can also limit the import to a subdirectory, using the -"branch:subdir" syntax. For example, if "camera" is a special remote -that accesses a camera, and you want to import those into the photos -directory, rather than to the root of your repository: +You can import into a subdirectory, using the "branch:subdir" syntax. For +example, if "camera" is a special remote that accesses a camera, and you +want to import those into the photos directory, rather than to the root of +your repository: git annex import master:photos --from camera git merge camera/master @@ -65,8 +65,20 @@ git config remote.myremote.annex-tracking-branch master git annex sync --content -## IMPORTING FROM A DIRECTORY +If a preferred content expression is configured for the special remote, +it will be honored when importing from it. Files that are not preferred +content of the remote will not be imported from it, but will be left on the +remote. +However, preferred content expressions that relate to the key +can't be matched when importing, because the content of the file is not +known. Importing will fail when such a preferred content expression is +set. This includes expressions containing "copies=", "metadata=", and other +things that depend on the key. Preferred content expressions containing +"include=", "exclude=" "smallerthan=", "largerthan=" will work. + +# IMPORTING FROM A DIRECTORY + When run with a path, `git annex import` moves files from somewhere outside the git working copy, and adds them to the annex. @@ -141,6 +153,8 @@ Imports multiple files in parallel. This may be faster. For example: `-J4` + Setting this to "cpus" will run one job per CPU core. + * `--json` Enable JSON output. This is intended to be parsed by programs that use @@ -167,6 +181,8 @@ [[git-annex-add]](1) [[git-annex-export]](1) + +[[git-annex-preferred-content]](1) # AUTHOR diff --git a/doc/git-annex-importfeed.mdwn b/doc/git-annex-importfeed.mdwn --- a/doc/git-annex-importfeed.mdwn +++ b/doc/git-annex-importfeed.mdwn @@ -16,7 +16,7 @@ When `youtube-dl` is installed, it can be used to download links in the feed. This allows importing e.g., YouTube playlists. (However, this is disabled by default as it can be a security risk. -See the documentation of annex.security.allowed-http-addresses +See the documentation of annex.security.allowed-ip-addresses in [[git-annex]](1) for details.) To make the import process add metadata to the imported files from the feed, diff --git a/doc/git-annex-mirror.mdwn b/doc/git-annex-mirror.mdwn --- a/doc/git-annex-mirror.mdwn +++ b/doc/git-annex-mirror.mdwn @@ -36,6 +36,8 @@ Enables parallel transfers with up to the specified number of jobs running at once. For example: `-J10` + Setting this to "cpus" will run one job per CPU core. + * `--all` `-A` Mirror all objects stored in the git annex, not only objects used by diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn --- a/doc/git-annex-move.mdwn +++ b/doc/git-annex-move.mdwn @@ -40,6 +40,8 @@ Enables parallel transfers with up to the specified number of jobs running at once. For example: `-J10` + Setting this to "cpus" will run one job per CPU core. + * `--all` `-A` Rather than specifying a filename or path to move, this option can be diff --git a/doc/git-annex-preferred-content.mdwn b/doc/git-annex-preferred-content.mdwn --- a/doc/git-annex-preferred-content.mdwn +++ b/doc/git-annex-preferred-content.mdwn @@ -37,12 +37,16 @@ Match files to include, or exclude. While --include=glob and --exclude=glob match files relative to the current - directory, preferred content expressions always match files relative to the - top of the git repository. + directory, preferred content expressions match files relative to the + top of the git repository. For example, suppose you put files into `archive` directories when you're done with them. Then you could configure your laptop to prefer to not retain those files, like this: `exclude=*/archive/*` + + When a subdirectory is being exported or imported to a special remote (see + [[git-annex-export]](1)) and [[git-annex-import]](1), these match relative + to the top of the subdirectory. * `copies=number` diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn --- a/doc/git-annex-sync.mdwn +++ b/doc/git-annex-sync.mdwn @@ -112,6 +112,8 @@ Enables parallel syncing with up to the specified number of jobs running at once. For example: `-J10` + Setting this to "cpus" will run one job per CPU core. + When there are multiple git remotes, pushes will be made to them in parallel. Pulls are not done in parallel because that tends to be less efficient. When --content is synced, the files are processed diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -952,6 +952,8 @@ Only git-annex commands that support the --jobs option will use this. + Setting this to "cpus" will run one job per CPU core. + * `annex.queuesize` git-annex builds a queue of git commands, in order to combine similar @@ -1424,7 +1426,7 @@ Or to make curl use your ~/.netrc file, set it to "--netrc". Setting this option makes git-annex use curl, but only - when annex.security.allowed-http-addresses is configured in a + when annex.security.allowed-ip-addresses is configured in a specific way. See its documentation. * `annex.youtube-dl-options` @@ -1467,10 +1469,11 @@ Some special remotes support their own domain-specific URL schemes; those are not affected by this configuration setting. -* `annex.security.allowed-http-addresses` +* `annex.security.allowed-ip-addresses` - By default, git-annex only makes HTTP connections to public IP addresses; - it will refuse to use HTTP servers on localhost or on a private network. + By default, git-annex only makes connections to public IP addresses; + it will refuse to use HTTP and other servers on localhost or on a + private network. This setting can override that behavior, allowing access to particular IP addresses. For example "127.0.0.1 ::1" allows access to localhost @@ -1478,13 +1481,19 @@ Think very carefully before changing this; there are security implications. Anyone who can get a commit into your git-annex repository - could `git annex addurl` an url on a private http server, possibly + could `git annex addurl` an url on a private server, possibly causing it to be downloaded into your repository and transferred to other remotes, exposing its content. Note that, since the interfaces of curl and youtube-dl do not allow these IP address restrictions to be enforced, curl and youtube-dl will - never be used unless annex.security.allowed-http-addresses=all. + never be used unless annex.security.allowed-ip-addresses=all. + +* `annex.security.allowed-http-addresses` + + Old name for annex.security.allowed-ip-addresses. + If set, this is treated the same as having + annex.security.allowed-ip-addresses set. * `annex.security.allow-unverified-downloads` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 7.20190507 +Version: 7.20190615 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -1001,6 +1001,7 @@ Types.UUID Types.UrlContents Types.View + Types.WorkerPool Upgrade Upgrade.V0 Upgrade.V1