aboutsummaryrefslogtreecommitdiff
path: root/Command/Status.hs
blob: 26e96a9253324e73a2934b4fe336a49a84917c22 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
{- git-annex command
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Status where

import Common.Annex
import Command
import Annex.CatFile
import Annex.Content.Direct
import Config
import qualified Git.LsFiles as LsFiles
import qualified Git.Ref
import qualified Git

cmd :: [Command]
cmd = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $
	command "status" paramPaths seek SectionCommon
		"show the working tree status"]

seek :: CommandSeek
seek = withWords start

start :: [FilePath] -> CommandStart
start [] = do
	-- Like git status, when run without a directory, behave as if
	-- given the path to the top of the repository.
	top <- fromRepo Git.repoPath
	d <- liftIO $ relPathCwdToFile top
	start' [d]
start locs = start' locs
	
start' :: [FilePath] -> CommandStart
start' locs = do
	(l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
	getstatus <- ifM isDirect
		( return statusDirect
		, return $ Just <$$> statusIndirect
		)
	forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
	void $ liftIO cleanup
	stop

data Status 
	= NewFile
	| DeletedFile
	| ModifiedFile

showStatus :: Status -> String
showStatus NewFile = "?"
showStatus DeletedFile = "D"
showStatus ModifiedFile = "M"

showFileStatus :: FilePath -> Status -> Annex ()
showFileStatus f s  = unlessM (showFullJSON [("status", ss), ("file", f)]) $
	liftIO $ putStrLn $ ss ++ " " ++ f
  where
	ss = showStatus s

statusDirect :: FilePath -> Annex (Maybe Status)
statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
  where
	checkstatus Nothing = return $ Just DeletedFile
	checkstatus (Just s)
		-- Git thinks that present direct mode files are modifed,
		-- so have to check.
		| not (isSymbolicLink s) = checkkey s =<< catKeyFile f
		| otherwise = Just <$> checkNew f
	
	checkkey s (Just k) = ifM (sameFileStatus k f s)
		( return Nothing
		, return $ Just ModifiedFile
		)
	checkkey _ Nothing = Just <$> checkNew f

statusIndirect :: FilePath -> Annex Status
statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
	( checkNew f
	, return DeletedFile
	)
  where

checkNew :: FilePath -> Annex Status
checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
	( return ModifiedFile
	, return NewFile
	)