5d98cba923
Now there's a ByteString used all the way from disk to Key. The main complication in this conversion was the use of fromInternalGitPath in several places to munge things on Windows. The things that used that were changed to parse the ByteString using either path separator. Also some code that had read from files to a String lazily was changed to read a minimal strict ByteString.
102 lines
2.5 KiB
Haskell
102 lines
2.5 KiB
Haskell
{- 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 (commandAction . 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 = giveup $ "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 readTreeItemType (getmode r) of
|
|
Just TreeSymlink -> do
|
|
v <- getAnnexLinkTarget' (getfile r) False
|
|
case parseLinkTargetOrPointer =<< 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 )
|