1{- git-annex command 2 - 3 - Copyright 2014 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8module Command.View where 9 10import Command 11import qualified Git 12import qualified Git.Command 13import qualified Git.Ref 14import qualified Git.Branch 15import qualified Git.LsFiles as LsFiles 16import Git.FilePath 17import Git.Status 18import Types.View 19import Annex.View 20import Logs.View 21 22import qualified System.FilePath.ByteString as P 23 24cmd :: Command 25cmd = notBareRepo $ 26 command "view" SectionMetaData "enter a view branch" 27 paramView (withParams seek) 28 29seek :: CmdParams -> CommandSeek 30seek = withWords (commandAction . start) 31 32start :: [String] -> CommandStart 33start [] = giveup "Specify metadata to include in view" 34start ps = ifM safeToEnterView 35 ( do 36 view <- mkView ps 37 go view =<< currentView 38 , giveup "Not safe to enter view." 39 ) 40 where 41 ai = ActionItemOther Nothing 42 si = SeekInput ps 43 go view Nothing = starting "view" ai si $ 44 perform view 45 go view (Just v) 46 | v == view = stop 47 | otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view." 48 49safeToEnterView :: Annex Bool 50safeToEnterView = do 51 (l, cleanup) <- inRepo $ getStatus [] [] 52 case filter dangerous l of 53 [] -> liftIO cleanup 54 _ -> do 55 warning "Your uncommitted changes would be lost when entering a view." 56 void $ liftIO cleanup 57 return False 58 where 59 dangerous (StagedUnstaged { staged = Nothing, unstaged = Nothing }) = False 60 -- Untracked files will not be affected by entering a view, 61 -- so are not dangerous. 62 dangerous (StagedUnstaged { staged = Just (Untracked _), unstaged = Nothing }) = False 63 dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Nothing }) = False 64 dangerous (StagedUnstaged { unstaged = Just (Untracked _), staged = Just (Untracked _) }) = False 65 -- Staged changes would have their modifications either be 66 -- lost when entering a view, or committed as part of the view. 67 -- Either is dangerous because upon leaving the view; the staged 68 -- changes would be lost. 69 dangerous (StagedUnstaged { staged = Just _ }) = True 70 -- Unstaged changes to annexed files would get lost when entering a 71 -- view. 72 dangerous (StagedUnstaged { unstaged = Just _ }) = True 73 74perform :: View -> CommandPerform 75perform view = do 76 showAction "searching" 77 next $ checkoutViewBranch view applyView 78 79paramView :: String 80paramView = paramRepeating "FIELD=VALUE" 81 82mkView :: [String] -> Annex View 83mkView ps = go =<< inRepo Git.Branch.current 84 where 85 go Nothing = giveup "not on any branch!" 86 go (Just b) = return $ fst $ refineView (View b []) $ 87 map parseViewParam $ reverse ps 88 89checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup 90checkoutViewBranch view mkbranch = do 91 here <- liftIO getCurrentDirectory 92 93 branch <- mkbranch view 94 95 showOutput 96 ok <- inRepo $ Git.Command.runBool 97 [ Param "checkout" 98 , Param (Git.fromRef $ Git.Ref.base branch) 99 ] 100 when ok $ do 101 setView view 102 {- A git repo can easily have empty directories in it, 103 - and this pollutes the view, so remove them. 104 - (However, emptry directories used by submodules are not 105 - removed.) -} 106 top <- liftIO . absPath =<< fromRepo Git.repoPath 107 (l, cleanup) <- inRepo $ 108 LsFiles.notInRepoIncludingEmptyDirectories [] False [top] 109 forM_ l (removeemptydir top) 110 liftIO $ void cleanup 111 unlessM (liftIO $ doesDirectoryExist here) $ do 112 showLongNote (cwdmissing (fromRawFilePath top)) 113 return ok 114 where 115 removeemptydir top d = do 116 p <- inRepo $ toTopFilePath d 117 liftIO $ tryIO $ removeDirectory $ 118 fromRawFilePath $ (top P.</> getTopFilePath p) 119 cwdmissing top = unlines 120 [ "This view does not include the subdirectory you are currently in." 121 , "Perhaps you should: cd " ++ top 122 ] 123