diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -1,10 +1,12 @@ {- git-annex exports - - - Copyright 2017 Joey Hess + - Copyright 2017-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Export where import Annex @@ -15,31 +17,42 @@ import qualified Types.Remote as Remote import Messages -import Control.Applicative import Data.Maybe -import Prelude --- An export includes both annexed files and files stored in git. --- For the latter, a SHA1 key is synthesized. -data ExportKey = AnnexKey Key | GitKey Key - deriving (Show, Eq, Ord) - -asKey :: ExportKey -> Key -asKey (AnnexKey k) = k -asKey (GitKey k) = k - -exportKey :: Git.Sha -> Annex ExportKey +-- From a sha pointing to the content of a file to the key +-- to use to export it. When the file is annexed, it's the annexed key. +-- When the file is stored in git, it's a special type of key to indicate +-- that. +exportKey :: Git.Sha -> Annex Key exportKey sha = mk <$> catKey sha where - mk (Just k) = AnnexKey k - mk Nothing = GitKey $ mkKey $ \k -> k - { keyName = Git.fromRef' sha - , keyVariety = SHA1Key (HasExt False) - , keySize = Nothing - , keyMtime = Nothing - , keyChunkSize = Nothing - , keyChunkNum = Nothing - } + mk (Just k) = k + mk Nothing = gitShaKey sha + +-- Encodes a git sha as a key. This is used to represent a non-annexed +-- file that is stored on a special remote, which necessarily needs a +-- key. +-- +-- This is not the same as a SHA1 key, because the mapping needs to be +-- bijective, also because git may not always use SHA1, and because git +-- takes a SHA1 of the file size + content, while git-annex SHA1 keys +-- only checksum the content. +gitShaKey :: Git.Sha -> Key +gitShaKey (Git.Ref s) = mkKey $ \kd -> kd + { keyName = s + , keyVariety = OtherKey "GIT" + } + +-- Reverse of gitShaKey +keyGitSha :: Key -> Maybe Git.Sha +keyGitSha k + | fromKey keyVariety k == OtherKey "GIT" = + Just (Git.Ref (fromKey keyName k)) + | otherwise = Nothing + +-- Is a key storing a git sha, and not used for an annexed file? +isGitShaKey :: Key -> Bool +isGitShaKey = isJust . keyGitSha warnExportImportConflict :: Remote -> Annex () warnExportImportConflict r = do diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -75,7 +75,15 @@ (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file mkey (Just key, AssociatedFile Nothing) -> - go (MatchingKey key afile) + let i = ProvidedInfo + { providedFilePath = Nothing + , providedKey = Just key + , providedFileSize = Nothing + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + , providedLinkType = Nothing + } + in go (MatchingInfo i) (Nothing, _) -> d where go mi = checkMatcher' matcher mi notpresent @@ -89,7 +97,7 @@ matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo { matchFile = matchfile - , contentFile = Just file + , contentFile = file , matchKey = mkey } diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -179,11 +179,11 @@ updatelocationlog oldexport finaltree = do let stillpresent db k = liftIO $ not . null <$> Export.getExportedLocation db k - let updater db oldkey _newkey _ = case oldkey of - Just (AnnexKey k) -> unlessM (stillpresent db k) $ - logChange k (Remote.uuid remote) InfoMissing - Just (GitKey _) -> noop - Nothing -> noop + let updater db moldkey _newkey _ = case moldkey of + Just oldkey | not (isGitShaKey oldkey) -> + unlessM (stillpresent db oldkey) $ + logChange oldkey (Remote.uuid remote) InfoMissing + _ -> noop db <- Export.openDb (Remote.uuid remote) forM_ (exportedTreeishes oldexport) $ \oldtree -> Export.runExportDiffUpdater updater db oldtree finaltree @@ -454,11 +454,12 @@ when (Utility.Matcher.introspect matchNeedsFileContent matcher) $ giveup "annex.largefiles configuration examines file contents, so cannot import without content." let mi = MatchingInfo ProvidedInfo - { providedFilePath = f + { providedFilePath = Just f , providedKey = Nothing - , providedFileSize = sz + , providedFileSize = Just sz , providedMimeType = Nothing , providedMimeEncoding = Nothing + , providedLinkType = Nothing } islargefile <- checkMatcher' matcher mi mempty metered Nothing sz $ const $ if islargefile @@ -568,7 +569,7 @@ mkkey tmpfile = do let mi = MatchingFile FileInfo { matchFile = f - , contentFile = Just tmpfile + , contentFile = tmpfile , matchKey = Nothing } islargefile <- checkMatcher' matcher mi mempty @@ -703,11 +704,12 @@ matchesImportLocation matcher loc sz = checkMatcher' matcher mi mempty where mi = MatchingInfo $ ProvidedInfo - { providedFilePath = fromImportLocation loc + { providedFilePath = Just (fromImportLocation loc) , providedKey = Nothing - , providedFileSize = sz + , providedFileSize = Just sz , providedMimeType = Nothing , providedMimeEncoding = Nothing + , providedLinkType = Nothing } notIgnoredImportLocation :: ImportTreeConfig -> CheckGitIgnore -> ImportLocation -> Annex Bool diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -383,19 +383,19 @@ af = AssociatedFile (Just file) mi = case mtmp of Just tmp -> MatchingFile $ FileInfo - { contentFile = Just tmp + { contentFile = tmp , matchFile = file , matchKey = Just key } -- Provide as much info as we can without access to the -- file's content. Nothing -> MatchingInfo $ ProvidedInfo - { providedFilePath = file + { providedFilePath = Just file , providedKey = Just key - , providedFileSize = fromMaybe 0 $ - keySize `fromKey` key + , providedFileSize = Nothing , providedMimeType = Nothing , providedMimeEncoding = Nothing + , providedLinkType = Nothing } linkunlocked mode = linkFromAnnex key file mode >>= \case diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,28 @@ +git-annex (8.20210310) upstream; urgency=medium + + * When non-annexed files in a tree are exported to a special remote, + importing from the special remote keeps the files non-annexed, + as long as their content has not changed, rather than converting + them to annexed files. + (Such a conversion will still happen when importing from a remote + an old git-annex exported such a tree to before; export the tree + with the new git-annex before importing to avoid that.) + * Added support for git-remote-gcrypt's rsync URIs, which access a remote + using rsync over ssh, and which git pushes to much more efficiently + than ssh urls. + * unregisterurl: New command. + * registerurl: Allow it to be used in a bare repository. + * Prevent combinations of options such as --all with --include. + * Fixed handling of --mimetype or --mimeencoding combined with + options like --all or --unused. + * Fix handling of --branch combined with --unlocked or --locked. + * Fix support for local gcrypt repositories with a space in their URI. + * uninit: Fix a small bug that left a lock file in .git/annex + * Windows: Correct the path to the html help file for 64 bit build. + * OSX dmg: Updated bundled git to 2.30.2 which fixes CVE-2021-21300. + + -- Joey Hess Wed, 10 Mar 2021 13:58:15 -0400 + git-annex (8.20210223) upstream; urgency=medium * annex.stalldetection can now be set to "true" to make git-annex diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -131,7 +131,7 @@ matcher <- getMatcher go $ \si f -> let f' = toRawFilePath f - in ifM (matcher $ MatchingFile $ FileInfo (Just f') f' Nothing) + in ifM (matcher $ MatchingFile $ FileInfo f' f' Nothing) ( a (si, f') , return Nothing ) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -1,6 +1,6 @@ {- git-annex main program - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -33,6 +33,7 @@ import qualified Command.MatchExpression import qualified Command.FromKey import qualified Command.RegisterUrl +import qualified Command.UnregisterUrl import qualified Command.SetKey import qualified Command.DropKey import qualified Command.Transferrer @@ -178,6 +179,7 @@ , Command.MatchExpression.cmd , Command.FromKey.cmd , Command.RegisterUrl.cmd + , Command.UnregisterUrl.cmd , Command.SetKey.cmd , Command.DropKey.cmd , Command.Transferrer.cmd diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -22,6 +22,7 @@ import qualified Git.LsTree as LsTree import qualified Git.Types as Git import qualified Git.Ref +import Git.Types (toTreeItemType, TreeItemType(..)) import Git.FilePath import qualified Limit import CmdLine.GitAnnex.Options @@ -30,6 +31,7 @@ import Logs.Unused import Types.Transfer import Logs.Transfer +import Types.Link import Remote.List import qualified Remote import Annex.CatFile @@ -121,7 +123,7 @@ p' = toRawFilePath p checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo - { contentFile = Just f + { contentFile = f , matchFile = relf , matchKey = Nothing } @@ -191,12 +193,27 @@ where mkkeyaction = do matcher <- Limit.getMatcher - return $ \v@(_si, k, ai) -> checkseeker k $ + return $ \lt v@(_si, k, ai) -> checkseeker k $ let i = case ai of ActionItemBranchFilePath (BranchFilePath _ topf) _ -> - MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) - _ -> MatchingKey k (AssociatedFile Nothing) - in whenM (matcher i) $ + ProvidedInfo + { providedFilePath = Just $ + getTopFilePath topf + , providedKey = Just k + , providedFileSize = Nothing + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + , providedLinkType = lt + } + _ -> ProvidedInfo + { providedFilePath = Nothing + , providedKey = Just k + , providedFileSize = Nothing + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + , providedLinkType = lt + } + in whenM (matcher (MatchingInfo i)) $ keyaction v checkseeker k a = case checkContentPresent seeker of Nothing -> a @@ -207,7 +224,7 @@ withKeyOptions' :: Maybe KeyOptions -> Bool - -> Annex ((SeekInput, Key, ActionItem) -> Annex ()) + -> Annex (Maybe LinkType -> (SeekInput, Key, ActionItem) -> Annex ()) -> (WorkTreeItems -> CommandSeek) -> WorkTreeItems -> CommandSeek @@ -217,21 +234,30 @@ giveup "Cannot use --auto in a bare repository" case (noworktreeitems, ko) of (True, Nothing) - | bare -> noauto runallkeys + | bare -> nofilename $ noauto runallkeys | otherwise -> fallbackaction worktreeitems (False, Nothing) -> fallbackaction worktreeitems - (True, Just WantAllKeys) -> noauto runallkeys - (True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys' - (True, Just WantFailedTransfers) -> noauto runfailedtransfers - (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k]) - (True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys + (True, Just WantAllKeys) -> nofilename $ noauto runallkeys + (True, Just WantUnusedKeys) -> nofilename $ noauto $ runkeyaction unusedKeys' + (True, Just WantFailedTransfers) -> nofilename $ noauto runfailedtransfers + (True, Just (WantSpecificKey k)) -> nofilename $ noauto $ runkeyaction (return [k]) + (True, Just WantIncompleteKeys) -> nofilename $ noauto $ runkeyaction incompletekeys (True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs (False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" where noauto a | auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" | otherwise = a - + + nofilename a = ifM (Limit.introspect matchNeedsFileName) + ( do + bare <- fromRepo Git.repoIsLocalBare + if bare + then giveup "Cannot use options that match on file names in a bare repository." + else giveup "Cannot use --all or --unused or --key or --incomplete with options that match on file names." + , a + ) + noworktreeitems = case worktreeitems of WorkTreeItems [] -> True WorkTreeItems _ -> False @@ -262,7 +288,7 @@ Nothing -> return () Just ((k, f), content) -> checktimelimit (discard reader) $ do maybe noop (Annex.BranchState.setCache f) content - keyaction (SeekInput [], k, mkActionItem k) + keyaction Nothing (SeekInput [], k, mkActionItem k) go reader catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go liftIO $ void cleanup @@ -270,17 +296,22 @@ runkeyaction getks = do keyaction <- mkkeyaction ks <- getks - forM_ ks $ \k -> keyaction (SeekInput [], k, mkActionItem k) + forM_ ks $ \k -> keyaction Nothing (SeekInput [], k, mkActionItem k) runbranchkeys bs = do keyaction <- mkkeyaction forM_ bs $ \b -> do (l, cleanup) <- inRepo $ LsTree.lsTree LsTree.LsTreeRecursive b forM_ l $ \i -> catKey (LsTree.sha i) >>= \case - Nothing -> noop Just k -> let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k) - in keyaction (SeekInput [], k, bfp) + lt = case toTreeItemType (LsTree.mode i) of + Just TreeSymlink -> Just LockedLink + Just TreeFile -> Just UnlockedLink + Just TreeExecutable -> Just UnlockedLink + _ -> Nothing + in keyaction lt (SeekInput [], k, bfp) + Nothing -> noop unlessM (liftIO cleanup) $ error ("git ls-tree " ++ Git.fromRef b ++ " failed") @@ -289,7 +320,7 @@ rs <- remoteList ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs forM_ ts $ \(t, i) -> - keyaction (SeekInput [], transferKey t, mkActionItem (t, i)) + keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i)) seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex () seekFiltered prefilter a listfs = do @@ -302,7 +333,7 @@ go _ _ [] = return () go matcher checktimelimit (v@(_si, f):rest) = checktimelimit noop $ do whenM (prefilter v) $ - whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ + whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $ a v go matcher checktimelimit rest @@ -366,7 +397,7 @@ maybe noop (Annex.BranchState.setCache logf) logcontent checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) - (MatchingFile $ FileInfo (Just f) f (Just k)) + (MatchingFile $ FileInfo f f (Just k)) (commandAction $ startAction seeker si f k) precachefinisher mi lreader checktimelimit Nothing -> return () @@ -390,14 +421,14 @@ -- checked later, to avoid a slow lookup here. (not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) && not (matcherNeedsFileName mi))) - (MatchingFile $ FileInfo (Just f) f Nothing) + (MatchingFile $ FileInfo f f Nothing) (liftIO $ ofeeder ((si, f), sha)) keyaction f mi content a = case parseLinkTargetOrPointerLazy =<< content of Just k -> checkMatcherWhen mi (matcherNeedsKey mi && not (matcherNeedsFileName mi || matcherNeedsLocationLog mi)) - (MatchingFile $ FileInfo (Just f) f (Just k)) + (MatchingFile $ FileInfo f f (Just k)) (checkpresence k (a k)) Nothing -> noop diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -171,7 +171,7 @@ perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do lockingfile <- not <$> addUnlocked addunlockedmatcher - (MatchingFile (FileInfo (Just file) file Nothing)) + (MatchingFile (FileInfo file file Nothing)) True let cfg = LockDownConfig { lockingFile = lockingfile diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -72,9 +72,9 @@ -- To handle renames which swap files, the exported file is first renamed -- to a stable temporary name based on the key. -exportTempName :: ExportKey -> ExportLocation +exportTempName :: Key -> ExportLocation exportTempName ek = mkExportLocation $ toRawFilePath $ - ".git-annex-tmp-content-" ++ serializeKey (asKey (ek)) + ".git-annex-tmp-content-" ++ serializeKey ek seek :: ExportOptions -> CommandSeek seek o = startConcurrency commandStages $ do @@ -203,8 +203,8 @@ sequence_ $ map a diff void $ liftIO cleanup --- Map of old and new filenames for each changed ExportKey in a diff. -type DiffMap = M.Map ExportKey (Maybe TopFilePath, Maybe TopFilePath) +-- Map of old and new filenames for each changed Key in a diff. +type DiffMap = M.Map Key (Maybe TopFilePath, Maybe TopFilePath) mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap mkDiffMap old new db = do @@ -259,7 +259,7 @@ ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ starting ("export " ++ name r) ai si $ - ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) + ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) ek loc)) ( next $ cleanupExport r db ek loc False , do liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True)) @@ -272,39 +272,38 @@ ai = ActionItemOther (Just (fromRawFilePath f)) si = SeekInput [] notrecordedpresent ek = (||) - <$> liftIO (notElem loc <$> getExportedLocation db (asKey ek)) + <$> liftIO (notElem loc <$> getExportedLocation db ek) -- If content was removed from the remote, the export db -- will still list it, so also check location tracking. - <*> (notElem (uuid r) <$> loggedLocations (asKey ek)) + <*> (notElem (uuid r) <$> loggedLocations ek) -performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform +performExport :: Remote -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform performExport r db ek af contentsha loc allfilledvar = do let storer = storeExport (exportActions r) - sent <- tryNonAsync $ case ek of - AnnexKey k -> ifM (inAnnex k) + sent <- tryNonAsync $ if not (isGitShaKey ek) + then ifM (inAnnex ek) ( notifyTransfer Upload af $ -- alwaysUpload because the same key -- could be used for more than one export -- location, and concurrently uploading -- of the content should still be allowed. - alwaysUpload (uuid r) k af Nothing stdRetry $ \pm -> do + alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc - sendAnnex k rollback $ \f -> + sendAnnex ek rollback $ \f -> Remote.action $ - storer f k loc pm + storer f ek loc pm , do showNote "not available" return False ) -- Sending a non-annexed file. - GitKey sha1k -> - withTmpFile "export" $ \tmp h -> do - b <- catObject contentsha - liftIO $ L.hPut h b - liftIO $ hClose h - Remote.action $ - storer tmp sha1k loc nullMeterUpdate + else withTmpFile "export" $ \tmp h -> do + b <- catObject contentsha + liftIO $ L.hPut h b + liftIO $ hClose h + Remote.action $ + storer tmp ek loc nullMeterUpdate let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False)) case sent of Right True -> next $ cleanupExport r db ek loc True @@ -315,11 +314,11 @@ failedsend throwM err -cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> Bool -> CommandCleanup +cleanupExport :: Remote -> ExportHandle -> Key -> ExportLocation -> Bool -> CommandCleanup cleanupExport r db ek loc sent = do - liftIO $ addExportedLocation db (asKey ek) loc - when sent $ - logChange (asKey ek) (uuid r) InfoPresent + liftIO $ addExportedLocation db ek loc + when (sent && not (isGitShaKey ek)) $ + logChange ek (uuid r) InfoPresent return True startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart @@ -335,7 +334,7 @@ ai = ActionItemOther (Just (fromRawFilePath f')) si = SeekInput [] -startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart +startUnexport' :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart startUnexport' r db f ek = starting ("unexport " ++ name r) ai si $ performUnexport r db [ek] loc @@ -350,20 +349,20 @@ -- remote is untrusted, so would not count as a copy anyway. -- Or, an export may be appendonly, and removing a file from it does -- not really remove the content, which must be accessible later on. -performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform +performUnexport :: Remote -> ExportHandle -> [Key] -> ExportLocation -> CommandPerform performUnexport r db eks loc = do ifM (allM rm eks) ( next $ cleanupUnexport r db eks loc , stop ) where - rm ek = Remote.action $ removeExport (exportActions r) (asKey ek) loc + rm ek = Remote.action $ removeExport (exportActions r) ek loc -cleanupUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup +cleanupUnexport :: Remote -> ExportHandle -> [Key] -> ExportLocation -> CommandCleanup cleanupUnexport r db eks loc = do liftIO $ do forM_ eks $ \ek -> - removeExportedLocation db (asKey ek) loc + removeExportedLocation db ek loc flushDbQueue db -- An versionedExport remote supports removeExportLocation to remove @@ -371,12 +370,12 @@ -- and allows retrieving it. unless (versionedExport (exportActions r)) $ do remaininglocs <- liftIO $ - concat <$> forM eks (\ek -> getExportedLocation db (asKey ek)) + concat <$> forM eks (getExportedLocation db) when (null remaininglocs) $ forM_ eks $ \ek -> - logChange (asKey ek) (uuid r) InfoMissing + logChange ek (uuid r) InfoMissing - removeEmptyDirectories r db loc (map asKey eks) + removeEmptyDirectories r db loc eks startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart startRecoverIncomplete r db sha oldf @@ -387,12 +386,12 @@ let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation loc))) let si = SeekInput [] starting ("unexport " ++ name r) ai si $ do - liftIO $ removeExportedLocation db (asKey ek) oldloc + liftIO $ removeExportedLocation db ek oldloc performUnexport r db [ek] loc where oldloc = mkExportLocation $ getTopFilePath oldf -startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart +startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart startMoveToTempName r db f ek = starting ("rename " ++ name r) ai si $ performRename r db ek loc tmploc @@ -403,11 +402,11 @@ ai = ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc) si = SeekInput [] -startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart +startMoveFromTempName :: Remote -> ExportHandle -> Key -> TopFilePath -> CommandStart startMoveFromTempName r db ek f = do let tmploc = exportTempName ek let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f')) - stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ + stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $ starting ("rename " ++ name r) ai si $ performRename r db ek tmploc loc where @@ -415,9 +414,9 @@ f' = getTopFilePath f si = SeekInput [] -performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform +performRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandPerform performRename r db ek src dest = - tryNonAsync (renameExport (exportActions r) (asKey ek) src dest) >>= \case + tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case Right (Just ()) -> next $ cleanupRename r db ek src dest Left err -> do warning $ "rename failed (" ++ show err ++ "); deleting instead" @@ -427,14 +426,14 @@ where fallbackdelete = performUnexport r db [ek] src -cleanupRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup +cleanupRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandCleanup cleanupRename r db ek src dest = do liftIO $ do - removeExportedLocation db (asKey ek) src - addExportedLocation db (asKey ek) dest + removeExportedLocation db ek src + addExportedLocation db ek dest flushDbQueue db if exportDirectories src /= exportDirectories dest - then removeEmptyDirectories r db src [asKey ek] + then removeEmptyDirectories r db src [ek] else return True -- | Remove empty directories from the export. Call after removing an @@ -491,11 +490,17 @@ 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 + let mi = MatchingInfo $ ProvidedInfo + { providedFilePath = Just $ + -- Match filename relative + -- to the top of the tree. + getTopFilePath topf + , providedKey = Just k + , providedFileSize = Nothing + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + , providedLinkType = Nothing + } ifM (checkMatcher' matcher mi mempty) ( return (Just ti) , do diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -239,7 +239,7 @@ stop lockdown a = do let mi = MatchingFile $ FileInfo - { contentFile = Just srcfile + { contentFile = srcfile , matchFile = destfile , matchKey = Nothing } diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -569,7 +569,7 @@ where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = - ifM (matcher $ MatchingFile $ FileInfo (Just file) file (Just key)) + ifM (matcher $ MatchingFile $ FileInfo file file (Just key)) ( do !presentdata' <- ifM (inAnnex key) ( return $ addKey key presentdata diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -135,7 +135,7 @@ (fs', cleanup) <- seekHelper id ww LsFiles.inRepo =<< workTreeItems ww fs matcher <- Limit.getMatcher - let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ + let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $ liftIO $ hPutStrLn h o forM_ fs' $ \(_, f) -> do mk <- lookupKey f diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -15,11 +15,10 @@ import qualified Remote cmd :: Command -cmd = notBareRepo $ - command "registerurl" - SectionPlumbing "registers an url for a key" - (paramPair paramKey paramUrl) - (seek <$$> optParser) +cmd = command "registerurl" + SectionPlumbing "registers an url for a key" + (paramPair paramKey paramUrl) + (seek <$$> optParser) data RegisterUrlOptions = RegisterUrlOptions { keyUrlPairs :: CmdParams @@ -33,43 +32,43 @@ seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of - (Batch fmt, _) -> commandAction $ startMass fmt + (Batch fmt, _) -> commandAction $ startMass setUrlPresent fmt -- older way of enabling batch input, does not support BatchNull - (NoBatch, []) -> commandAction $ startMass BatchLine - (NoBatch, ps) -> withWords (commandAction . start) ps + (NoBatch, []) -> commandAction $ startMass setUrlPresent BatchLine + (NoBatch, ps) -> withWords (commandAction . start setUrlPresent) ps -start :: [String] -> CommandStart -start (keyname:url:[]) = +start :: (Key -> URLString -> Annex ()) -> [String] -> CommandStart +start a (keyname:url:[]) = starting "registerurl" ai si $ - perform (keyOpt keyname) url + perform a (keyOpt keyname) url where ai = ActionItemOther (Just url) si = SeekInput [keyname, url] -start _ = giveup "specify a key and an url" +start _ _ = giveup "specify a key and an url" -startMass :: BatchFormat -> CommandStart -startMass fmt = +startMass :: (Key -> URLString -> Annex ()) -> BatchFormat -> CommandStart +startMass a fmt = starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $ - massAdd fmt + performMass a fmt -massAdd :: BatchFormat -> CommandPerform -massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt +performMass :: (Key -> URLString -> Annex ()) -> BatchFormat -> CommandPerform +performMass a fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt where go status [] = next $ return status go status ((keyname,u):rest) | not (null keyname) && not (null u) = do let key = keyOpt keyname - ok <- perform' key u + ok <- perform' a key u let !status' = status && ok go status' rest go _ _ = giveup "Expected pairs of key and url on stdin, but got something else." -perform :: Key -> URLString -> CommandPerform -perform key url = do - ok <- perform' key url +perform :: (Key -> URLString -> Annex ()) -> Key -> URLString -> CommandPerform +perform a key url = do + ok <- perform' a key url next $ return ok -perform' :: Key -> URLString -> Annex Bool -perform' key url = do +perform' :: (Key -> URLString -> Annex ()) -> Key -> URLString -> Annex Bool +perform' a key url = do r <- Remote.claimingUrl url - setUrlPresent key (setDownloader' url r) + a key (setDownloader' url r) return True diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -711,7 +711,7 @@ pure Nothing waitForAllRunningCommandActions withKeyOptions' (keyOptions o) False - (return (commandAction . gokey mvar bloom)) + (return (const (commandAction . gokey mvar bloom))) (const noop) (WorkTreeItems []) waitForAllRunningCommandActions diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -13,6 +13,7 @@ import qualified Git.Command import qualified Command.Unannex import qualified Annex.Branch +import qualified Annex.Queue import qualified Database.Keys import Annex.Content import Annex.Init @@ -65,6 +66,7 @@ finish :: Annex () finish = do + Annex.Queue.flush annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< listKeys InAnnex diff --git a/Command/UnregisterUrl.hs b/Command/UnregisterUrl.hs new file mode 100644 --- /dev/null +++ b/Command/UnregisterUrl.hs @@ -0,0 +1,25 @@ +{- git-annex command + - + - Copyright 2015-2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Command.UnregisterUrl where + +import Command +import Logs.Web +import Command.RegisterUrl (start, startMass, optParser, RegisterUrlOptions(..)) + +cmd :: Command +cmd = command "unregisterurl" + SectionPlumbing "unregisters an url for a key" + (paramPair paramKey paramUrl) + (seek <$$> optParser) + +seek :: RegisterUrlOptions -> CommandSeek +seek o = case (batchOption o, keyUrlPairs o) of + (Batch fmt, _) -> commandAction $ startMass setUrlMissing fmt + (NoBatch, ps) -> withWords (commandAction . start setUrlMissing) ps diff --git a/Database/Export.hs b/Database/Export.hs --- a/Database/Export.hs +++ b/Database/Export.hs @@ -200,9 +200,9 @@ -- and updates state. type ExportDiffUpdater = ExportHandle - -> Maybe ExportKey + -> Maybe Key -- ^ old exported key - -> Maybe ExportKey + -> Maybe Key -- ^ new exported key -> Git.DiffTree.DiffTreeItem -> Annex () @@ -214,10 +214,10 @@ mkExportDiffUpdater removeold addnew h srcek dstek i = do case srcek of Nothing -> return () - Just k -> liftIO $ removeold h (asKey k) loc + Just k -> liftIO $ removeold h k loc case dstek of Nothing -> return () - Just k -> liftIO $ addnew h (asKey k) loc + Just k -> liftIO $ addnew h k loc where loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -19,6 +19,7 @@ import Utility.Gpg import qualified Data.ByteString as S +import qualified Network.URI urlScheme :: String urlScheme = "gcrypt:" @@ -48,7 +49,13 @@ go' u | urlPrefix `isPrefixOf` u = - fromRemoteLocation (drop plen u) baserepo + let l = drop plen u + -- Git.Construct.fromUrl escapes characters + -- that are not allowed in URIs (though git + -- allows them); need to de-escape any such + -- to get back the path to the repository. + l' = Network.URI.unEscapeString l + in fromRemoteLocation l' baserepo | otherwise = notencrypted notencrypted = giveup "not a gcrypt encrypted repository" diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -99,7 +99,9 @@ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs (prefix, suffix) = ("url." , ".insteadof") - urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v + -- git supports URIs that contain unescaped characters such as + -- spaces. So to test if it's a (git) URI, escape those. + urlstyle v = isURI (escapeURIString isUnescapedInURI v) -- git remotes can be written scp style -- [user@]host:dir -- but foo::bar is a git-remote-helper location instead scpstyle v = ":" `isInfixOf` v diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -23,8 +23,6 @@ nonChunkKey, chunkKeyOffset, isChunkKey, - gitShaKey, - keyGitSha, isKeyPrefix, splitKeyNameExtension, @@ -37,7 +35,6 @@ import Common import Types.Key -import Git.Types import Utility.QuickCheck import Utility.Bloom import Utility.Aeson @@ -60,23 +57,6 @@ isChunkKey :: Key -> Bool isChunkKey k = isJust (fromKey keyChunkSize k) && isJust (fromKey keyChunkNum k) - --- Encodes a git sha as a key. --- --- This is not the same as a SHA1 key, because the mapping needs to be --- bijective, also because git may not always use SHA1. -gitShaKey :: Sha -> Key -gitShaKey (Ref s) = mkKey $ \kd -> kd - { keyName = s - , keyVariety = OtherKey "GIT" - } - --- Reverse of gitShaKey -keyGitSha :: Key -> Maybe Sha -keyGitSha k - | fromKey keyVariety k == OtherKey "GIT" = - Just (Ref (fromKey keyName k)) - | otherwise = Nothing serializeKey :: Key -> String serializeKey = decodeBS' . serializeKey' diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -16,6 +16,7 @@ import Annex.UUID import Annex.Magic import Annex.Link +import Types.Link import Logs.Trust import Annex.NumCopies import Types.Key @@ -116,10 +117,10 @@ where cglob = compileGlob glob CaseSensative (GlobFilePath True) -- memoized go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) - go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p)) + go (MatchingInfo p) = pure $ case providedFilePath p of + Just f -> matchGlob cglob (fromRawFilePath f) + Nothing -> False go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) - go (MatchingKey _ (AssociatedFile Nothing)) = pure False - go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af) addMimeType :: String -> Annex () addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType userProvidedMimeType @@ -159,23 +160,26 @@ matchMagic _limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = Right $ MatchFiles { matchAction = const go - , matchNeedsFileName = True + , matchNeedsFileName = False , matchNeedsFileContent = True , matchNeedsKey = False , matchNeedsLocationLog = False } where cglob = compileGlob glob CaseSensative (GlobFilePath False) -- memoized - go (MatchingKey _ _) = pure False - go (MatchingFile fi) = case contentFile fi of - Just f -> catchBoolIO $ - maybe False (matchGlob cglob) - <$> querymagic magic (fromRawFilePath f) - Nothing -> return False - go (MatchingInfo p) = pure $ - maybe False (matchGlob cglob) (selectprovidedinfo p) + go (MatchingFile fi) = catchBoolIO $ + maybe False (matchGlob cglob) + <$> querymagic magic (fromRawFilePath (contentFile fi)) + go (MatchingInfo p) = maybe + (usecontent (providedKey p)) + (pure . matchGlob cglob) + (selectprovidedinfo p) go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p) + usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $ + maybe False (matchGlob cglob) + <$> querymagic magic (fromRawFilePath obj) + usecontent Nothing = pure False matchMagic limitname _ _ _ Nothing _ = Left $ "unable to load magic database; \""++limitname++"\" cannot be used" @@ -198,17 +202,19 @@ } matchLockStatus :: Bool -> MatchInfo -> Annex Bool -matchLockStatus _ (MatchingKey _ _) = pure False -matchLockStatus _ (MatchingInfo _) = pure False +matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do + let f = contentFile fi + islocked <- isPointerFile f >>= \case + Just _key -> return False + Nothing -> isSymbolicLink + <$> getSymbolicLinkStatus (fromRawFilePath f) + return (islocked == wantlocked) +matchLockStatus wantlocked (MatchingInfo p) = + pure $ case providedLinkType p of + Nothing -> False + Just LockedLink -> wantlocked + Just UnlockedLink -> not wantlocked matchLockStatus _ (MatchingUserInfo _) = pure False -matchLockStatus wantlocked (MatchingFile fi) = case contentFile fi of - Just f -> liftIO $ do - islocked <- isPointerFile f >>= \case - Just _key -> return False - Nothing -> isSymbolicLink - <$> getSymbolicLinkStatus (fromRawFilePath f) - return (islocked == wantlocked) - Nothing -> return False {- Adds a limit to skip files not believed to be present - in a specfied repository. Optionally on a prior date. -} @@ -270,9 +276,7 @@ } where go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi - go (MatchingKey _ (AssociatedFile Nothing)) = return False - go (MatchingKey _ (AssociatedFile (Just af))) = checkf $ fromRawFilePath af - go (MatchingInfo p) = checkf $ fromRawFilePath $ providedFilePath p + go (MatchingInfo p) = maybe (pure False) (checkf . fromRawFilePath) (providedFilePath p) go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p) checkf = return . elem dir . splitPath . takeDirectory @@ -333,7 +337,6 @@ else case mi of MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi - MatchingKey _ _ -> approxNumCopies MatchingInfo {} -> approxNumCopies MatchingUserInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) @@ -356,7 +359,6 @@ } where go _ (MatchingFile _) = return False - go _ (MatchingKey k _) = isunused k go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p) go _ (MatchingUserInfo p) = do k <- getUserInfo (userProvidedKey p) @@ -460,21 +462,18 @@ } where go sz _ (MatchingFile fi) = case lb of - LimitAnnexFiles -> goannexed sz fi - LimitDiskFiles -> case contentFile fi of - Just f -> do - filesize <- liftIO $ catchMaybeIO $ getFileSize f - return $ filesize `vs` Just sz - Nothing -> goannexed sz fi - go sz _ (MatchingKey key _) = checkkey sz key - go sz _ (MatchingInfo p) = return $ - Just (providedFileSize p) `vs` Just sz + LimitAnnexFiles -> lookupFileKey fi >>= \case + Just key -> checkkey sz key + Nothing -> return False + LimitDiskFiles -> do + filesize <- liftIO $ catchMaybeIO $ getFileSize (contentFile fi) + return $ filesize `vs` Just sz + go sz _ (MatchingInfo p) = case providedFileSize p of + Just sz' -> pure (Just sz' `vs` Just sz) + Nothing -> maybe (pure False) (checkkey sz) (providedKey p) go sz _ (MatchingUserInfo p) = getUserInfo (userProvidedFileSize p) >>= \sz' -> return (Just sz' `vs` Just sz) - goannexed sz fi = lookupFileKey fi >>= \case - Just key -> checkkey sz key - Nothing -> return False checkkey sz key = return $ fromKey keySize key `vs` Just sz addMetaData :: String -> Annex () @@ -517,12 +516,9 @@ lookupFileKey :: FileInfo -> Annex (Maybe Key) lookupFileKey fi = case matchKey fi of Just k -> return (Just k) - Nothing -> case contentFile fi of - Just f -> lookupKey f - Nothing -> return Nothing + Nothing -> lookupKey (contentFile fi) checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a -checkKey a (MatchingKey k _) = a k checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p) checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p) diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -37,6 +37,5 @@ checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) -checkWant a (MatchingKey _ af) = a af -checkWant a (MatchingInfo p) = a (AssociatedFile (Just $ providedFilePath p)) +checkWant a (MatchingInfo p) = a (AssociatedFile (providedFilePath p)) checkWant _ (MatchingUserInfo {}) = return False diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -94,7 +94,7 @@ let runtransfer ti = Right <$> storefile dest o l getb iv validitycheck nullMeterUpdate ti let fallback = return $ Left $ - ProtoFailureMessage "transfer failed" + ProtoFailureMessage "Transfer failed" checktransfer runtransfer fallback case v of Left e -> return $ Left $ ProtoFailureException e diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -128,7 +128,7 @@ gen' r u c gc rs = do cst <- remoteCost gc $ if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost - (rsynctransport, rsyncurl) <- rsyncTransportToObjects r gc + let (rsynctransport, rsyncurl, accessmethod) = rsyncTransportToObjects r gc let rsyncopts = Remote.Rsync.genRsyncOpts c gc rsynctransport rsyncurl let this = Remote { uuid = u @@ -163,10 +163,10 @@ , remoteStateHandle = rs } return $ Just $ specialRemote' specialcfg c - (store this rsyncopts) - (retrieve this rsyncopts) - (remove this rsyncopts) - (checkKey this rsyncopts) + (store this rsyncopts accessmethod) + (retrieve this rsyncopts accessmethod) + (remove this rsyncopts accessmethod) + (checkKey this rsyncopts accessmethod) this where specialcfg @@ -175,35 +175,47 @@ { displayProgress = False } | otherwise = specialRemoteCfg c -rsyncTransportToObjects :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String) -rsyncTransportToObjects r gc = do - (rsynctransport, rsyncurl, _) <- rsyncTransport r gc - return (rsynctransport, rsyncurl ++ "/annex/objects") +rsyncTransportToObjects :: Git.Repo -> RemoteGitConfig -> (Annex [CommandParam], String, AccessMethod) +rsyncTransportToObjects r gc = + let (rsynctransport, rsyncurl, m) = rsyncTransport r gc + in (rsynctransport, rsyncurl ++ "/annex/objects", m) -rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod) +rsyncTransport :: Git.Repo -> RemoteGitConfig -> (Annex [CommandParam], String, AccessMethod) rsyncTransport r gc | sshprefix `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length sshprefix) loc - | "//:" `isInfixOf` loc = othertransport + | "rsync://" `isPrefixOf` loc = rsyncoversshtransport | ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc - | otherwise = othertransport + | otherwise = rsyncoversshtransport where sshprefix = "ssh://" :: String loc = Git.repoLocation r - sshtransport (host, path) = do + sshtransport (host, path) = let rsyncpath = if "/~/" `isPrefixOf` path then drop 3 path else path - let sshhost = either error id (mkSshHost host) - let mkopts = rsyncShell . (Param "ssh" :) + sshhost = either error id (mkSshHost host) + mkopts = rsyncShell . (Param "ssh" :) <$> sshOptions ConsumeStdin (sshhost, Nothing) gc [] - return (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell) - othertransport = return (pure [], loc, AccessDirect) + in (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessGitAnnexShell) + rsyncoversshtransport = + -- git-remote-gcrypt uses a rsync:// url to mean + -- rsync over ssh. But to rsync, that's rsync protocol, + -- so it must be converted to a form that rsync will treat + -- as rsync over ssh. + -- There are two url forms that git-remote-gcrypt + -- supports: rsync://userhost/path and rsync://userhost:path + -- change to: userhost:/path userhost:path + let loc' = replace "rsync://" "" loc + loc'' = if ':' `elem` loc' + then loc' + else let (a, b) = break (== '/') loc' in a ++ ":" ++ b + in (pure [], loc'', AccessRsyncOverSsh) noCrypto :: Annex a noCrypto = giveup "cannot use gcrypt remote without encryption enabled" unsupportedUrl :: a -unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported" +unsupportedUrl = giveup "unsupported repo url for gcrypt" gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c @@ -256,8 +268,9 @@ else giveup $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")" {- Sets up the gcrypt repository. The repository is either a local - - repo, or it is accessed via rsync directly, or it is accessed over ssh - - and git-annex-shell is available to manage it. + - repo, or it is accessed via rsync over ssh (without using + - git-annex-shell), or it is accessed over ssh and git-annex-shell + - is available to manage it. - - The GCryptID is recorded in the repository's git config for later use. - Also, if the git config has receive.denyNonFastForwards set, disable @@ -267,11 +280,11 @@ setupRepo gcryptid r | Git.repoIsUrl r = do dummycfg <- liftIO dummyRemoteGitConfig - (_, _, accessmethod) <- rsyncTransport r dummycfg + let (_, _, accessmethod) = rsyncTransport r dummycfg case accessmethod of - AccessDirect -> rsyncsetup - AccessShell -> ifM gitannexshellsetup - ( return AccessShell + AccessRsyncOverSsh -> rsyncsetup + AccessGitAnnexShell -> ifM gitannexshellsetup + ( return AccessGitAnnexShell , rsyncsetup ) | Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r) @@ -281,16 +294,16 @@ let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (fromConfigKey k), Param v] r' setconfig coreGCryptId gcryptid setconfig denyNonFastForwards (Git.Config.boolConfig False) - return AccessDirect + return AccessRsyncOverSsh {- As well as modifying the remote's git config, - create the objectDir on the remote, - - which is needed for direct rsync of objects to work. + - which is needed for rsync of objects to it to work. -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do createAnnexDirectory (toRawFilePath (tmp objectDir)) dummycfg <- liftIO dummyRemoteGitConfig - (rsynctransport, rsyncurl, _) <- rsyncTransport r dummycfg + let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg let tmpconfig = tmp "config" opts <- rsynctransport void $ liftIO $ rsync $ opts ++ @@ -307,7 +320,7 @@ ] unless ok $ giveup "Failed to connect to remote to set it up." - return AccessDirect + return AccessRsyncOverSsh {- Ask git-annex-shell to configure the repository as a gcrypt - repository. May fail if it is too old. -} @@ -322,7 +335,7 @@ accessShellConfig :: RemoteGitConfig -> Bool accessShellConfig c = case method of - AccessShell -> True + AccessGitAnnexShell -> True _ -> False where method = toAccessMethod $ fromMaybe "" $ remoteAnnexGCrypt c @@ -363,13 +376,13 @@ where remoteconfig n = n remotename -store :: Remote -> Remote.Rsync.RsyncOpts -> Storer -store r rsyncopts k s p = do +store :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Storer +store r rsyncopts accessmethod k s p = do repo <- getRepo r - store' repo r rsyncopts k s p + store' repo r rsyncopts accessmethod k s p -store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Storer -store' repo r rsyncopts +store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Storer +store' repo r rsyncopts accessmethod | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do let tmpdir = Git.repoPath repo P. "tmp" P. keyFile k @@ -386,16 +399,19 @@ (AssociatedFile Nothing) unless ok $ giveup "rsync failed" - else fileStorer $ Remote.Rsync.store rsyncopts + else storersync + | accessmethod == AccessRsyncOverSsh = storersync | otherwise = unsupportedUrl + where + storersync = fileStorer $ Remote.Rsync.store rsyncopts -retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever -retrieve r rsyncopts k p sink = do +retrieve :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever +retrieve r rsyncopts accessmethod k p sink = do repo <- getRepo r - retrieve' repo r rsyncopts k p sink + retrieve' repo r rsyncopts accessmethod k p sink -retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Retriever -retrieve' repo r rsyncopts +retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Retriever +retrieve' repo r rsyncopts accessmethod | not $ Git.repoIsUrl repo = byteRetriever $ \k sink -> guardUsable repo (giveup "cannot access remote") $ sink =<< liftIO (L.readFile $ gCryptLocation repo k) @@ -406,38 +422,42 @@ oh <- mkOutputHandler unlessM (Ssh.rsyncHelper oh (Just p) ps) $ giveup "rsync failed" - else fileRetriever $ Remote.Rsync.retrieve rsyncopts + else retrieversync + | accessmethod == AccessRsyncOverSsh = retrieversync | otherwise = unsupportedUrl where + retrieversync = fileRetriever $ Remote.Rsync.retrieve rsyncopts -remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover -remove r rsyncopts k = do +remove :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remover +remove r rsyncopts accessmethod k = do repo <- getRepo r - remove' repo r rsyncopts k + remove' repo r rsyncopts accessmethod k -remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover -remove' repo r rsyncopts k +remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remover +remove' repo r rsyncopts accessmethod k | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ liftIO $ Remote.Directory.removeDirGeneric (fromRawFilePath (Git.repoPath repo)) (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k)))) | Git.repoIsSsh repo = shellOrRsync r removeshell removersync + | accessmethod == AccessRsyncOverSsh = removersync | otherwise = unsupportedUrl where removersync = Remote.Rsync.remove rsyncopts k removeshell = Ssh.dropKey repo k -checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent -checkKey r rsyncopts k = do +checkKey :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> CheckPresent +checkKey r rsyncopts accessmethod k = do repo <- getRepo r - checkKey' repo r rsyncopts k + checkKey' repo r rsyncopts accessmethod k -checkKey' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> CheckPresent -checkKey' repo r rsyncopts k +checkKey' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> CheckPresent +checkKey' repo r rsyncopts accessmethod k | not $ Git.repoIsUrl repo = guardUsable repo (cantCheck repo) $ liftIO $ doesFileExist (gCryptLocation repo k) | Git.repoIsSsh repo = shellOrRsync r checkshell checkrsync + | accessmethod == AccessRsyncOverSsh = checkrsync | otherwise = unsupportedUrl where checkrsync = Remote.Rsync.checkKey repo rsyncopts k @@ -449,15 +469,16 @@ gCryptLocation repo key = Git.repoLocation repo objectDir fromRawFilePath (keyPath key (hashDirLower def)) -data AccessMethod = AccessDirect | AccessShell +data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell + deriving (Eq) fromAccessMethod :: AccessMethod -> String -fromAccessMethod AccessShell = "shell" -fromAccessMethod AccessDirect = "true" +fromAccessMethod AccessGitAnnexShell = "shell" +fromAccessMethod AccessRsyncOverSsh = "true" toAccessMethod :: String -> AccessMethod -toAccessMethod "shell" = AccessShell -toAccessMethod _ = AccessDirect +toAccessMethod "shell" = AccessGitAnnexShell +toAccessMethod _ = AccessRsyncOverSsh getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID) getGCryptUUID fast r = do @@ -491,7 +512,7 @@ getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, String)) getConfigViaRsync r gc = do - (rsynctransport, rsyncurl, _) <- rsyncTransport r gc + let (rsynctransport, rsyncurl, _) = rsyncTransport r gc opts <- rsynctransport liftIO $ do withTmpFile "tmpconfig" $ \tmpconfig _ -> do diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -37,7 +37,7 @@ metered (Just p) sizer $ \_ p' -> runner p' (P2P.put k af p') >>= \case Just True -> return () - Just False -> giveup "transfer failed" + Just False -> giveup "Transfer failed" Nothing -> remoteUnavail retrieve :: VerifyConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification @@ -46,7 +46,7 @@ metered (Just p) k $ \m p' -> runner p' (P2P.get dest k iv af m p') >>= \case Just (True, v) -> return v - Just (False, _) -> giveup "transfer failed" + Just (False, _) -> giveup "Transfer failed" Nothing -> remoteUnavail remove :: ProtoRunner Bool -> Key -> Annex () diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matcher types - - - Copyright 2013-2020 Joey Hess + - Copyright 2013-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,7 +8,8 @@ module Types.FileMatcher where import Types.UUID (UUID) -import Types.Key (Key, AssociatedFile) +import Types.Key (Key) +import Types.Link (LinkType) import Types.Mime import Utility.Matcher (Matcher, Token) import Utility.FileSize @@ -21,15 +22,11 @@ -- Information about a file and/or a key that can be matched on. data MatchInfo = MatchingFile FileInfo - | MatchingKey Key AssociatedFile - -- ^ This is used when matching a file that may be in another - -- branch. The AssociatedFile is the filename, but it should not be - -- accessed from disk when matching. | MatchingInfo ProvidedInfo | MatchingUserInfo UserProvidedInfo data FileInfo = FileInfo - { contentFile :: Maybe RawFilePath + { contentFile :: RawFilePath -- ^ path to a file containing the content, for operations -- that examine it , matchFile :: RawFilePath @@ -41,11 +38,13 @@ } data ProvidedInfo = ProvidedInfo - { providedFilePath :: RawFilePath + { providedFilePath :: Maybe RawFilePath + -- ^ filepath to match on, should not be accessed from disk. , providedKey :: Maybe Key - , providedFileSize :: FileSize + , providedFileSize :: Maybe FileSize , providedMimeType :: Maybe MimeType , providedMimeEncoding :: Maybe MimeEncoding + , providedLinkType :: Maybe LinkType } -- This is used when testing a matcher, with values to match against diff --git a/Types/Link.hs b/Types/Link.hs new file mode 100644 --- /dev/null +++ b/Types/Link.hs @@ -0,0 +1,13 @@ +{- Types for links to content + - + - Copyright 2013-2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.Link where + +-- A locked link is stored in git as a symlink, while an unlocked link is +-- stored as a pointer file. +data LinkType = LockedLink | UnlockedLink + deriving (Show, Eq) diff --git a/doc/git-annex-registerurl.mdwn b/doc/git-annex-registerurl.mdwn --- a/doc/git-annex-registerurl.mdwn +++ b/doc/git-annex-registerurl.mdwn @@ -13,10 +13,6 @@ No verification is performed of the url's contents. -If no key and url pair are specified on the command line, -batch input is used, the same as if the --batch option were -specified. - Normally the key is a git-annex formatted key. However, to make it easier to use this to add urls, if the key cannot be parsed as a key, and is a valid url, an URL key is constructed from the url. @@ -28,6 +24,11 @@ In batch input mode, lines are read from stdin, and each line should contain a key and url, separated by a single space. + For backwards compatability with old git-annex before this option + was added, when no key and url pair are specified on the command line, + batch input is used, the same as if the --batch option were + specified. It is however recommended to use --batch. + * `-z` When in batch mode, the input is delimited by nulls instead of the usual @@ -41,6 +42,8 @@ [[git-annex]](1) [[git-annex-addurl]](1) + +[[git-annex-unregisterurl]](1) # AUTHOR diff --git a/doc/git-annex-unlock.mdwn b/doc/git-annex-unlock.mdwn --- a/doc/git-annex-unlock.mdwn +++ b/doc/git-annex-unlock.mdwn @@ -39,6 +39,7 @@ # git annex unlock photo.jpg # gimp photo.jpg + # git annex add photo.jpg # git annex lock photo.jpg # git commit -m "redeye removal" diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -618,6 +618,12 @@ Registers an url for a key. See [[git-annex-registerurl]](1) for details. + +* `unregisterurl [key url]` + + Unregisters an url for a key. + + See [[git-annex-unregisterurl]](1) for details. * `setkey key file` 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: 8.20210223 +Version: 8.20210310 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -808,6 +808,7 @@ Command.Ungroup Command.Uninit Command.Unlock + Command.UnregisterUrl Command.Untrust Command.Unused Command.Upgrade @@ -1018,6 +1019,7 @@ Types.IndexFiles Types.Key Types.KeySource + Types.Link Types.LockCache Types.Messages Types.MetaData