diffdriver: New git-annex command, to make git external diff drivers work with annexed files.

Closes https://github.com/datalad/datalad/issues/18

Command/DiffDriver.hs

@@ -0,0 +1,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 )