aboutsummaryrefslogtreecommitdiff
path: root/Command/DiffDriver.hs
blob: 2c9b4a39dc246a126c751fe5f582c5abe9937b50 (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
91
92
93
94
95
96
97
98
99
100
101
102
{- git-annex command
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.DiffDriver where

import Command
import Annex.Content
import Annex.Link
import Git.Types

cmd :: Command
cmd = dontCheck repoExists $
	command "diffdriver" SectionPlumbing 
		"external git diff driver shim"
		("-- cmd --") (withParams seek)

seek :: CmdParams -> CommandSeek
seek = withWords start

start :: [String] -> CommandStart
start opts = do
	let (req, differ) = parseReq opts
	void $ liftIO . exitBool =<< liftIO . differ =<< fixupReq req
	stop

data Req 
	= Req
		{ rPath :: FilePath
		, rOldFile :: FilePath
		, rOldHex :: String
		, rOldMode :: String
		, rNewFile :: FilePath
		, rNewHex :: String
		, rNewMode ::String
		}
	| UnmergedReq
		{ rPath :: FilePath
		}

type Differ = Req -> IO Bool

serializeReq :: Req -> [CommandParam]
serializeReq req@(UnmergedReq {}) = [Param $ rPath req]
serializeReq req@(Req {}) = map Param
	[ rPath req
	, rOldFile req
	, rOldHex req
	, rOldMode req
	, rNewFile req
	, rNewHex req
	, rNewMode req
	]

parseReq :: [String] -> (Req, Differ)
parseReq opts = case separate (== "--") opts of
	(c:ps, l) -> (mk l, externalDiffer c ps)
	([],_) -> badopts
  where
	mk (path:old_file:old_hex:old_mode:new_file:new_hex:new_mode:[]) =
		Req
			{ rPath = path
			, rOldFile = old_file
			, rOldHex = old_hex
			, rOldMode = old_mode
			, rNewFile = new_file
			, rNewHex = new_hex
			, rNewMode = new_mode
			}
	mk (unmergedpath:[]) = UnmergedReq { rPath = unmergedpath }
	mk _ = badopts

	badopts = error $ "Unexpected input: " ++ unwords opts

{- Check if either file is a symlink to a git-annex object,
 - which git-diff will leave as a normal file containing the link text.
 - Adjust the Req to instead point to the actual location of the annexed
 - object (which may or may not exist). -}
fixupReq :: Req -> Annex Req
fixupReq req@(UnmergedReq {}) = return req
fixupReq req@(Req {}) = 
	check rOldFile rOldMode (\r f -> r { rOldFile = f }) req
		>>= check rNewFile rNewMode (\r f -> r { rNewFile = f })
  where
	check getfile getmode setfile r = case readBlobType (getmode r) of
		Just SymlinkBlob -> do
			v <- getAnnexLinkTarget' (getfile r) False
			case fileKey . takeFileName =<< v of
				Nothing -> return r
				Just k -> setfile r <$>
					withObjectLoc k
						-- indirect mode
						return 
						-- direct mode
						(return . Prelude.head)
		_ -> return r

externalDiffer :: String -> [String] -> Differ
externalDiffer c ps = \req -> boolSystem c (map Param ps ++ serializeReq req )