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
2023-02-27 14:39:33 -04:00 · 2023-02-27 14:39:33 -04:00 · cc32e31161
commit cc32e31161
parent 2a966f49f2
9 changed files with 113 additions and 79 deletions
--- 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
--- 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)

--- 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)

--- 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."
--- 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]
--- 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
--- 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
--- a/Command/View.hs
+++ b/Command/View.hs
@ -1,6 +1,6 @@
 {- git-annex command
 -
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2023 Joey Hess <id@joeyh.name>
 -
 - 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
--- 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)