git-annex 8.20210223 → 8.20210310
raw patch · 32 files changed
+424/−283 lines, 32 files
Files
- Annex/Export.hs +35/−22
- Annex/FileMatcher.hs +10/−2
- Annex/Import.hs +12/−10
- Annex/Ingest.hs +4/−4
- CHANGELOG +25/−0
- CmdLine/Batch.hs +1/−1
- CmdLine/GitAnnex.hs +3/−1
- CmdLine/Seek.hs +53/−22
- Command/Add.hs +1/−1
- Command/Export.hs +52/−47
- Command/Import.hs +1/−1
- Command/Info.hs +1/−1
- Command/Multicast.hs +1/−1
- Command/RegisterUrl.hs +23/−24
- Command/Sync.hs +1/−1
- Command/Uninit.hs +2/−0
- Command/UnregisterUrl.hs +25/−0
- Database/Export.hs +4/−4
- Git/GCrypt.hs +8/−1
- Git/Remote.hs +3/−1
- Key.hs +0/−20
- Limit.hs +39/−43
- Limit/Wanted.hs +1/−2
- P2P/Annex.hs +1/−1
- Remote/GCrypt.hs +78/−57
- Remote/Helper/P2P.hs +2/−2
- Types/FileMatcher.hs +8/−9
- Types/Link.hs +13/−0
- doc/git-annex-registerurl.mdwn +7/−4
- doc/git-annex-unlock.mdwn +1/−0
- doc/git-annex.mdwn +6/−0
- git-annex.cabal +3/−1
Annex/Export.hs view
@@ -1,10 +1,12 @@ {- git-annex exports -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2021 Joey Hess <id@joeyh.name> - - 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
Annex/FileMatcher.hs view
@@ -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 }
Annex/Import.hs view
@@ -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
Annex/Ingest.hs view
@@ -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
CHANGELOG view
@@ -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 <id@joeyh.name> 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
CmdLine/Batch.hs view
@@ -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 )
CmdLine/GitAnnex.hs view
@@ -1,6 +1,6 @@ {- git-annex main program -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - 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
CmdLine/Seek.hs view
@@ -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
Command/Add.hs view
@@ -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
Command/Export.hs view
@@ -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
Command/Import.hs view
@@ -239,7 +239,7 @@ stop lockdown a = do let mi = MatchingFile $ FileInfo- { contentFile = Just srcfile+ { contentFile = srcfile , matchFile = destfile , matchKey = Nothing }
Command/Info.hs view
@@ -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
Command/Multicast.hs view
@@ -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
Command/RegisterUrl.hs view
@@ -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
Command/Sync.hs view
@@ -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
Command/Uninit.hs view
@@ -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
+ Command/UnregisterUrl.hs view
@@ -0,0 +1,25 @@+{- git-annex command+ -+ - Copyright 2015-2021 Joey Hess <id@joeyh.name>+ -+ - 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
Database/Export.hs view
@@ -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
Git/GCrypt.hs view
@@ -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"
Git/Remote.hs view
@@ -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
Key.hs view
@@ -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'
Limit.hs view
@@ -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)
Limit/Wanted.hs view
@@ -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
P2P/Annex.hs view
@@ -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
Remote/GCrypt.hs view
@@ -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
Remote/Helper/P2P.hs view
@@ -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 ()
Types/FileMatcher.hs view
@@ -1,6 +1,6 @@ {- git-annex file matcher types -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name> - - 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
+ Types/Link.hs view
@@ -0,0 +1,13 @@+{- Types for links to content+ -+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ -+ - 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)
doc/git-annex-registerurl.mdwn view
@@ -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
doc/git-annex-unlock.mdwn view
@@ -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"
doc/git-annex.mdwn view
@@ -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`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210223+Version: 8.20210310 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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