git-annex 10.20230126 → 10.20230214
raw patch · 28 files changed
+521/−170 lines, 28 files
Files
- Annex/AdjustedBranch.hs +3/−1
- Annex/View.hs +221/−53
- CHANGELOG +29/−0
- CmdLine/Usage.hs +0/−4
- Command.hs +1/−1
- Command/EnableRemote.hs +2/−2
- Command/Info.hs +14/−17
- Command/RenameRemote.hs +2/−2
- Command/Sync.hs +58/−25
- Command/VAdd.hs +5/−4
- Command/VFilter.hs +3/−1
- Command/View.hs +7/−4
- Git/Construct.hs +1/−1
- Logs/View.hs +40/−12
- Remote.hs +19/−12
- Remote/Git.hs +2/−2
- Remote/Helper/AWS.hs +2/−3
- Remote/S3.hs +24/−4
- Types/GitConfig.hs +4/−0
- Types/View.hs +9/−2
- Utility/LinuxMkLibs.hs +20/−2
- Utility/Url.hs +20/−4
- doc/git-annex-sync.mdwn +7/−0
- doc/git-annex-vadd.mdwn +1/−1
- doc/git-annex-vfilter.mdwn +1/−1
- doc/git-annex-view.mdwn +18/−10
- doc/git-annex.mdwn +7/−1
- git-annex.cabal +1/−1
Annex/AdjustedBranch.hs view
@@ -490,7 +490,9 @@ , rebase currcommit newparent ) Nothing -> return (Nothing, return ())- Nothing -> return (Nothing, return ())+ Nothing -> do+ warning $ "Cannot find basis ref " ++ fromRef basis ++ "; not propagating adjusted commits to original branch " ++ fromRef origbranch+ return (Nothing, return ()) where (BasisBranch basis) = basisBranch adjbranch adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj
Annex/View.hs view
@@ -1,6 +1,6 @@ {- metadata based branch views -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -15,11 +15,14 @@ import Types.MetaData import Annex.MetaData import qualified Annex+import qualified Annex.Branch import qualified Git import qualified Git.DiffTree as DiffTree import qualified Git.Branch import qualified Git.LsFiles+import qualified Git.LsTree import qualified Git.Ref+import Git.CatFile import Git.UpdateIndex import Git.Sha import Git.Types@@ -28,6 +31,8 @@ import Annex.GitOverlay import Annex.Link import Annex.CatFile+import Annex.Concurrent+import Logs import Logs.MetaData import Logs.View import Utility.Glob@@ -40,6 +45,7 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified System.FilePath.ByteString as P+import Control.Concurrent.Async import "mtl" Control.Monad.Writer {- Each visible ViewFilter in a view results in another level of@@ -56,19 +62,23 @@ visibleViewSize :: View -> Int visibleViewSize = length . filter viewVisible . viewComponents -{- Parses field=value, field!=value, tag, and !tag+{- Parses field=value, field!=value, field?=value, tag, !tag, and ?tag - - Note that the field may not be a legal metadata field name, - but it's let through anyway. - This is useful when matching on directory names with spaces, - which are not legal MetaFields. -}-parseViewParam :: String -> (MetaField, ViewFilter)-parseViewParam s = case separate (== '=') s of+parseViewParam :: ViewUnset -> String -> (MetaField, ViewFilter)+parseViewParam vu s = case separate (== '=') s of ('!':tag, []) | not (null tag) -> ( tagMetaField , mkExcludeValues tag )+ ('?':tag, []) | not (null tag) ->+ ( tagMetaField+ , mkFilterOrUnsetValues tag+ ) (tag, []) -> ( tagMetaField , mkFilterValues tag@@ -78,15 +88,22 @@ ( mkMetaFieldUnchecked (T.pack (beginning field)) , mkExcludeValues wanted )+ | end field == "?" ->+ ( mkMetaFieldUnchecked (T.pack (beginning field))+ , mkFilterOrUnsetValues wanted+ ) | otherwise -> ( mkMetaFieldUnchecked (T.pack field) , mkFilterValues wanted ) where+ mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS mkFilterValues v | any (`elem` v) ['*', '?'] = FilterGlob v | otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v- mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS+ mkFilterOrUnsetValues v+ | any (`elem` v) ['*', '?'] = FilterGlobOrUnset v vu+ | otherwise = FilterValuesOrUnset (S.singleton $ toMetaValue $ encodeBS v) vu data ViewChange = Unchanged | Narrowing | Widening deriving (Ord, Eq, Show)@@ -136,18 +153,8 @@ toinvisible c = c { viewVisible = False } {- Combine old and new ViewFilters, yielding a result that matches- - either old+new, or only new.- -- - If we have FilterValues and change to a FilterGlob,- - it's always a widening change, because the glob could match other- - values. OTOH, going the other way, it's a Narrowing change if the old- - glob matches all the new FilterValues.- -- - With two globs, the old one is discarded, and the new one is used.- - We can tell if that's a narrowing change by checking if the old- - glob matches the new glob. For example, "*" matches "foo*",- - so that's narrowing. While "f?o" does not match "f??", so that's- - widening.+ - either old+new, or only new. Which depends on the types of things+ - being combined. -} combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange) combineViewFilter old@(FilterValues olds) (FilterValues news)@@ -160,19 +167,74 @@ | otherwise = (combined, Narrowing) where combined = ExcludeValues (S.union olds news)+{- If we have FilterValues and change to a FilterGlob,+ - it's always a widening change, because the glob could match other+ - values. OTOH, going the other way, it's a Narrowing change if the old+ - glob matches all the new FilterValues. -} combineViewFilter (FilterValues _) newglob@(FilterGlob _) = (newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s) | all (matchGlob (compileGlob oldglob CaseInsensative (GlobFilePath False)) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) | otherwise = (new, Widening)+{- With two globs, the old one is discarded, and the new one is used.+ - We can tell if that's a narrowing change by checking if the old+ - glob matches the new glob. For example, "*" matches "foo*",+ - so that's narrowing. While "f?o" does not match "f??", so that's+ - widening. -} combineViewFilter (FilterGlob old) newglob@(FilterGlob new) | old == new = (newglob, Unchanged) | matchGlob (compileGlob old CaseInsensative (GlobFilePath False)) new = (newglob, Narrowing) | otherwise = (newglob, Widening)+{- Combining FilterValuesOrUnset and FilterGlobOrUnset with FilterValues+ - and FilterGlob maintains the OrUnset if the second parameter has it,+ - and is otherwise the same as combining without OrUnset, except that+ - eliminating the OrUnset can be narrowing, and adding it can be widening. -}+combineViewFilter old@(FilterValuesOrUnset olds _) (FilterValuesOrUnset news newvu)+ | combined == old = (combined, Unchanged)+ | otherwise = (combined, Widening)+ where+ combined = FilterValuesOrUnset (S.union olds news) newvu+combineViewFilter (FilterValues olds) (FilterValuesOrUnset news vu) =+ (combined, Widening)+ where+ combined = FilterValuesOrUnset (S.union olds news) vu+combineViewFilter old@(FilterValuesOrUnset olds _) (FilterValues news)+ | combined == old = (combined, Narrowing)+ | otherwise = (combined, Widening)+ where+ combined = FilterValues (S.union olds news)+combineViewFilter (FilterValuesOrUnset _ _) newglob@(FilterGlob _) =+ (newglob, Widening)+combineViewFilter (FilterGlob _) new@(FilterValuesOrUnset _ _) =+ (new, Widening)+combineViewFilter (FilterValues _) newglob@(FilterGlobOrUnset _ _) =+ (newglob, Widening)+combineViewFilter (FilterValuesOrUnset _ _) newglob@(FilterGlobOrUnset _ _) =+ (newglob, Widening)+combineViewFilter (FilterGlobOrUnset oldglob _) new@(FilterValues _) =+ combineViewFilter (FilterGlob oldglob) new+combineViewFilter (FilterGlobOrUnset oldglob _) new@(FilterValuesOrUnset _ _) =+ let (_, viewchange) = combineViewFilter (FilterGlob oldglob) new+ in (new, viewchange)+combineViewFilter (FilterGlobOrUnset old _) newglob@(FilterGlobOrUnset new _)+ | old == new = (newglob, Unchanged)+ | matchGlob (compileGlob old CaseInsensative (GlobFilePath False)) new = (newglob, Narrowing)+ | otherwise = (newglob, Widening)+combineViewFilter (FilterGlob _) newglob@(FilterGlobOrUnset _ _) =+ (newglob, Widening)+combineViewFilter (FilterGlobOrUnset _ _) newglob@(FilterGlob _) =+ (newglob, Narrowing)+{- There is not a way to filter a value and also apply an exclude. So:+ - When adding an exclude to a filter, use only the exclude.+ - When adding a filter to an exclude, use only the filter. -} combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing) combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening) combineViewFilter (FilterValues _) new@(ExcludeValues _) = (new, Narrowing) combineViewFilter (ExcludeValues _) new@(FilterValues _) = (new, Widening)+combineViewFilter (FilterValuesOrUnset _ _) new@(ExcludeValues _) = (new, Narrowing)+combineViewFilter (ExcludeValues _) new@(FilterValuesOrUnset _ _) = (new, Widening)+combineViewFilter (FilterGlobOrUnset _ _) new@(ExcludeValues _) = (new, Narrowing)+combineViewFilter (ExcludeValues _) new@(FilterGlobOrUnset _ _) = (new, Widening) {- Generates views for a file from a branch, based on its metadata - and the filename used in the branch.@@ -196,7 +258,7 @@ then [] else let paths = pathProduct $- map (map toViewPath) (visible matches)+ map (map toviewpath) (visible matches) in if null paths then [mkviewedfile file] else map (</> mkviewedfile file) paths@@ -204,29 +266,41 @@ visible = map (fromJust . snd) . filter (viewVisible . fst) . zip (viewComponents view)+ + toviewpath (MatchingMetaValue v) = toViewPath v+ toviewpath (MatchingUnset v) = toViewPath (toMetaValue (encodeBS v)) +data MatchingValue = MatchingMetaValue MetaValue | MatchingUnset String+ {- Checks if metadata matches a ViewComponent filter, and if so - returns the value, or values that match. Self-memoizing on ViewComponent. -}-viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])+viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MatchingValue]) viewComponentMatcher viewcomponent = \metadata -> - matcher (currentMetaDataValues metafield metadata)+ matcher Nothing (viewFilter viewcomponent)+ (currentMetaDataValues metafield metadata) where metafield = viewField viewcomponent- matcher = case viewFilter viewcomponent of- FilterValues s -> \values -> setmatches $- S.intersection s values- FilterGlob glob ->- let cglob = compileGlob glob CaseInsensative (GlobFilePath False)- in \values -> setmatches $- S.filter (matchGlob cglob . decodeBS . fromMetaValue) values- ExcludeValues excludes -> \values -> + matcher matchunset (FilterValues s) = + \values -> setmatches matchunset $ S.intersection s values+ matcher matchunset (FilterGlob glob) =+ let cglob = compileGlob glob CaseInsensative (GlobFilePath False)+ in \values -> setmatches matchunset $+ S.filter (matchGlob cglob . decodeBS . fromMetaValue) values+ matcher _ (ExcludeValues excludes) = + \values -> if S.null (S.intersection values excludes) then Just [] else Nothing- setmatches s- | S.null s = Nothing- | otherwise = Just (S.toList s)+ matcher _ (FilterValuesOrUnset s (ViewUnset u)) =+ matcher (Just [MatchingUnset u]) (FilterValues s)+ matcher _ (FilterGlobOrUnset glob (ViewUnset u)) =+ matcher (Just [MatchingUnset u]) (FilterGlob glob) + setmatches matchunset s+ | S.null s = matchunset + | otherwise = Just $+ map MatchingMetaValue (S.toList s)+ -- This is '∕', a unicode character that displays the same as '/' but is -- not it. It is encoded using the filesystem encoding, which allows it -- to be used even when not in a unicode capable locale.@@ -282,15 +356,26 @@ - Derived metadata is excluded. -} fromView :: View -> ViewedFile -> MetaData-fromView view f = MetaData $- M.fromList (zip fields values) `M.difference` derived+fromView view f = MetaData $ m `M.difference` derived where+ m = M.fromList $ map convfield $+ filter (not . isviewunset) (zip visible values) visible = filter viewVisible (viewComponents view)- fields = map viewField visible paths = splitDirectories (dropFileName f) values = map (S.singleton . fromViewPath) paths MetaData derived = getViewedFileMetaData f+ convfield (vc, v) = (viewField vc, v) + -- When a directory is the one used to hold files that don't+ -- have the metadata set, don't include it in the MetaData.+ isviewunset (vc, v) = case viewFilter vc of+ FilterValues {} -> False+ FilterGlob {} -> False+ ExcludeValues {} -> False+ FilterValuesOrUnset _ (ViewUnset vu) -> isviewunset' vu v+ FilterGlobOrUnset _ (ViewUnset vu) -> isviewunset' vu v+ isviewunset' vu v = S.member (fromViewPath vu) v+ {- Constructing a view that will match arbitrary metadata, and applying - it to a file yields a set of ViewedFile which all contain the same - MetaFields that were present in the input metadata@@ -349,42 +434,120 @@ - or a file in a dotdir in the top. - Look up the metadata of annexed files, and generate any ViewedFiles, - and stage them.- -- - Must be run from top of repository. -} applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]- liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex- viewg <- withViewIndex gitRepo- withUpdateIndex viewg $ \uh -> do- forM_ l $ \(f, sha, mode) -> do+ applyView'' mkviewedfile getfilemetadata view l clean $ + \(f, sha, mode) -> do topf <- inRepo (toTopFilePath f)- go uh topf sha (toTreeItemType mode) =<< lookupKey f- liftIO $ void clean+ k <- lookupKey f+ return (topf, sha, toTreeItemType mode, k) genViewBranch view++applyView''+ :: MkViewedFile+ -> (FilePath -> MetaData)+ -> View+ -> [t]+ -> IO Bool+ -> (t -> Annex (TopFilePath, Sha, Maybe TreeItemType, Maybe Key))+ -> Annex ()+applyView'' mkviewedfile getfilemetadata view l clean conv = do+ viewg <- withNewViewIndex gitRepo+ withUpdateIndex viewg $ \uh -> do+ g <- Annex.gitRepo+ gc <- Annex.getGitConfig+ -- Streaming the metadata like this is an optimisation.+ catObjectStream g $ \mdfeeder mdcloser mdreader -> do+ tid <- liftIO . async =<< forkState+ (getmetadata gc mdfeeder mdcloser l)+ process uh mdreader+ join (liftIO (wait tid))+ liftIO $ void clean where genviewedfiles = viewedFiles view mkviewedfile -- enables memoization - go uh topf _sha _mode (Just k) = do- metadata <- getCurrentMetaData k- let f = fromRawFilePath $ getTopFilePath topf- let metadata' = getfilemetadata f `unionMetaData` metadata- forM_ (genviewedfiles f metadata') $ \fv -> do- f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)- stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)- go uh topf sha (Just treeitemtype) Nothing- | "." `B.isPrefixOf` getTopFilePath topf =+ getmetadata _ _ mdcloser [] = liftIO mdcloser+ getmetadata gc mdfeeder mdcloser (t:ts) = do+ v@(topf, _sha, _treeitemtype, mkey) <- conv t+ let feed mdlogf = liftIO $ mdfeeder+ (v, Git.Ref.branchFileRef Annex.Branch.fullname mdlogf)+ case mkey of+ Just key -> feed (metaDataLogFile gc key)+ Nothing+ -- Handle toplevel dotfiles that are not+ -- annexed files by feeding through a query+ -- for dummy metadata. Calling+ -- Git.UpdateIndex.streamUpdateIndex'+ -- here would race with process's calls+ -- to it.+ | "." `B.isPrefixOf` getTopFilePath topf ->+ feed "dummy"+ | otherwise -> noop+ getmetadata gc mdfeeder mdcloser ts++ process uh mdreader = liftIO mdreader >>= \case+ Just ((topf, _, _, Just k), Just mdlog) -> do+ let metadata = parseCurrentMetaData mdlog+ let f = fromRawFilePath $ getTopFilePath topf+ let metadata' = getfilemetadata f `unionMetaData` metadata+ forM_ (genviewedfiles f metadata') $ \fv -> do+ f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)+ stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)+ process uh mdreader+ Just ((topf, sha, Just treeitemtype, Nothing), _) -> do liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $ pureStreamer $ updateIndexLine sha treeitemtype topf- go _ _ _ _ _ = noop-+ process uh mdreader+ Just _ -> process uh mdreader+ Nothing -> return ()+ stagesymlink uh f linktarget = do sha <- hashSymlink linktarget liftIO . Git.UpdateIndex.streamUpdateIndex' uh =<< inRepo (Git.UpdateIndex.stageSymlink f sha) +{- Updates the current view with any changes that have been made to its+ - parent branch or the metadata since the view was created or last updated.+ -+ - When there were changes, returns a ref to a commit for the updated view.+ - Does not update the view branch with it.+ -+ - This is not very optimised. An incremental update would be possible to+ - implement and would be faster, but more complicated.+ -}+updateView :: View -> Annex (Maybe Git.Ref)+updateView view = do+ (l, clean) <- inRepo $ Git.LsTree.lsTree+ Git.LsTree.LsTreeRecursive+ (Git.LsTree.LsTreeLong True)+ (viewParentBranch view)+ applyView'' viewedFileFromReference getWorkTreeMetaData view l clean $+ \ti -> do+ let ref = Git.Ref.branchFileRef (viewParentBranch view)+ (getTopFilePath (Git.LsTree.file ti))+ k <- case Git.LsTree.size ti of+ Nothing -> catKey ref+ Just sz -> catKey' ref sz+ return+ ( (Git.LsTree.file ti)+ , (Git.LsTree.sha ti)+ , (toTreeItemType (Git.LsTree.mode ti))+ , k+ )+ oldcommit <- inRepo $ Git.Ref.sha (branchView view)+ oldtree <- maybe (pure Nothing) (inRepo . Git.Ref.tree) oldcommit+ newtree <- withViewIndex $ inRepo Git.Branch.writeTree+ if oldtree /= Just newtree+ then Just <$> do+ cmode <- annexCommitMode <$> Annex.getGitConfig+ let msg = "updated " ++ fromRef (branchView view)+ let parent = catMaybes [oldcommit]+ inRepo (Git.Branch.commitTree cmode msg parent newtree)+ else return Nothing+ {- Diff between currently checked out branch and staged changes, and - update metadata to reflect the changes that are being committed to the - view.@@ -421,6 +584,11 @@ - info staged for an old view. -} withViewIndex :: Annex a -> Annex a withViewIndex = withIndexFile ViewIndexFile . const++withNewViewIndex :: Annex a -> Annex a+withNewViewIndex a = do+ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex+ withViewIndex a {- Generates a branch for a view, using the view index file - to make a commit to the view branch. The view branch is not
CHANGELOG view
@@ -1,3 +1,32 @@+git-annex (10.20230214) upstream; urgency=medium++ * sync: Fix a bug that caused files to be removed from an + importtree=yes exporttree=yes special remote when the remote's+ annex-tracking-branch was not the currently checked out branch.+ * S3: Support a region= configuration useful for some non-Amazon S3+ implementations. This feature needs git-annex to be built with aws-0.24.+ * view: New field?=glob and ?tag syntax that includes a directory "_"+ in the view for files that do not have the specified metadata set.+ * Added annex.viewunsetdirectory git config to change the name of the+ "_" directory in a view.+ * Changed the name of view branches to include the parent branch.+ Existing view branches checked out using an old name will still work.+ * sync: Avoid pushing view branches to remotes.+ * sync: When run in a view branch, refresh the view branch to reflect any+ changes that have been made to the parent branch or metadata.+ * sync: When run in a view branch, avoid updating synced/ branches,+ or trying to merge anything from remotes.+ * Support http urls that contain ":" that is not followed by a port+ number, the same as git does.+ * sync: Warn when the adjusted basis ref cannot be found, as happens eg when+ the user has renamed branches.+ * Sped up view branch construction by 50%.+ * info, enableremotemote, renameremote: Avoid a confusing message when more+ than one repository matches the user provided name.+ * info: Exit nonzero when the input is not supported.++ -- Joey Hess <id@joeyh.name> Tue, 14 Feb 2023 14:07:11 -0400+ git-annex (10.20230126) upstream; urgency=medium * Change --metadata comparisons < > <= and >= to fall back to
CmdLine/Usage.hs view
@@ -32,16 +32,12 @@ cmdline c = concat [ cmdname c , namepad (cmdname c)- , cmdparamdesc c- , descpad (cmdparamdesc c) , cmddesc c ] pad n s = replicate (n - length s) ' ' namepad = pad $ longest cmdname + 1- descpad = pad $ longest cmdparamdesc + 2 longest f = foldl max 0 $ map (length . f) cmds scmds = sort cmds- {- Descriptions of params used in usage messages. -} paramPaths :: String
Command.hs view
@@ -66,7 +66,7 @@ {- Adds a fallback action to a command, that will be run if it's used - outside a git repository. -}-noRepo :: (String -> Parser (IO ())) -> Command -> Command+noRepo :: (CmdParamsDesc -> Parser (IO ())) -> Command -> Command noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } {- Adds Annex options to a command. -}
Command/EnableRemote.hs view
@@ -79,10 +79,10 @@ m <- SpecialRemote.specialRemoteMap confm <- Logs.Remote.remoteConfigMap Remote.nameToUUID' name >>= \case- Right u | u `M.member` m ->+ ([u], _) | u `M.member` m -> startSpecialRemote name config $ [(u, fromMaybe M.empty (M.lookup u confm), Nothing)]- _ -> unknownNameError "Unknown remote name."+ (_, msg) -> unknownNameError msg startSpecialRemote name config ((u, c, mcu):[]) = starting "enableremote" ai si $ do let fullconfig = config `M.union` c
Command/Info.hs view
@@ -165,28 +165,24 @@ itemInfo :: InfoOptions -> (SeekInput, String) -> Annex () itemInfo o (si, p) = ifM (isdir p) ( dirInfo o p si- , do- v <- Remote.byName' p- case v of- Right r -> remoteInfo o r si- Left _ -> do- v' <- Remote.nameToUUID' p- case v' of- Right u -> uuidInfo o u si- Left _ -> do- relp <- liftIO $ relPathCwdToFile (toRawFilePath p)- lookupKey relp >>= \case- Just k -> fileInfo o (fromRawFilePath relp) si k- Nothing -> treeishInfo o p si+ , Remote.byName' p >>= \case+ Right r -> remoteInfo o r si+ Left _ -> Remote.nameToUUID' p >>= \case+ ([], _) -> do+ relp <- liftIO $ relPathCwdToFile (toRawFilePath p)+ lookupKey relp >>= \case+ Just k -> fileInfo o (fromRawFilePath relp) si k+ Nothing -> treeishInfo o p si+ ([u], _) -> uuidInfo o u si+ (_us, msg) -> noInfo p si msg ) where isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) -noInfo :: String -> SeekInput -> Annex ()-noInfo s si = do+noInfo :: String -> SeekInput -> String -> Annex ()+noInfo s si msg = do showStart "info" (encodeBS s) si- showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid"- showEndFail+ giveup msg dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex () dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do@@ -203,6 +199,7 @@ mi <- getTreeStatInfo o (Git.Ref (encodeBS t)) case mi of Nothing -> noInfo t si+ "not a directory or an annexed file or a treeish or a remote or a uuid" Just i -> showCustom (unwords ["info", t]) si $ do stats <- selStats (tostats (tree_name:tree_fast_stats False))
Command/RenameRemote.hs view
@@ -35,12 +35,12 @@ -- as a fallback when there is nothing with the name in the -- special remote log. [] -> Remote.nameToUUID' oldname >>= \case- Left e -> giveup e- Right u -> do+ ([u], _) -> do m <- Logs.Remote.remoteConfigMap case M.lookup u m of Nothing -> giveup "That is not a special remote." Just cfg -> go u cfg Nothing+ (_, msg) -> giveup msg _ -> giveup $ "There are multiple special remotes named " ++ oldname ++ ". Provide instead the uuid or description of the remote to rename." where ai = ActionItemOther Nothing
Command/Sync.hs view
@@ -1,7 +1,7 @@ {- git-annex command - - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -21,7 +21,6 @@ commitMsg, pushBranch, updateBranch,- syncBranch, updateBranches, seekExportContent, parseUnrelatedHistoriesOption,@@ -60,9 +59,11 @@ import Logs.UUID import Logs.Export import Logs.PreferredContent+import Logs.View import Annex.AutoMerge import Annex.AdjustedBranch import Annex.AdjustedBranch.Merge+import Annex.View import Annex.Ssh import Annex.BloomFilter import Annex.UpdateInstead@@ -310,8 +311,11 @@ (b, _) -> autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge syncBranch :: Git.Branch -> Git.Branch-syncBranch = Git.Ref.underBase "refs/heads/synced" . fromAdjustedBranch+syncBranch = Git.Ref.underBase "refs/heads/synced" . origBranch +origBranch :: Git.Branch -> Git.Branch+origBranch = fromViewBranch . fromAdjustedBranch+ remoteBranch :: Remote -> Git.Ref -> Git.Ref remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote @@ -405,10 +409,13 @@ -- Returns the branch that should be merged, if any. needMerge :: CurrBranch -> Git.Branch -> Annex (Maybe Git.Branch)-needMerge currbranch headbranch = ifM (allM id checks)- ( return (Just syncbranch)- , return Nothing- )+needMerge currbranch headbranch+ | is_branchView headbranch = return Nothing+ | otherwise = + ifM (allM id checks)+ ( return (Just syncbranch)+ , return Nothing+ ) where syncbranch = syncBranch headbranch checks = case currbranch of@@ -437,7 +444,6 @@ -- to be updated, if the adjustment is not stable, and the usual -- configuration does not update it. case madj of- Nothing -> noop Just adj -> do let origbranch = branch propigateAdjustedCommits origbranch adj@@ -445,13 +451,27 @@ annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case 0 -> adjustedBranchRefreshFull adj origbranch _ -> return ()+ -- When in a view branch, update it to reflect any changes+ -- of its parent branch or the metadata.+ Nothing -> currentView >>= \case+ Nothing -> noop+ Just view -> updateView view >>= \case+ Nothing -> noop+ Just newcommit -> do+ ok <- inRepo $ Git.Command.runBool+ [ Param "merge"+ , Param (Git.fromRef newcommit)+ ]+ unless ok $+ giveup $ "failed to update view" -- Update the sync branch to match the new state of the branch- inRepo $ updateBranch (syncBranch branch) branch+ inRepo $ updateBranch (syncBranch branch) (fromViewBranch branch) updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO () updateBranch syncbranch updateto g = - unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch+ unlessM go $+ giveup $ "failed to update " ++ Git.fromRef syncbranch where go = Git.Command.runBool [ Param "branch"@@ -565,7 +585,9 @@ (mapM (merge currbranch mergeconfig o Git.Branch.ManualCommit . remoteBranch remote) =<< getlist) tomerge = filterM (changed remote) branchlist Nothing = []- branchlist (Just branch) = [fromAdjustedBranch branch, syncBranch branch]+ branchlist (Just branch)+ | is_branchView branch = []+ | otherwise = [origBranch branch, syncBranch branch] pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote _o _remote (Nothing, _) = stop@@ -654,7 +676,7 @@ pushBranch remote mbranch ms g = directpush `after` annexpush `after` syncpush where syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes- [ (refspec . fromAdjustedBranch) <$> mbranch+ [ (refspec . origBranch) <$> mbranch , Just $ Git.Branch.forcePush $ refspec Annex.Branch.name ] annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams@@ -673,7 +695,7 @@ -- will want to see that one. Just branch -> do let p = flip Git.Command.gitCreateProcess g $ pushparams- [ Git.fromRef $ Git.Ref.base $ fromAdjustedBranch branch ]+ [ Git.fromRef $ Git.Ref.base $ origBranch branch ] (transcript, ok) <- processTranscript' p Nothing when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ hPutStr stderr transcript@@ -875,9 +897,14 @@ ai = mkActionItem (k, af) si = SeekInput [] -{- When a remote has an annex-tracking-branch configuration, change the export- - to contain the current content of the branch. Otherwise, transfer any files- - that were part of an export but are not in the remote yet.+{- When a remote has an annex-tracking-branch configuration, and that branch+ - is currently checked out, change the export to contain the current content+ - of the branch. (If the branch is not currently checked out, anything+ - imported from the remote will not yet have been merged into it yet and+ - so exporting would delete files from the remote unexpectedly.)+ -+ - Otherwise, transfer any files that were part of a previous export+ - but are not in the remote yet. - - Returns True if any file transfers were made. -}@@ -892,20 +919,26 @@ Export.closeDb (\db -> Export.writeLockDbWhile db (go' r db)) go' r db = case remoteAnnexTrackingBranch (Remote.gitconfig r) of- Nothing -> cannotupdateexport r db Nothing+ Nothing -> cannotupdateexport r db Nothing True Just b -> do mtree <- inRepo $ Git.Ref.tree b+ mcurrtree <- maybe (pure Nothing)+ (inRepo . Git.Ref.tree)+ currbranch mtbcommitsha <- Command.Export.getExportCommit r b- case (mtree, mtbcommitsha) of- (Just tree, Just _) -> do- filteredtree <- Command.Export.filterExport r tree- Command.Export.changeExport r db filteredtree- Command.Export.fillExport r db filteredtree mtbcommitsha- _ -> cannotupdateexport r db (Just b)+ case (mtree, mcurrtree, mtbcommitsha) of+ (Just tree, Just currtree, Just _)+ | tree == currtree -> do+ filteredtree <- Command.Export.filterExport r tree+ Command.Export.changeExport r db filteredtree+ Command.Export.fillExport r db filteredtree mtbcommitsha+ | otherwise -> cannotupdateexport r db (Just b) False+ _ -> cannotupdateexport r db (Just b) True - cannotupdateexport r db mtb = do+ cannotupdateexport r db mtb showwarning = do exported <- getExport (Remote.uuid r)- maybe noop (warncannotupdateexport r mtb exported) currbranch+ when showwarning $+ maybe noop (warncannotupdateexport r mtb exported) currbranch fillexistingexport r db (exportedTreeishes exported) Nothing warncannotupdateexport r mtb exported currb = case mtb of
Command/VAdd.hs view
@@ -8,15 +8,15 @@ module Command.VAdd where import Command+import qualified Annex import Annex.View-import Command.View (checkoutViewBranch)+import Command.View (checkoutViewBranch, paramView) cmd :: Command cmd = notBareRepo $ command "vadd" SectionMetaData "add subdirs to current view"- (paramRepeating "FIELD=GLOB")- (withParams seek)+ paramView (withParams seek) seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start)@@ -24,8 +24,9 @@ start :: [String] -> CommandStart start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $ withCurrentView $ \view -> do+ vu <- annexViewUnsetDirectory <$> Annex.getGitConfig let (view', change) = refineView view $- map parseViewParam $ reverse params+ map (parseViewParam vu) (reverse params) case change of Unchanged -> do showNote "unchanged"
Command/VFilter.hs view
@@ -8,6 +8,7 @@ module Command.VFilter where import Command+import qualified Annex import Annex.View import Command.View (paramView, checkoutViewBranch) @@ -22,8 +23,9 @@ start :: [String] -> CommandStart start params = starting "vfilter" (ActionItemOther Nothing) (SeekInput params) $ withCurrentView $ \view -> do+ vu <- annexViewUnsetDirectory <$> Annex.getGitConfig let view' = filterView view $- map parseViewParam $ reverse params+ map (parseViewParam vu) (reverse params) next $ if visibleViewSize view' > visibleViewSize view then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter." else checkoutViewBranch view' narrowView
Command/View.hs view
@@ -8,6 +8,7 @@ module Command.View where import Command+import qualified Annex import qualified Git import qualified Git.Command import qualified Git.Ref@@ -34,7 +35,7 @@ start ps = ifM safeToEnterView ( do view <- mkView ps- go view =<< currentView+ go view =<< currentView , giveup "Not safe to enter view." ) where@@ -77,14 +78,16 @@ next $ checkoutViewBranch view applyView paramView :: String-paramView = paramRepeating "FIELD=VALUE"+paramView = paramRepeating "TAG FIELD=GLOB ?TAG FIELD?=GLOB FIELD!=VALUE" mkView :: [String] -> Annex View mkView ps = go =<< inRepo Git.Branch.current where go Nothing = giveup "not on any branch!"- go (Just b) = return $ fst $ refineView (View b []) $- map parseViewParam $ reverse ps+ go (Just b) = do+ vu <- annexViewUnsetDirectory <$> Annex.getGitConfig+ return $ fst $ refineView (View b []) $+ map (parseViewParam vu) (reverse ps) checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup checkoutViewBranch view mkbranch = do
Git/Construct.hs view
@@ -227,7 +227,7 @@ isRepo = checkdir $ gitSignature (".git" </> "config") <||>- -- A git-worktree lacks .git/config, but has .git/commondir.+ -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.)
Logs/View.hs view
@@ -4,7 +4,7 @@ - - This file is stored locally in .git/annex/, not in the git-annex branch. -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -17,6 +17,7 @@ removeView, recentViews, branchView,+ fromViewBranch, is_branchView, prop_branchView_legal, ) where@@ -58,7 +59,8 @@ currentView = go =<< inRepo Git.Branch.current where go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b =- headMaybe . filter (\v -> branchView v == b) <$> recentViews+ headMaybe . filter (\v -> branchView v == b || branchViewOld v == b) + <$> recentViews go _ = return Nothing branchViewPrefix :: B.ByteString@@ -67,17 +69,28 @@ {- Generates a git branch name for a View. - - There is no guarantee that each view gets a unique branch name,- - but the branch name is used to express the view as well as possible.+ - but the branch name is used to express the view as well as possible+ - given the constraints on git branch names. It includes the name of the+ - parent branch, and what metadata is used. -} branchView :: View -> Git.Branch-branchView view- | B.null name = Git.Ref branchViewPrefix- | otherwise = Git.Ref $ branchViewPrefix <> "/" <> name+branchView view = Git.Ref $ + branchViewPrefix <> "/" <> basebranch+ <> "(" <> branchViewDesc view False <> ")" where- name = encodeBS $- intercalate ";" $ map branchcomp (viewComponents view)+ basebranch = fromRef' (Git.Ref.base (viewParentBranch view))++{- Old name used for a view did not include the name of the parent branch. -}+branchViewOld :: View -> Git.Branch+branchViewOld view = Git.Ref $+ branchViewPrefix <> "/" <> branchViewDesc view True++branchViewDesc :: View -> Bool -> B.ByteString+branchViewDesc view pareninvisibles = encodeBS $+ intercalate ";" $ map branchcomp (viewComponents view)+ where branchcomp c- | viewVisible c = branchcomp' c+ | viewVisible c || not pareninvisibles = branchcomp' c | otherwise = "(" ++ branchcomp' c ++ ")" branchcomp' (ViewComponent metafield viewfilter _) = concat [ forcelegal (T.unpack (fromMetaField metafield))@@ -86,6 +99,8 @@ branchvals (FilterValues set) = '=' : branchset set branchvals (FilterGlob glob) = '=' : forcelegal glob branchvals (ExcludeValues set) = "!=" ++ branchset set+ branchvals (FilterValuesOrUnset set _) = '=' : branchset set+ branchvals (FilterGlobOrUnset glob _) = '=' : forcelegal glob branchset = intercalate "," . map (forcelegal . decodeBS . fromMetaValue) . S.toList@@ -94,9 +109,22 @@ | otherwise = map (\c -> if isAlphaNum c then c else '_') s is_branchView :: Git.Branch -> Bool-is_branchView (Ref b)- | b == branchViewPrefix = True- | otherwise = (branchViewPrefix <> "/") `B.isPrefixOf` b+is_branchView (Ref b) = (branchViewPrefix <> "/") `B.isPrefixOf` b++{- Converts a view branch as generated by branchView (but not by+ - branchViewOld) back to the parent branch.+ - Has no effect on other branches. -}+fromViewBranch :: Git.Branch -> Git.Branch+fromViewBranch b = + let bs = fromRef' b+ in if (branchViewPrefix <> "/") `B.isPrefixOf` bs+ then + let (branch, _desc) = separate' (== openparen) (B.drop prefixlen bs)+ in Ref branch+ else b+ where+ prefixlen = B.length branchViewPrefix + 1+ openparen = fromIntegral (ord '(') prop_branchView_legal :: View -> Bool prop_branchView_legal = Git.Ref.legal False . fromRef . branchView
Remote.hs view
@@ -173,26 +173,33 @@ - and returns its UUID. Finds even repositories that are not - configured in .git/config. -} nameToUUID :: RemoteName -> Annex UUID-nameToUUID = either giveup return <=< nameToUUID'+nameToUUID n = nameToUUID' n >>= \case+ ([u], _) -> return u+ (_, msg) -> giveup msg -nameToUUID' :: RemoteName -> Annex (Either String UUID)-nameToUUID' "." = Right <$> getUUID -- special case for current repo-nameToUUID' "here" = Right <$> getUUID-nameToUUID' n = byName' n >>= go+nameToUUID' :: RemoteName -> Annex ([UUID], String)+nameToUUID' n+ | n == "." = currentrepo+ | n == "here" = currentrepo+ | otherwise = byName' n >>= go where+ currentrepo = mkone <$> getUUID+ go (Right r) = return $ case uuid r of- NoUUID -> Left $ noRemoteUUIDMsg r- u -> Right u+ NoUUID -> ([], noRemoteUUIDMsg r)+ u -> mkone u go (Left e) = do m <- uuidDescMap let descn = UUIDDesc (encodeBS n) return $ case M.keys (M.filter (== descn) m) of- [u] -> Right u- [] -> let u = toUUID n+ [] -> + let u = toUUID n in case M.keys (M.filterWithKey (\k _ -> k == u) m) of- [] -> Left e- _ -> Right u- _us -> Left "Found multiple repositories with that description"+ [] -> ([], e)+ _ -> ([u], e)+ us -> (us, "found multiple repositories with that description (use the uuid instead to disambiguate)")++ mkone u = ([u], "found a remote") {- Pretty-prints a list of UUIDs of remotes, with their descriptions, - for human display.
Remote/Git.hs view
@@ -351,8 +351,8 @@ let check = do Annex.BranchState.disableUpdate catchNonAsync (autoInitialize (pure [])) $ \e ->- warning $ "remote " ++ Git.repoDescribe r ++- ":" ++ show e+ warning $ "Remote " ++ Git.repoDescribe r +++ ": " ++ show e Annex.getState Annex.repo s <- newLocal r liftIO $ Annex.eval s $ check
Remote/Helper/AWS.hs view
@@ -60,9 +60,8 @@ , ("Asia Pacific (Tokyo)", [BothRegion "ap-northeast-1"]) , ("Asia Pacific (Sydney)", [S3Region "ap-southeast-2"]) , ("South America (São Paulo)", [S3Region "sa-east-1"])- -- These need signature V4 support, which has not landed in- -- the aws library.- -- See https://github.com/aristidb/aws/pull/199+ -- These need signature V4 to be used, and currently v2 is+ -- the default, so to add these would need other changes. -- , ("EU (Frankfurt)", [BothRegion "eu-central-1"]) -- , ("Asia Pacific (Seoul)", [S3Region "ap-northeast-2"]) -- , ("Asia Pacific (Mumbai)", [S3Region "ap-south-1"])
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -83,6 +83,8 @@ (FieldDesc "S3 server hostname (default is Amazon S3)") , optionalStringParser datacenterField (FieldDesc "S3 datacenter to use (US, EU, us-west-1, ..)")+ , optionalStringParser regionField+ (FieldDesc "S3 region to use") , optionalStringParser partsizeField (FieldDesc "part size for multipart upload (eg 1GiB)") , optionalStringParser storageclassField@@ -129,6 +131,9 @@ datacenterField :: RemoteConfigField datacenterField = Accepted "datacenter" +regionField :: RemoteConfigField+regionField = Accepted "region"+ partsizeField :: RemoteConfigField partsizeField = Accepted "partsize" @@ -948,8 +953,16 @@ | otherwise -> AWS.HTTP cfg = case getRemoteConfigValue signatureField c of Just (SignatureVersion 4) -> - S3.s3v4 proto endpoint False S3.SignWithEffort- _ -> S3.s3 proto endpoint False+ (S3.s3v4 proto endpoint False S3.SignWithEffort)+#if MIN_VERSION_aws(0,24,0)+ { S3.s3Region = r }+#endif+ _ -> (S3.s3 proto endpoint False)+#if MIN_VERSION_aws(0,24,0)+ { S3.s3Region = r }+ + r = encodeBS <$> getRemoteConfigValue regionField c+#endif data S3Info = S3Info { bucket :: S3.Bucket@@ -964,6 +977,7 @@ , public :: Bool , publicurl :: Maybe URLString , host :: Maybe String+ , region :: Maybe String } extractS3Info :: ParsedRemoteConfig -> Annex S3Info@@ -987,6 +1001,7 @@ getRemoteConfigValue publicField c , publicurl = getRemoteConfigValue publicurlField c , host = getRemoteConfigValue hostField c+ , region = getRemoteConfigValue regionField c } putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject@@ -1126,7 +1141,12 @@ s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)] s3Info c info = catMaybes [ Just ("bucket", fromMaybe "unknown" (getBucketName c))- , Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c)))+ , Just ("endpoint", decodeBS (S3.s3Endpoint s3c))+#if MIN_VERSION_aws(0,24,0)+ , case S3.s3Region s3c of+ Nothing -> Nothing+ Just r -> Just ("region", decodeBS r)+#endif , Just ("port", show (S3.s3Port s3c)) , Just ("protocol", map toLower (show (S3.s3Protocol s3c))) , Just ("storage class", showstorageclass (getStorageClass c))
Types/GitConfig.hs view
@@ -43,6 +43,7 @@ import Types.RefSpec import Types.RepoVersion import Types.StallDetection+import Types.View import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)@@ -145,6 +146,7 @@ , mergeDirectoryRenames :: Maybe String , annexPrivateRepos :: S.Set UUID , annexAdviceNoSshCaching :: Bool+ , annexViewUnsetDirectory :: ViewUnset } extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig@@ -266,6 +268,8 @@ in mapMaybe get (M.toList (Git.config r)) ] , annexAdviceNoSshCaching = getbool (annexConfig "advicenosshcaching") True+ , annexViewUnsetDirectory = ViewUnset $ fromMaybe "_" $+ getmaybe (annexConfig "viewunsetdirectory") } where getbool k d = fromMaybe d $ getmaybebool k
Types/View.hs view
@@ -1,6 +1,6 @@ {- types for metadata based branch views -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -9,9 +9,9 @@ module Types.View where -import Annex.Common import Types.MetaData import Utility.QuickCheck+import Utility.Monad import qualified Git import qualified Data.Set as S@@ -42,8 +42,13 @@ = FilterValues (S.Set MetaValue) | FilterGlob String | ExcludeValues (S.Set MetaValue)+ | FilterValuesOrUnset (S.Set MetaValue) ViewUnset+ | FilterGlobOrUnset String ViewUnset deriving (Eq, Read, Show) +newtype ViewUnset = ViewUnset String+ deriving (Eq, Read, Show)+ instance Arbitrary ViewFilter where arbitrary = do s <- S.fromList <$> resize 10 (listOf arbitrary)@@ -60,3 +65,5 @@ multiValue (FilterValues s) = S.size s > 1 multiValue (FilterGlob _) = True multiValue (ExcludeValues _) = False+multiValue (FilterValuesOrUnset _ _) = True+multiValue (FilterGlobOrUnset _ _) = True
Utility/LinuxMkLibs.hs view
@@ -1,13 +1,16 @@ {- Linux library copier and binary shimmer -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# Language LambdaCase #-}+ module Utility.LinuxMkLibs ( installLib, parseLdd,+ runLdd, glibcLibs, gconvLibs, inTop,@@ -21,6 +24,8 @@ import Utility.Path.AbsRel import Utility.Split import Utility.FileSystemEncoding+import Utility.Env+import Utility.Exception import Data.Maybe import System.FilePath@@ -63,6 +68,19 @@ parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines where getlib l = headMaybe . words =<< lastMaybe (split " => " l)+ +runLdd :: [String] -> IO [FilePath]+runLdd exes = concat <$> mapM go exes+ where+ go exe = tryNonAsync (readProcess "ldd" [exe]) >>= \case+ Right o -> return (parseLdd o)+ -- ldd for some reason segfaults when run in an arm64+ -- chroot on an amd64 host, on a binary produced by ghc.+ -- But asking ldd to trace loaded objects works.+ Left _e -> do+ environ <- getEnvironment+ let environ' =("LD_TRACE_LOADED_OBJECTS","1"):environ+ parseLdd <$> readProcessEnv exe [] (Just environ') {- Get all glibc libs, and also libgcc_s -@@ -72,7 +90,7 @@ ls <- lines <$> readProcess "sh" ["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"] ls2 <- lines <$> readProcess "sh"- ["-c", "dpkg -L libgcc-s1:$(dpkg --print-architecture) | egrep '\\.so'"]+ ["-c", "(dpkg -L libgcc-s1:$(dpkg --print-architecture 2>/dev/null) || dpkg -L libgcc1:$(dpkg --print-architecture)) | egrep '\\.so'"] return (ls++ls2) {- Get gblibc's gconv libs, which are handled specially.. -}
Utility/Url.hs view
@@ -1,6 +1,6 @@ {- Url downloading. -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -215,7 +215,7 @@ Nothing -> return (Right dne) where go :: URI -> IO (Either String UrlInfo)- go u = case (urlDownloader uo, parseRequest (show u)) of+ go u = case (urlDownloader uo, parseRequestRelaxed u) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> existsconduit r req (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing)@@ -373,7 +373,7 @@ where go = case parseURIRelaxed url of Just u -> checkPolicy uo u $- case (urlDownloader uo, parseRequest (show u)) of+ case (urlDownloader uo, parseRequestRelaxed u) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302)) (downloadConduit meterupdate iv req file uo >> return (Right ()))@@ -598,7 +598,7 @@ Nothing -> return Nothing Just u -> go u `catchNonAsync` const (return Nothing) where- go u = case parseRequest (show u) of+ go u = case parseRequestRelaxed u of Nothing -> return Nothing Just req -> do let req' = applyRequest uo req@@ -613,6 +613,19 @@ parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $ parseURI $ escapeURIString isAllowedInURI s +{- Generate a http-conduit Request for an URI. This is able+ - to deal with some urls that parseRequest would usually reject. + -}+parseRequestRelaxed :: MonadThrow m => URI -> m Request+parseRequestRelaxed u = case uriAuthority u of+ Just ua+ -- parseURI can handle an empty port value, but+ -- parseRequest cannot. So remove the ':' to+ -- make it work.+ | uriPort ua == ":" -> parseRequest $ show $+ u { uriAuthority = Just $ ua { uriPort = "" } }+ _ -> parseRequest (show u)+ {- Some characters like '[' are allowed in eg, the address of - an uri, but cannot appear unescaped further along in the uri. - This handles that, expensively, by successively escaping each character@@ -686,6 +699,9 @@ Nothing -> giveup "malformed url" Just uath -> case uriPort uath of "" -> go (uriRegName uath) defport+ -- ignore an empty port, same as+ -- parseRequestRelaxed does.+ ":" -> go (uriRegName uath) defport -- strict parser because the port we provide to curl -- needs to match the port in the url (':':s) -> case readMaybe s :: Maybe Int of
doc/git-annex-sync.mdwn view
@@ -45,6 +45,13 @@ `remote.<name>.annex-tracking-branch` also must be configured, and have the same value as the currently checked out branch. +When [[git-annex-adjust]](1) has been used to check out an adjusted branch,+running sync will propagate changes that have been made back to the +parent branch, without propagating the adjustments. When+[[git-annex-view]](1) has been used to check out a view branch,+running sync will update the view branch to reflect any changes +to the parent branch or metadata.+ # OPTIONS * `[remote]`
doc/git-annex-vadd.mdwn view
@@ -4,7 +4,7 @@ # SYNOPSIS -git annex vadd `[field=glob ...] [field=value ...] [tag ...]`+git annex vadd `[field=glob ...] [field=value ...] [tag ...] [?tag ...] [field?=glob]` # DESCRIPTION
doc/git-annex-vfilter.mdwn view
@@ -4,7 +4,7 @@ # SYNOPSIS -git annex vfilter `[tag ...] [field=value ...] [!tag ...] [field!=value ...]`+git annex vfilter `[tag ...] [field=value ...] [?tag ...] [field?=glob] [!tag ...] [field!=value ...]` # DESCRIPTION
doc/git-annex-view.mdwn view
@@ -4,7 +4,7 @@ # SYNOPSIS -git annex view `[tag ...] [field=value ...] [field=glob ...] [!tag ...] [field!=value ...]`+git annex view `[tag ...] [field=value ...] [field=glob ...] [?tag ...] [field?=glob] [!tag ...] [field!=value ...]` # DESCRIPTION @@ -21,20 +21,28 @@ copy or move files into them. When you commit, the metadata will be updated to correspond to your changes. Deleting files and committing also updates the metadata.- -There are fields corresponding to the path to the file. So a file-"foo/bar/baz/file" has fields "/=foo", "foo/=bar", and "foo/bar/=baz".-These location fields can be used the same as other metadata to construct-the view.- ++As well as the usual metadata, there are fields available corresponding+to the path to the file. So a file "foo/bar/baz/file" has fields "/=foo",+"foo/=bar", and "foo/bar/=baz". These location fields can be used the+same as other metadata to construct the view.+ For example, `/=foo` will only include files from the foo directory in the view, while `foo/=*` will preserve the subdirectories of the foo directory in the view. To enter a view containing only files that lack a given metadata-field or tag, specify field!=value or !tag. Globs can also be used here,-so `field!="*"` will enter a view containing only files that do not have-the field set to any value.+value or tag, specify field!=value or !tag. (Globs cannot be used here.)++`field?=*` is like `field=*` but adds an additional directory named `_` (by+default) that contains files that do not have the field set to any value.+Similarly, `?tag` adds an additional directory named `_` that contains+files that do not have any tags set. Moving files from the `_` directory to+another directory and committing will set the metadata. And moving files+into the `_` directory and committing will unset the metadata. ++The name of the `_` directory can be changed using the annex.viewunsetdirectory+git config. # OPTIONS
doc/git-annex.mdwn view
@@ -506,7 +506,7 @@ See [[git-annex-metadata]](1) for details. -* `view [tag ...] [field=value ...] [field=glob ...] [!tag ...] [field!=value ...]`+* `view [tag ...] [field=value ...] [field=glob ...] [?tag ...] [field?=glob] [!tag ...] [field!=value ...]` Uses metadata to build a view branch of the files in the current branch, and checks out the view branch. Only files in the current branch whose@@ -1176,6 +1176,12 @@ To configure the behavior in all clones of the repository, this can be set in [[git-annex-config]](1).++* `annex.viewunsetdirectory`++ This configures the name of a directory that is used in a view to contain+ files that do not have metadata set. The default name for the directory + is `"_"`. See [[git-annex-view]](1) for details. * `annex.debug`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230126+Version: 10.20230214 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>