From d8fb97806c430be8358b2b77d67c02e876278d2f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 3 Feb 2012 15:12:41 -0400 Subject: [PATCH] support all filename encodings with ghc 7.4 Under ghc 7.4, this seems to be able to handle all filename encodings again. Including filename encodings that do not match the LANG setting. I think this will not work with earlier versions of ghc, it uses some ghc internals. Turns out that ghc 7.4 has a special filesystem encoding that it uses when reading/writing filenames (as FilePaths). This encoding is documented to allow "arbitrary undecodable bytes to be round-tripped through it". So, to get FilePaths from eg, git ls-files, set the Handle that is reading from git to use this encoding. Then things basically just work. However, I have not found a way to make Text read using this encoding. Text really does assume unicode. So I had to switch back to using String when reading/writing data to git. Which is a pity, because it's some percent slower, but at least it works. Note that stdout and stderr also have to be set to this encoding, or printing out filenames that contain undecodable bytes causes a crash. IMHO this is a misfeature in ghc, that the user can pass you a filename, which you can readFile, etc, but that default, putStr of filename may cause a crash! Git.CheckAttr gave me special trouble, because the filenames I got back from git, after feeding them in, had further encoding breakage. Rather than try to deal with that, I just zip up the input filenames with the attributes. Which must be returned in the same order queried for this to work. Also of note is an apparent GHC bug I worked around in Git.CheckAttr. It used to forkProcess and feed git from the child process. Unfortunatly, after this forkProcess, accessing the `files` variable from the parent returns []. Not the value that was passed into the function. This screams of a bad bug, that's clobbering a variable, but for now I just avoid forkProcess there to work around it. That forkProcess was itself only added because of a ghc bug, #624389. I've confirmed that the test case for that bug doesn't reproduce it with ghc 7.4. So that's ok, except for the new ghc bug I have not isolated and reported. Why does this simple bit of code magnet the ghc bugs? :) Also, the symlink touching code is currently broken, when used on utf-8 filenames in a non-utf-8 locale, or probably on any filename containing undecodable bytes, and I temporarily commented it out. --- Command/Add.hs | 8 +++++--- Command/Uninit.hs | 4 +--- Command/Unused.hs | 2 +- Git/Branch.hs | 15 ++++++--------- Git/CheckAttr.hs | 32 +++++--------------------------- Git/Command.hs | 26 +++++++++++--------------- Git/LsTree.hs | 21 ++++++++++----------- Git/Queue.hs | 5 +++-- Git/Ref.hs | 6 ++---- Git/UnionMerge.hs | 13 +++++++------ Messages.hs | 13 +++++-------- Utility/Misc.hs | 8 ++++++++ 12 files changed, 64 insertions(+), 89 deletions(-) diff --git a/Command/Add.hs b/Command/Add.hs index 9410601b8b..944525ea5e 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -82,9 +82,11 @@ cleanup file key hascontent = do -- touch the symlink to have the same mtime as the -- file it points to - liftIO $ do - mtime <- modificationTime <$> getFileStatus file - touch file (TimeSpec mtime) False + -- XXX Currently broken on non-utf8 locales when + -- dealing with utf-8 filenames. + --liftIO $ do + --mtime <- modificationTime <$> getFileStatus file + --touch file (TimeSpec mtime) False force <- Annex.getState Annex.force if force diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 878547bc36..d6283a77da 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -7,8 +7,6 @@ module Command.Uninit where -import qualified Data.Text.Lazy as L - import Common.Annex import Command import qualified Git @@ -29,7 +27,7 @@ check = do when (b == Annex.Branch.name) $ error $ "cannot uninit when the " ++ show b ++ " branch is checked out" where - current_branch = Git.Ref . Prelude.head . lines . L.unpack <$> revhead + current_branch = Git.Ref . Prelude.head . lines <$> revhead revhead = inRepo $ Git.Command.pipeRead [Params "rev-parse --abbrev-ref HEAD"] diff --git a/Command/Unused.hs b/Command/Unused.hs index 67f743ab08..1c82b9ae4a 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -162,7 +162,7 @@ excludeReferenced l = do refs = map (Git.Ref . snd) . nubBy uniqref . filter ourbranches . - map (separate (== ' ')) . lines . L.unpack + map (separate (== ' ')) . lines uniqref (a, _) (b, _) = a == b ourbranchend = '/' : show Annex.Branch.name ourbranches (_, b) = not $ ourbranchend `isSuffixOf` b diff --git a/Git/Branch.hs b/Git/Branch.hs index 546d4a96b3..cd91882283 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -7,8 +7,6 @@ module Git.Branch where -import qualified Data.Text.Lazy as L - import Common import Git import Git.Sha @@ -19,15 +17,15 @@ current :: Repo -> IO (Maybe Git.Ref) current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r where parse v - | L.null v = Nothing - | otherwise = Just $ Git.Ref $ firstLine $ L.unpack v + | null v = Nothing + | otherwise = Just $ Git.Ref $ firstLine v {- Checks if the second branch has any commits not present on the first - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . L.null <$> diffs + | otherwise = not . null <$> diffs where diffs = pipeRead [ Param "log" @@ -73,15 +71,14 @@ fastForward branch (first:rest) repo = do - with the specified parent refs, and returns the committed sha -} commit :: String -> Branch -> [Ref] -> Repo -> IO Sha commit message branch parentrefs repo = do - tree <- getSha "write-tree" $ asString $ + tree <- getSha "write-tree" $ pipeRead [Param "write-tree"] repo - sha <- getSha "commit-tree" $ asString $ + sha <- getSha "commit-tree" $ ignorehandle $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps) - (L.pack message) repo + message repo run "update-ref" [Param $ show branch, Param $ show sha] repo return sha where ignorehandle a = snd <$> a - asString a = L.unpack <$> a ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index eedaf66420..3e9375159a 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -7,12 +7,9 @@ module Git.CheckAttr where -import System.Exit - import Common import Git import Git.Command -import qualified Git.Filename import qualified Git.Version {- Efficiently looks up a gitattributes value for each file in a list. -} @@ -20,13 +17,9 @@ lookup :: String -> [FilePath] -> Repo -> IO [(FilePath, String)] lookup attr files repo = do cwd <- getCurrentDirectory (_, fromh, toh) <- hPipeBoth "git" (toCommand params) - _ <- forkProcess $ do - hClose fromh - hPutStr toh $ join "\0" $ input cwd - hClose toh - exitSuccess - hClose toh - output cwd . lines <$> hGetContents fromh + hPutStr toh $ join "\0" $ input cwd + hClose toh + zip files . map attrvalue . lines <$> hGetContents fromh where params = gitCommandLine [ Param "check-attr" @@ -45,22 +38,7 @@ lookup attr files repo = do input cwd | oldgit = map (absPathFrom cwd) files | otherwise = map (relPathDirToFile cwd . absPathFrom cwd) files - output cwd - | oldgit = map (torel cwd . topair) - | otherwise = map topair - - topair l = (Git.Filename.decode file, value) - where - file = join sep $ beginning bits - value = end bits !! 0 + attrvalue l = end bits !! 0 + where bits = split sep l sep = ": " ++ attr ++ ": " - - torel cwd (file, value) = (relfile, value) - where - relfile - | startswith cwd' file = drop (length cwd') file - | otherwise = relPathDirToFile top' file - top = workTree repo - cwd' = cwd ++ "/" - top' = top ++ "/" diff --git a/Git/Command.hs b/Git/Command.hs index 1650efe13c..3d859ed28d 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -8,9 +8,7 @@ module Git.Command where import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Encoding as L import qualified Data.Text.Lazy.IO as L -import qualified Data.ByteString.Lazy as B import Common import Git @@ -41,10 +39,11 @@ run subcommand params repo = assertLocal repo $ - Note that this leaves the git process running, and so zombies will - result unless reap is called. -} -pipeRead :: [CommandParam] -> Repo -> IO L.Text +pipeRead :: [CommandParam] -> Repo -> IO String pipeRead params repo = assertLocal repo $ do (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo - L.decodeUtf8 <$> B.hGetContents h + fileEncoding h + hGetContents h {- Runs a git subcommand, feeding it input. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} @@ -57,26 +56,23 @@ pipeWrite params s repo = assertLocal repo $ do {- Runs a git subcommand, feeding it input, and returning its output. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWriteRead :: [CommandParam] -> L.Text -> Repo -> IO (PipeHandle, L.Text) +pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String) pipeWriteRead params s repo = assertLocal repo $ do (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) - hSetBinaryMode from True - L.hPutStr to s + fileEncoding to + fileEncoding from + hPutStr to s hClose to - c <- L.hGetContents from + c <- hGetContents from return (p, c) {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} pipeNullSplit :: [CommandParam] -> Repo -> IO [String] -pipeNullSplit params repo = map L.unpack <$> pipeNullSplitT params repo - -{- For when Strings are not needed. -} -pipeNullSplitT ::[CommandParam] -> Repo -> IO [L.Text] -pipeNullSplitT params repo = filter (not . L.null) . L.splitOn sep <$> - pipeRead params repo +pipeNullSplit params repo = + filter (not . null) . split sep <$> pipeRead params repo where - sep = L.pack "\0" + sep = "\0" {- Reaps any zombie git processes. -} reap :: IO () diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 5c1541819a..8f9066f0f3 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -14,7 +14,6 @@ module Git.LsTree ( import Numeric import Control.Applicative import System.Posix.Types -import qualified Data.Text.Lazy as L import Common import Git @@ -31,22 +30,22 @@ data TreeItem = TreeItem {- Lists the contents of a Ref -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree <$> - pipeNullSplitT [Params "ls-tree --full-tree -z -r --", File $ show t] repo + pipeNullSplit [Params "ls-tree --full-tree -z -r --", File $ show t] repo {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} -parseLsTree :: L.Text -> TreeItem +parseLsTree :: String -> TreeItem parseLsTree l = TreeItem - { mode = fst $ Prelude.head $ readOct $ L.unpack m - , typeobj = L.unpack t - , sha = L.unpack s - , file = Git.Filename.decode $ L.unpack f + { mode = fst $ Prelude.head $ readOct m + , typeobj = t + , sha = s + , file = Git.Filename.decode f } where -- l = SP SP TAB -- All fields are fixed, so we can pull them out of -- specific positions in the line. - (m, past_m) = L.splitAt 7 l - (t, past_t) = L.splitAt 4 past_m - (s, past_s) = L.splitAt 40 $ L.tail past_t - f = L.tail past_s + (m, past_m) = splitAt 7 l + (t, past_t) = splitAt 4 past_m + (s, past_s) = splitAt 40 $ Prelude.tail past_t + f = Prelude.tail past_s diff --git a/Git/Queue.hs b/Git/Queue.hs index 63c3adee7c..c71605ad52 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -18,7 +18,6 @@ import qualified Data.Map as M import System.IO import System.Cmd.Utils import Data.String.Utils -import Codec.Binary.UTF8.String import Utility.SafeCommand import Common @@ -91,4 +90,6 @@ runAction repo action files = where params = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo - feedxargs h = hPutStr h $ join "\0" $ map encodeString files + feedxargs h = do + fileEncoding h + hPutStr h $ join "\0" files diff --git a/Git/Ref.hs b/Git/Ref.hs index 81560b0157..f483aede03 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -7,8 +7,6 @@ module Git.Ref where -import qualified Data.Text.Lazy as L - import Common import Git import Git.Command @@ -40,7 +38,7 @@ exists ref = runBool "show-ref" {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) -sha branch repo = process . L.unpack <$> showref repo +sha branch repo = process <$> showref repo where showref = pipeRead [Param "show-ref", Param "--hash", -- get the hash @@ -52,7 +50,7 @@ sha branch repo = process . L.unpack <$> showref repo matching :: Ref -> Repo -> IO [(Ref, Branch)] matching ref repo = do r <- pipeRead [Param "show-ref", Param $ show ref] repo - return $ map (gen . L.unpack) (L.lines r) + return $ map gen (lines r) where gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b) diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 19db328609..15bff60527 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -107,21 +107,22 @@ mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String) mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha - shas -> use =<< either return (hashObject repo . L.unlines) =<< + shas -> use =<< either return (hashObject repo . unlines) =<< calcMerge . zip shas <$> mapM getcontents shas where [_colonmode, _bmode, asha, bsha, _status] = words info - getcontents s = L.lines . L.decodeUtf8 <$> catObject h s + getcontents s = map L.unpack . L.lines . + L.decodeUtf8 <$> catObject h s use sha = return $ Just $ update_index_line sha file {- Injects some content into git, returning its Sha. -} -hashObject :: Repo -> L.Text -> IO Sha +hashObject :: Repo -> String -> IO Sha hashObject repo content = getSha subcmd $ do (h, s) <- pipeWriteRead (map Param params) content repo - L.length s `seq` do + length s `seq` do forceSuccess h reap -- XXX unsure why this is needed - return $ L.unpack s + return s where subcmd = "hash-object" params = [subcmd, "-w", "--stdin"] @@ -131,7 +132,7 @@ hashObject repo content = getSha subcmd $ do - When possible, reuses the content of an existing ref, rather than - generating new content. -} -calcMerge :: [(Ref, [L.Text])] -> Either Ref [L.Text] +calcMerge :: [(Ref, [String])] -> Either Ref [String] calcMerge shacontents | null reuseable = Right $ new | otherwise = Left $ fst $ Prelude.head reuseable diff --git a/Messages.hs b/Messages.hs index ff5287d80c..a0bd20ca3c 100644 --- a/Messages.hs +++ b/Messages.hs @@ -119,16 +119,13 @@ showHeader h = handle q $ showRaw :: String -> Annex () showRaw s = handle q $ putStrLn s -{- This check is done because the code assumes filenames are utf8 encoded, - - using decodeUtf8 and Codec.Binary.UTF8.String.encodeString. So if - - run in a non unicode locale, it will crash or worse, possibly operate - - on the wrong file. +{- This avoids ghc's output layer crashing on invalid encoded characters in + - files when printing them out. -} setupConsole :: IO () -setupConsole - | show localeEncoding == show utf8 = return () - | otherwise = error $ - "Sorry, only UTF-8 locales are currently supported." +setupConsole = do + fileEncoding stdout + fileEncoding stderr handle :: IO () -> IO () -> Annex () handle json normal = Annex.getState Annex.output >>= go diff --git a/Utility/Misc.hs b/Utility/Misc.hs index c9bfcb953a..c4992e1428 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -11,6 +11,14 @@ import System.IO import System.IO.Error (try) import Control.Monad import Control.Applicative +import GHC.IO.Encoding + +{- Sets a Handle to use the filesystem encoding. This causes data + - written or read from it to be encoded/decoded the same + - as ghc 7.4 does to filenames et. This special encoding + - allows "arbitrary undecodable bytes to be round-tripped through it". -} +fileEncoding :: Handle -> IO () +fileEncoding h = hSetEncoding h =<< getFileSystemEncoding {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -}