53526136e8
This is groundwork for nested seek loops, eg seeking over all files and then performing commandActions on a list of remotes, which can be done concurrently. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
118 lines
3.6 KiB
Haskell
118 lines
3.6 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.View where
|
|
|
|
import Command
|
|
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
|
|
|
|
cmd :: Command
|
|
cmd = notBareRepo $ notDirect $
|
|
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 = do
|
|
showStart' "view" Nothing
|
|
ifM safeToEnterView
|
|
( do
|
|
view <- mkView ps
|
|
go view =<< currentView
|
|
, giveup "Not safe to enter view."
|
|
)
|
|
where
|
|
go view Nothing = next $ perform view
|
|
go view (Just v)
|
|
| 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 applyView
|
|
|
|
paramView :: String
|
|
paramView = paramRepeating "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
|
|
|
|
checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup
|
|
checkoutViewBranch view mkbranch = do
|
|
here <- liftIO getCurrentDirectory
|
|
|
|
branch <- mkbranch view
|
|
|
|
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 top)
|
|
return ok
|
|
where
|
|
removeemptydir top d = do
|
|
p <- inRepo $ toTopFilePath d
|
|
liftIO $ tryIO $ removeDirectory (top </> getTopFilePath p)
|
|
cwdmissing top = unlines
|
|
[ "This view does not include the subdirectory you are currently in."
|
|
, "Perhaps you should: cd " ++ top
|
|
]
|