diff options
| -rw-r--r-- | CHANGELOG | 6 | ||||
| -rw-r--r-- | Common.hs | 6 | ||||
| -rw-r--r-- | Git/CatFile.hs | 1 | ||||
| -rw-r--r-- | Git/Command.hs | 6 | ||||
| -rw-r--r-- | Git/Config.hs | 5 | ||||
| -rw-r--r-- | Git/CurrentRepo.hs | 2 | ||||
| -rw-r--r-- | Git/Repair.hs | 2 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 1 | ||||
| -rw-r--r-- | Utility/CoProcess.hs | 6 | ||||
| -rw-r--r-- | Utility/Exception.hs | 18 | ||||
| -rw-r--r-- | Utility/FileSystemEncoding.hs | 41 | ||||
| -rw-r--r-- | Utility/Metered.hs | 43 | ||||
| -rw-r--r-- | Utility/Misc.hs | 17 | ||||
| -rw-r--r-- | Utility/SystemDirectory.hs | 2 | ||||
| -rw-r--r-- | Utility/URI.hs | 18 | ||||
| -rw-r--r-- | Utility/UserInfo.hs | 3 | ||||
| -rw-r--r-- | git-repair.cabal | 4 | ||||
| -rw-r--r-- | git-repair.hs | 5 |
18 files changed, 93 insertions, 93 deletions
@@ -1,3 +1,9 @@ +git-repair (1.20161119) UNRELEASED; urgency=medium + + * Merge from git-annex. + + -- Joey Hess <id@joeyh.name> Sat, 24 Dec 2016 14:53:47 -0400 + git-repair (1.20161118) unstable; urgency=medium * Fix build with recent versions of cabal and ghc. @@ -5,12 +5,13 @@ module Common (module X) where import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X -import "mtl" Control.Monad.State.Strict as X (liftIO) +import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) import Data.String.Utils as X hiding (join) import Data.Monoid as X +import Data.Default as X import System.FilePath as X import System.IO as X hiding (FilePath) @@ -24,12 +25,11 @@ import Utility.Exception as X import Utility.SafeCommand as X import Utility.Process as X import Utility.Path as X +import Utility.Directory as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.FileSystemEncoding as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X -import Utility.Directory as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 061349f..4935cdf 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -37,6 +37,7 @@ import Git.Command import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess +import Utility.FileSystemEncoding data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Command.hs b/Git/Command.hs index 2060563..adea762 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -53,7 +53,6 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - fileEncoding h c <- hGetContents h return (c, checkSuccessProcess pid) where @@ -66,7 +65,6 @@ pipeReadLazy params repo = assertLocal repo $ do pipeReadStrict :: [CommandParam] -> Repo -> IO String pipeReadStrict params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - fileEncoding h output <- hGetContentsStrict h hClose h return output @@ -81,9 +79,7 @@ pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do - fileEncoding h - hSetNewlineMode h noNewlineTranslation + adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () diff --git a/Git/Config.hs b/Git/Config.hs index 3d62395..65bd9b7 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -79,10 +79,6 @@ global = do {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - -- We use the FileSystemEncoding when reading from git-config, - -- because it can contain arbitrary filepaths (and other strings) - -- in any encoding. - fileEncoding h val <- hGetContentsStrict h store val repo @@ -167,7 +163,6 @@ coreBare = "core.bare" fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h val <- hGetContentsStrict h r' <- store val r return (r', val) diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index dab4ad2..69a679e 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -52,7 +52,7 @@ get = do curr <- getCurrentDirectory Git.Config.read $ newFrom $ Local { gitdir = absd, worktree = Just curr } - configure Nothing Nothing = error "Not in a git repository." + configure Nothing Nothing = giveup "Not in a git repository." addworktree w r = changelocation r $ Local { gitdir = gitdir (location r), worktree = w } diff --git a/Git/Repair.hs b/Git/Repair.hs index fcfc036..1baf51a 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -614,4 +614,4 @@ successfulRepair = fst safeReadFile :: FilePath -> IO String safeReadFile f = do allowRead f - readFileStrictAnyEncoding f + readFileStrict f diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 55c5b3b..7fdc945 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -55,7 +55,6 @@ startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) { std_in = CreatePipe } - fileEncoding h return $ UpdateIndexHandle p h where params = map Param ["update-index", "-z", "--index-info"] diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 94d5ac3..2bae40f 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -47,10 +47,10 @@ start' s = do rawMode to return $ CoProcessState pid to from s where - rawMode h = do - fileEncoding h #ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation + rawMode h = hSetNewlineMode h noNewlineTranslation +#else + rawMode _ = return () #endif stop :: CoProcessHandle -> IO () diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 0ffc710..67c2e85 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess <id@joeyh.name> + - Copyright 2011-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -40,6 +41,21 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,9,0) +giveup = errorWithoutStackTrace +#else +giveup = error +#endif +#else +giveup = error +#endif + {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index eab9833..be43ace 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess <id@joeyh.name> + - Copyright 2012-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( - fileEncoding, + useFileSystemEncoding, withFilePath, md5FilePath, decodeBS, @@ -19,7 +19,6 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -39,19 +38,30 @@ import qualified Data.ByteString.Lazy.UTF8 as L8 import Utility.Exception -{- 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 etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} -fileEncoding :: Handle -> IO () +useFileSystemEncoding :: IO () +useFileSystemEncoding = do #ifndef mingw32_HOST_OS -fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding + e <- Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} -fileEncoding h = hSetEncoding h Encoding.utf8 + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 #endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, @@ -165,10 +175,3 @@ truncateFilePath n = reverse . go [] n . L8.fromString else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif - -{- This avoids ghc's output layer crashing on invalid encoded characters in - - filenames when printing them out. -} -setConsoleEncoding :: IO () -setConsoleEncoding = do - fileEncoding stdout - fileEncoding stderr diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 440aa3f..e21e18c 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,11 +1,11 @@ {- Metered IO and actions - - - Copyright 2012-2106 Joey Hess <id@joeyh.name> + - Copyright 2012-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, BangPatterns #-} module Utility.Metered where @@ -85,12 +85,15 @@ streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () -meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite meterupdate h = void . meteredWrite' meterupdate h + +meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks where - go _ [] = return () + go sofar [] = return sofar go sofar (c:cs) = do S.hPut h c - let sofar' = addBytesProcessed sofar $ S.length c + let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs @@ -112,30 +115,30 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) - meter updates, so use caution. -} hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString -hGetContentsMetered h = hGetUntilMetered h (const True) +hGetContentsMetered h = hGetMetered h Nothing -{- Reads from the Handle, updating the meter after each chunk. +{- Reads from the Handle, updating the meter after each chunk is read. + - + - Stops at EOF, or when the requested number of bytes have been read. + - Closes the Handle at EOF, but otherwise leaves it open. - - Note that the meter update is run in unsafeInterleaveIO, which means that - it can be run at any time. It's even possible for updates to run out - of order, as different parts of the ByteString are consumed. - - - - Stops at EOF, or when keepgoing evaluates to False. - - Closes the Handle at EOF, but otherwise leaves it open. -} -hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString -hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed +hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString +hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed where lazyRead sofar = unsafeInterleaveIO $ loop sofar loop sofar = do - c <- S.hGet h defaultChunkSize + c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do hClose h return $ L.empty else do - let sofar' = addBytesProcessed sofar (S.length c) + let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' if keepgoing (fromBytesProcessed sofar') then do @@ -145,6 +148,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed cs <- lazyRead sofar' return $ L.append (L.fromChunks [c]) cs else return $ L.fromChunks [c] + + keepgoing n = case wantsize of + Nothing -> True + Just sz -> n < sz + + nextchunksize n = case wantsize of + Nothing -> defaultChunkSize + Just sz -> + let togo = sz - n + in if togo < toInteger defaultChunkSize + then fromIntegral togo + else defaultChunkSize {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int diff --git a/Utility/Misc.hs b/Utility/Misc.hs index ebb4257..4498c0a 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -10,9 +10,6 @@ module Utility.Misc where -import Utility.FileSystemEncoding -import Utility.Monad - import System.IO import Control.Monad import Foreign @@ -35,20 +32,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content - {- Like break, but the item matching the condition is not included - in the second result list. - diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs index 3dd44d1..b9040fe 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module Utility.SystemDirectory ( module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/Utility/URI.hs b/Utility/URI.hs deleted file mode 100644 index e68fda5..0000000 --- a/Utility/URI.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- Network.URI - - - - Copyright 2014 Joey Hess <id@joeyh.name> - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} - -module Utility.URI where - --- Old versions of network lacked an Ord for URI -#if ! MIN_VERSION_network(2,4,0) -import Network.URI - -instance Ord URI where - a `compare` b = show a `compare` show b -#endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index ec0b0d0..dd66c33 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -16,6 +16,7 @@ module Utility.UserInfo ( import Utility.Env import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -25,7 +26,7 @@ import Prelude - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = either error return =<< myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] diff --git a/git-repair.cabal b/git-repair.cabal index ccac779..7949439 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -44,7 +44,8 @@ Executable git-repair Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, unix-compat, bytestring, exceptions (>= 0.6), transformers, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, - utf8-string, async, optparse-applicative (>= 0.10.0) + utf8-string, async, optparse-applicative (>= 0.10.0), + data-default if flag(network-uri) Build-Depends: network-uri (>= 2.6), network (>= 2.6) @@ -113,5 +114,4 @@ Executable git-repair Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp - Utility.URI Utility.UserInfo diff --git a/git-repair.hs b/git-repair.hs index a82d5d6..4076c15 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -15,6 +15,7 @@ import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck import Utility.Tmp +import Utility.FileSystemEncoding data Settings = Settings { forced :: Bool @@ -46,7 +47,9 @@ parseSettings = Settings ) main :: IO () -main = execParser opts >>= go +main = do + useFileSystemEncoding + execParser opts >>= go where opts = info (helper <*> parseSettings) desc desc = fullDesc |