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

@@ -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 -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
-applyView' mkviewedfile getfilemetadata view = do
+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 -> Maybe Adjustment -> Annex (Maybe Git.Ref)
-updateView view = do
+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 -> Maybe Adjustment -> Annex Git.Branch
-genViewBranch view = withViewIndex $ do
+genViewBranch view madj = withViewIndex $ do
-	let branch = branchView view
+	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 :: (View -> Maybe Adjustment -> Annex a) -> Annex a
-withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView
+withCurrentView a = maybe (giveup "Not in a view.") (uncurry a) =<< currentView

Command/PreCommit.hs

@@ -45,10 +45,9 @@ seek ps = do
 	runAnnexHook preCommitAnnexHook
 
 	-- committing changes to a view updates metadata
-	mv <- currentView
+	currentView >>= \case
-	case mv of
 		Nothing -> noop
-		Just v -> withViewChanges
+		Just (v, _madj) -> withViewChanges
 			(addViewMetaData v)
 			(removeViewMetaData v)
 

Command/Sync.hs

@@ -439,31 +439,32 @@ 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
+	-- When in a view branch, update it to reflect any changes
-	-- back to the original branch. The adjusted branch may also need
+	-- of its parent branch or the metadata.
-	-- to be updated, if the adjustment is not stable, and the usual
+	currentView >>= \case
-	-- configuration does not update it.
+		Just (view, madj') -> updateView view madj' >>= \case
-	case madj of
+			Nothing -> noop
-		Just adj -> do
+			Just newcommit -> do
-			let origbranch = branch
+				ok <- inRepo $ Git.Command.runBool
-			propigateAdjustedCommits origbranch adj
+					[ Param "merge"
-			unless (adjustmentIsStable adj) $
+					, Param (Git.fromRef newcommit)
-				annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case
+					]
-					0 -> adjustedBranchRefreshFull adj origbranch
+				unless ok $
-					_ -> return ()
+					giveup $ "failed to update view"
-		-- When in a view branch, update it to reflect any changes
+		-- When in an adjusted branch, propigate any changes
-		-- of its parent branch or the metadata.
+		-- made to it back to the original branch. The adjusted
-		Nothing -> currentView >>= \case
+		-- 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
-			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) (fromViewBranch branch)

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."

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]

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

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

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 -> Maybe Adjustment -> (View -> Maybe Adjustment -> Annex Git.Branch) -> CommandCleanup
-checkoutViewBranch view mkbranch = do
+checkoutViewBranch view madj mkbranch = do
 	here <- liftIO getCurrentDirectory
 
-	branch <- mkbranch view
+	branch <- mkbranch view madj
 	
 	showOutput
 	ok <- inRepo $ Git.Command.runBool

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. -}
+{- Gets the currently checked out view, if there is one. 
-currentView :: Annex (Maybe View)
+ -
+ - 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 =
+	go (Just b) = case adjustedToOriginal b of
-		headMaybe . filter (\v -> branchView v == b || branchViewOld v == b) 
+		Nothing -> getvb b Nothing
-			<$> recentViews
+		Just (adj, b') -> getvb b' (Just adj)
-	go _ = return Nothing
+	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 -> Maybe Adjustment -> Git.Branch
-branchView view = Git.Ref $ 
+branchView view madj = case madj of
-	branchViewPrefix <> "/" <> basebranch
+	Nothing -> vb
-		<> "(" <> branchViewDesc view False <> ")"
+	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 = 
+fromViewBranch b = case adjustedToOriginal b of
-	let bs = fromRef' b
+	Nothing -> go b
-	in if (branchViewPrefix <> "/") `B.isPrefixOf` bs
+	Just (_adj, b') -> go b'
-		then 
-			let (branch, _desc) = separate' (== openparen) (B.drop prefixlen bs)
-			in Ref branch
-		else 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)