cc32e31161
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
126 lines
3.9 KiB
Haskell
126 lines
3.9 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2014-2023 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.View where
|
|
|
|
import Command
|
|
import qualified Annex
|
|
import qualified Git
|
|
import qualified Git.Command
|
|
import qualified Git.Ref
|
|
import qualified Git.Branch
|
|
import qualified Git.LsFiles as LsFiles
|
|
import Git.FilePath
|
|
import Git.Status
|
|
import Types.View
|
|
import Annex.View
|
|
import Logs.View
|
|
import Types.AdjustedBranch
|
|
|
|
import qualified System.FilePath.ByteString as P
|
|
|
|
cmd :: Command
|
|
cmd = notBareRepo $
|
|
command "view" SectionMetaData "enter a view branch"
|
|
paramView (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withWords (commandAction . start)
|
|
|
|
start :: [String] -> CommandStart
|
|
start [] = giveup "Specify metadata to include in view"
|
|
start ps = ifM safeToEnterView
|
|
( do
|
|
view <- mkView ps
|
|
go view =<< currentView
|
|
, giveup "Not safe to enter view."
|
|
)
|
|
where
|
|
ai = ActionItemOther Nothing
|
|
si = SeekInput ps
|
|
go view Nothing = starting "view" ai si $
|
|
perform view
|
|
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."
|
|
|
|
safeToEnterView :: Annex Bool
|
|
safeToEnterView = do
|
|
(l, cleanup) <- inRepo $ getStatus [] []
|
|
case filter dangerous l of
|
|
[] -> liftIO cleanup
|
|
_ -> do
|
|
warning "Your uncommitted changes would be lost when entering a view."
|
|
void $ liftIO cleanup
|
|
return False
|
|
where
|
|
dangerous (StagedUnstaged { staged = Nothing, unstaged = Nothing }) = False
|
|
-- Untracked files will not be affected by entering a view,
|
|
-- so are not dangerous.
|
|
dangerous (StagedUnstaged { staged = Just (Untracked _), unstaged = Nothing }) = False
|
|
dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Nothing }) = False
|
|
dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Just (Untracked _) }) = False
|
|
-- Staged changes would have their modifications either be
|
|
-- lost when entering a view, or committed as part of the view.
|
|
-- Either is dangerous because upon leaving the view; the staged
|
|
-- changes would be lost.
|
|
dangerous (StagedUnstaged { staged = Just _ }) = True
|
|
-- Unstaged changes to annexed files would get lost when entering a
|
|
-- view.
|
|
dangerous (StagedUnstaged { unstaged = Just _ }) = True
|
|
|
|
perform :: View -> CommandPerform
|
|
perform view = do
|
|
showAction "searching"
|
|
next $ checkoutViewBranch view Nothing applyView
|
|
|
|
paramView :: String
|
|
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) = do
|
|
vu <- annexViewUnsetDirectory <$> Annex.getGitConfig
|
|
return $ fst $ refineView (View b []) $
|
|
map (parseViewParam vu) (reverse ps)
|
|
|
|
checkoutViewBranch :: View -> Maybe Adjustment -> (View -> Maybe Adjustment -> Annex Git.Branch) -> CommandCleanup
|
|
checkoutViewBranch view madj mkbranch = do
|
|
here <- liftIO getCurrentDirectory
|
|
|
|
branch <- mkbranch view madj
|
|
|
|
showOutput
|
|
ok <- inRepo $ Git.Command.runBool
|
|
[ Param "checkout"
|
|
, Param (Git.fromRef $ Git.Ref.base branch)
|
|
]
|
|
when ok $ do
|
|
setView view
|
|
{- A git repo can easily have empty directories in it,
|
|
- and this pollutes the view, so remove them.
|
|
- (However, emptry directories used by submodules are not
|
|
- removed.) -}
|
|
top <- liftIO . absPath =<< fromRepo Git.repoPath
|
|
(l, cleanup) <- inRepo $
|
|
LsFiles.notInRepoIncludingEmptyDirectories [] False [top]
|
|
forM_ l (removeemptydir top)
|
|
liftIO $ void cleanup
|
|
unlessM (liftIO $ doesDirectoryExist here) $ do
|
|
showLongNote (cwdmissing (fromRawFilePath top))
|
|
return ok
|
|
where
|
|
removeemptydir top d = do
|
|
p <- inRepo $ toTopFilePath d
|
|
liftIO $ tryIO $ removeDirectory $
|
|
fromRawFilePath $ (top P.</> getTopFilePath p)
|
|
cwdmissing top = unlines
|
|
[ "This view does not include the subdirectory you are currently in."
|
|
, "Perhaps you should: cd " ++ top
|
|
]
|