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 <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.DiffDriver where
import Common.Annex
import Command
import Annex.Content
import Annex.Link
import Git.Types
cmd :: [Command]
cmd = [dontCheck repoExists $
command "diffdriver" ("[-- cmd --opts]") seek
SectionPlumbing "external git diff driver shim"]
seek :: 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 )
|
