From cc32e31161a27b0eb2adb6a832f3d1e843cdf98b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 27 Feb 2023 14:39:33 -0400 Subject: [PATCH] understand adjusted view branch names An adjusted view branch has a name like "refs/heads/adjusted/views/master(author=_)(unlocked)", so it is a view branch that has been converted to an adjusted branch. Made Logs.View support such branch names. So now git-annex sync and pre-commit handle updating metadata on commit in such a branch. Much remains to be done to fully support adjusted view branches, including actually applying the adjustment when updating the view branch. Sponsored-by: Graham Spencer on Patreon --- Annex/View.hs | 36 ++++++++++++----------- Command/PreCommit.hs | 5 ++-- Command/Sync.hs | 51 ++++++++++++++++---------------- Command/VAdd.hs | 4 +-- Command/VCycle.hs | 4 +-- Command/VFilter.hs | 4 +-- Command/VPop.hs | 5 ++-- Command/View.hs | 13 ++++---- Logs/View.hs | 70 +++++++++++++++++++++++++++++++------------- 9 files changed, 113 insertions(+), 79 deletions(-) diff --git a/Annex/View.hs b/Annex/View.hs index 57778ff67b..18c2b8038a 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -12,6 +12,7 @@ module Annex.View where import Annex.Common import Annex.View.ViewedFile import Types.View +import Types.AdjustedBranch import Types.MetaData import Annex.MetaData import qualified Annex @@ -418,7 +419,7 @@ getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName {- Applies a view to the currently checked out branch, generating a new - branch for the view. -} -applyView :: View -> Annex Git.Branch +applyView :: View -> Maybe Adjustment -> Annex Git.Branch applyView = applyView' viewedFileFromReference getWorkTreeMetaData {- Generates a new branch for a View, which must be a more narrow @@ -426,7 +427,7 @@ applyView = applyView' viewedFileFromReference getWorkTreeMetaData - checked out branch. That is, it must match a subset of the files - in view, not any others. -} -narrowView :: View -> Annex Git.Branch +narrowView :: View -> Maybe Adjustment -> Annex Git.Branch narrowView = applyView' viewedFileReuse getViewedFileMetaData {- Go through each staged file. @@ -435,26 +436,27 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData - Look up the metadata of annexed files, and generate any ViewedFiles, - and stage them. -} -applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch -applyView' mkviewedfile getfilemetadata view = do +applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch +applyView' mkviewedfile getfilemetadata view madj = do top <- fromRepo Git.repoPath (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] - applyView'' mkviewedfile getfilemetadata view l clean $ + applyView'' mkviewedfile getfilemetadata view madj l clean $ \(f, sha, mode) -> do topf <- inRepo (toTopFilePath f) k <- lookupKey f return (topf, sha, toTreeItemType mode, k) - genViewBranch view + genViewBranch view madj applyView'' :: MkViewedFile -> (FilePath -> MetaData) -> View + -> Maybe Adjustment -> [t] -> IO Bool -> (t -> Annex (TopFilePath, Sha, Maybe TreeItemType, Maybe Key)) -> Annex () -applyView'' mkviewedfile getfilemetadata view l clean conv = do +applyView'' mkviewedfile getfilemetadata view madj l clean conv = do viewg <- withNewViewIndex gitRepo withUpdateIndex viewg $ \uh -> do g <- Annex.gitRepo @@ -518,13 +520,13 @@ applyView'' mkviewedfile getfilemetadata view l clean conv = do - 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 +updateView :: View -> Maybe Adjustment -> Annex (Maybe Git.Ref) +updateView view madj = do (l, clean) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive (Git.LsTree.LsTreeLong True) (viewParentBranch view) - applyView'' viewedFileFromReference getWorkTreeMetaData view l clean $ + applyView'' viewedFileFromReference getWorkTreeMetaData view madj l clean $ \ti -> do let ref = Git.Ref.branchFileRef (viewParentBranch view) (getTopFilePath (Git.LsTree.file ti)) @@ -537,13 +539,13 @@ updateView view = do , (toTreeItemType (Git.LsTree.mode ti)) , k ) - oldcommit <- inRepo $ Git.Ref.sha (branchView view) + oldcommit <- inRepo $ Git.Ref.sha (branchView view madj) 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 msg = "updated " ++ fromRef (branchView view madj) let parent = catMaybes [oldcommit] inRepo (Git.Branch.commitTree cmode msg parent newtree) else return Nothing @@ -593,12 +595,12 @@ withNewViewIndex a = do {- Generates a branch for a view, using the view index file - to make a commit to the view branch. The view branch is not - checked out, but entering it will display the view. -} -genViewBranch :: View -> Annex Git.Branch -genViewBranch view = withViewIndex $ do - let branch = branchView view +genViewBranch :: View -> Maybe Adjustment -> Annex Git.Branch +genViewBranch view madj = withViewIndex $ do + let branch = branchView view madj cmode <- annexCommitMode <$> Annex.getGitConfig void $ inRepo $ Git.Branch.commit cmode True (fromRef branch) branch [] return branch -withCurrentView :: (View -> Annex a) -> Annex a -withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView +withCurrentView :: (View -> Maybe Adjustment -> Annex a) -> Annex a +withCurrentView a = maybe (giveup "Not in a view.") (uncurry a) =<< currentView diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 2191f4f332..f58a44f354 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -45,10 +45,9 @@ seek ps = do runAnnexHook preCommitAnnexHook -- committing changes to a view updates metadata - mv <- currentView - case mv of + currentView >>= \case Nothing -> noop - Just v -> withViewChanges + Just (v, _madj) -> withViewChanges (addViewMetaData v) (removeViewMetaData v) diff --git a/Command/Sync.hs b/Command/Sync.hs index d67193ddb3..f378950592 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -439,32 +439,33 @@ pushLocal o b = stopUnless (notOnlyAnnex o) $ do updateBranches :: CurrBranch -> Annex () updateBranches (Nothing, _) = noop updateBranches (Just branch, madj) = do - -- When in an adjusted branch, propigate any changes made to it - -- back to the original branch. The adjusted branch may also need - -- to be updated, if the adjustment is not stable, and the usual - -- configuration does not update it. - case madj of - Just adj -> do - let origbranch = branch - propigateAdjustedCommits origbranch adj - unless (adjustmentIsStable adj) $ - 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 + -- When in a view branch, update it to reflect any changes + -- of its parent branch or the metadata. + currentView >>= \case + Just (view, madj') -> updateView view madj' >>= \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" - + Just newcommit -> do + ok <- inRepo $ Git.Command.runBool + [ Param "merge" + , Param (Git.fromRef newcommit) + ] + unless ok $ + giveup $ "failed to update view" + -- When in an adjusted branch, propigate any changes + -- made to it back to the original branch. The adjusted + -- branch may also need to be updated, if the adjustment + -- is not stable, and the usual configuration does not + -- update it. + Nothing -> case madj of + Just adj -> do + let origbranch = branch + propigateAdjustedCommits origbranch adj + unless (adjustmentIsStable adj) $ + annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case + 0 -> adjustedBranchRefreshFull adj origbranch + _ -> return () + Nothing -> noop + -- Update the sync branch to match the new state of the branch inRepo $ updateBranch (syncBranch branch) (fromViewBranch branch) diff --git a/Command/VAdd.hs b/Command/VAdd.hs index e190eb1260..3c002645c6 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -23,7 +23,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $ - withCurrentView $ \view -> do + withCurrentView $ \view madj -> do vu <- annexViewUnsetDirectory <$> Annex.getGitConfig let (view', change) = refineView view $ map (parseViewParam vu) (reverse params) @@ -34,5 +34,5 @@ start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $ Narrowing -> next $ do if visibleViewSize view' == visibleViewSize view then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd." - else checkoutViewBranch view' narrowView + else checkoutViewBranch view' madj narrowView Widening -> giveup "Widening view to match more files is not currently supported." diff --git a/Command/VCycle.hs b/Command/VCycle.hs index 5c8d84ba91..e3b4a9fddc 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -26,13 +26,13 @@ start ::CommandStart start = go =<< currentView where go Nothing = giveup "Not in a view." - go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput []) $ do + go (Just (v, madj)) = starting "vcycle" (ActionItemOther Nothing) (SeekInput []) $ do let v' = v { viewComponents = vcycle [] (viewComponents v) } if v == v' then do showNote "unchanged" next $ return True - else next $ checkoutViewBranch v' narrowView + else next $ checkoutViewBranch v' madj narrowView vcycle rest (c:cs) | viewVisible c = rest ++ cs ++ [c] diff --git a/Command/VFilter.hs b/Command/VFilter.hs index ec2274a242..bc03cace2a 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -22,10 +22,10 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart start params = starting "vfilter" (ActionItemOther Nothing) (SeekInput params) $ - withCurrentView $ \view -> do + withCurrentView $ \view madj -> do vu <- annexViewUnsetDirectory <$> Annex.getGitConfig let view' = filterView view $ 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 + else checkoutViewBranch view' madj narrowView diff --git a/Command/VPop.hs b/Command/VPop.hs index 59afbfc8f4..ed145963c3 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -27,7 +27,7 @@ start :: [String] -> CommandStart start ps = go =<< currentView where go Nothing = giveup "Not in a view." - go (Just v) = starting "vpop" ai si $ do + go (Just (v, madj)) = starting "vpop" ai si $ do removeView v (oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) <$> recentViews @@ -35,7 +35,8 @@ start ps = go =<< currentView case vs of (oldv:_) -> next $ do showOutput - checkoutViewBranch oldv (return . branchView) + checkoutViewBranch oldv madj + (\v' madj' -> return (branchView v' madj')) _ -> next $ do showOutput inRepo $ Git.Command.runBool diff --git a/Command/View.hs b/Command/View.hs index 9954229e10..72d9e7d912 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014 Joey Hess + - Copyright 2014-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,6 +19,7 @@ import Git.Status import Types.View import Annex.View import Logs.View +import Types.AdjustedBranch import qualified System.FilePath.ByteString as P @@ -43,7 +44,7 @@ start ps = ifM safeToEnterView si = SeekInput ps go view Nothing = starting "view" ai si $ perform view - go view (Just v) + go view (Just (v, _madj)) | v == view = stop | otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view." @@ -75,7 +76,7 @@ safeToEnterView = do perform :: View -> CommandPerform perform view = do showAction "searching" - next $ checkoutViewBranch view applyView + next $ checkoutViewBranch view Nothing applyView paramView :: String paramView = paramRepeating "TAG FIELD=GLOB ?TAG FIELD?=GLOB FIELD!=VALUE" @@ -89,11 +90,11 @@ mkView ps = go =<< inRepo Git.Branch.current return $ fst $ refineView (View b []) $ map (parseViewParam vu) (reverse ps) -checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup -checkoutViewBranch view mkbranch = do +checkoutViewBranch :: View -> Maybe Adjustment -> (View -> Maybe Adjustment -> Annex Git.Branch) -> CommandCleanup +checkoutViewBranch view madj mkbranch = do here <- liftIO getCurrentDirectory - branch <- mkbranch view + branch <- mkbranch view madj showOutput ok <- inRepo $ Git.Command.runBool diff --git a/Logs/View.hs b/Logs/View.hs index b75a0c7b2c..afb036c202 100644 --- a/Logs/View.hs +++ b/Logs/View.hs @@ -19,12 +19,15 @@ module Logs.View ( branchView, fromViewBranch, is_branchView, + branchViewPrefix, prop_branchView_legal, ) where import Annex.Common import Types.View import Types.MetaData +import Types.AdjustedBranch +import Annex.AdjustedBranch.Name import qualified Git import qualified Git.Branch import qualified Git.Ref @@ -54,31 +57,49 @@ recentViews = do f <- fromRawFilePath <$> fromRepo gitAnnexViewLog liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) -{- Gets the currently checked out view, if there is one. -} -currentView :: Annex (Maybe View) +{- Gets the currently checked out view, if there is one. + - + - The view may also have an adjustment applied to it. + -} +currentView :: Annex (Maybe (View, Maybe Adjustment)) currentView = go =<< inRepo Git.Branch.current where - go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b = - headMaybe . filter (\v -> branchView v == b || branchViewOld v == b) - <$> recentViews - go _ = return Nothing + go (Just b) = case adjustedToOriginal b of + Nothing -> getvb b Nothing + Just (adj, b') -> getvb b' (Just adj) + go Nothing = return Nothing + getvb b madj + | branchViewPrefix `B.isPrefixOf` fromRef' b = do + vb <- headMaybe + . filter (\v -> branchView v Nothing == b || branchViewOld v == b) + <$> recentViews + case vb of + Just vb' -> return (Just (vb', madj)) + Nothing -> return Nothing + | otherwise = return Nothing + +{- Note that this is not the prefix used when an adjustment is applied to a + - view branch. -} branchViewPrefix :: B.ByteString branchViewPrefix = "refs/heads/views" -{- Generates a git branch name for a View. +{- Generates a git branch name for a View, which may also have an + - adjustment applied to it. - - 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 - 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 = Git.Ref $ - branchViewPrefix <> "/" <> basebranch - <> "(" <> branchViewDesc view False <> ")" +branchView :: View -> Maybe Adjustment -> Git.Branch +branchView view madj = case madj of + Nothing -> vb + Just adj -> adjBranch $ originalToAdjusted vb adj where basebranch = fromRef' (Git.Ref.base (viewParentBranch view)) + vb = Git.Ref $ branchViewPrefix <> "/" <> basebranch + <> "(" <> branchViewDesc view False <> ")" {- Old name used for a view did not include the name of the parent branch. -} branchViewOld :: View -> Git.Branch @@ -109,22 +130,31 @@ branchViewDesc view pareninvisibles = encodeBS $ | otherwise = map (\c -> if isAlphaNum c then c else '_') s is_branchView :: Git.Branch -> Bool -is_branchView (Ref b) = (branchViewPrefix <> "/") `B.isPrefixOf` b +is_branchView b = case adjustedToOriginal b of + Nothing -> hasprefix b + Just (_adj, b') -> hasprefix b' + where + hasprefix (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 +fromViewBranch b = case adjustedToOriginal b of + Nothing -> go b + Just (_adj, b') -> go b' where + go 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' + prefixlen = B.length branchViewPrefix + 1 openparen = fromIntegral (ord '(') prop_branchView_legal :: View -> Bool -prop_branchView_legal = Git.Ref.legal False . fromRef . branchView +prop_branchView_legal = Git.Ref.legal False + . fromRef . (\v -> branchView v Nothing)