diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +git-repair (1.20141026) unstable; urgency=medium + + * Prevent auto gc from happening when fetching from a remote. + * Merge from git-annex. + + -- Joey Hess Sun, 26 Oct 2014 13:37:30 -0400 + git-repair (1.20140914) unstable; urgency=medium * Update to build with optparse-applicative 0.10. Closes: #761552 diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -6,16 +6,15 @@ import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO) -import Control.Exception.Extensible as X (IOException) 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 System.FilePath as X import System.Directory as X import System.IO as X hiding (FilePath) -import System.PosixCompat.Files as X #ifndef mingw32_HOST_OS import System.Posix.IO as X #endif @@ -31,5 +30,6 @@ import Utility.Data as X import Utility.Applicative as X import Utility.FileSystemEncoding as X +import Utility.PosixFiles as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -94,7 +94,7 @@ catTree h treeref = go <$> catObjectDetails h treeref where go (Just (b, _, TreeObject)) = parsetree [] b - go _ = [] + go _ = [] parsetree c b = case L.break (== 0) b of (modefile, rest) diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -79,7 +79,7 @@ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do + adjusthandle h = do fileEncoding h hSetNewlineMode h noNewlineTranslation @@ -117,7 +117,7 @@ (toCommand $ gitCommandLine params repo) (gitEnv repo) where - {- If a long-running git command like cat-file --batch + {- If a long-running git command like cat-file --batch - crashes, it will likely start up again ok. If it keeps crashing - 10 times, something is badly wrong. -} numrestarts = if restartable then 10 else 0 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,7 +9,6 @@ import qualified Data.Map as M import Data.Char -import Control.Exception.Extensible import Common import Git @@ -168,7 +167,7 @@ fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h + fileEncoding h val <- hGetContentsStrict h r' <- store val r return (r', val) diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -5,17 +5,13 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Git.CurrentRepo where import Common import Git.Types import Git.Construct import qualified Git.Config -#ifndef mingw32_HOST_OS import Utility.Env -#endif {- Gets the current git repository. - @@ -42,17 +38,13 @@ setCurrentDirectory d return $ addworktree wt r where -#ifndef mingw32_HOST_OS pathenv s = do v <- getEnv s case v of Just d -> do - void $ unsetEnv s + unsetEnv s Just <$> absPath d Nothing -> return Nothing -#else - pathenv _ = return Nothing -#endif configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -138,7 +138,7 @@ moveFile fb fa moveFile tmp fa where - -- A broken .git/config is not recoverable. + -- A broken .git/config is not recoverable. -- Don't damage hook scripts, to avoid running arbitrary code. ;) skipped f = or [ takeFileName f == "config" diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -21,8 +21,8 @@ override :: FilePath -> IO (IO ()) override index = do res <- getEnv var - void $ setEnv var index True - return $ void $ reset res + setEnv var index True + return $ reset res where var = "GIT_INDEX_FILE" reset (Just v) = setEnv var v True diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -44,7 +44,7 @@ lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo where - ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs + ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -33,3 +33,17 @@ looseObjectFile r sha = objectsDir r prefix rest where (prefix, rest) = splitAt 2 (fromRef sha) + +listAlternates :: Repo -> IO [FilePath] +listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) + where + alternatesfile = objectsDir r "info" "alternates" + +{- A repository recently cloned with --shared will have one or more + - alternates listed, and contain no loose objects or packs. -} +isSharedClone :: Repo -> IO Bool +isSharedClone r = allM id + [ not . null <$> listAlternates r + , null <$> listLooseObjectShas r + , null <$> listPackFiles r + ] diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -70,7 +70,7 @@ parseRemoteLocation :: String -> Repo -> RemoteLocation parseRemoteLocation s repo = ret $ calcloc s where - ret v + ret v #ifdef mingw32_HOST_OS | dosstyle v = RemotePath (dospath v) #endif @@ -102,7 +102,13 @@ && not ("::" `isInfixOf` v) scptourl v = "ssh://" ++ host ++ slash dir where - (host, dir) = separate (== ':') v + (host, dir) + -- handle ipv6 address inside [] + | "[" `isPrefixOf` v = case break (== ']') v of + (h, ']':':':d) -> (h ++ "]", d) + (h, ']':d) -> (h ++ "]", d) + (h, d) -> (h, d) + | otherwise = separate (== ':') v slash d | d == "" = "/~/" ++ d | "/" `isPrefixOf` d = d | "~" `isPrefixOf` d = '/':d diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -135,11 +135,16 @@ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) , pullremotes tmpr rmts fetchrefs ms ) - fetchfrom fetchurl ps = runBool $ - [ Param "fetch" - , Param fetchurl - , Params "--force --update-head-ok --quiet" - ] ++ ps + fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + where + ps' = + [ Param "fetch" + , Param fetchurl + , Params "--force --update-head-ok --quiet" + ] ++ ps + fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } + nogc = [ Param "-c", Param "gc.auto=0" ] + -- fetch refs and tags fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"] -- Fetch all available refs (more likely to fail, @@ -222,7 +227,7 @@ getAllRefs :: Repo -> IO [Ref] getAllRefs r = map toref <$> dirContentsRecursive refdir where - refdir = localGitDir r "refs" + refdir = localGitDir r "refs" toref = Ref . relPathDirToFile (localGitDir r) explodePackedRefsFile :: Repo -> IO () @@ -411,7 +416,7 @@ putStrLn header putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems where - numitems = length items + numitems = length items truncateditems | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] | otherwise = items diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -29,8 +29,6 @@ import Git.FilePath import Git.Sha -import Control.Exception (bracket) - {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -21,7 +21,7 @@ installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"] where - extract s = case lines s of + extract s = case lines s of [] -> "" (l:_) -> unwords $ drop 2 $ words l diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -32,7 +32,7 @@ #if defined(linux_HOST_OS) || defined(__ANDROID__) batch a = wait =<< batchthread where - batchthread = asyncBound $ do + batchthread = asyncBound $ do setProcessPriority 0 maxNice a #else diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -65,7 +65,7 @@ restartable s (receive $ coProcessFrom s) return where - restartable s a cont + restartable s a cont | coProcessNumRestarts (coProcessSpec s) > 0 = maybe restart cont =<< catchMaybeIO a | otherwise = cont =<< a @@ -87,7 +87,7 @@ raw $ coProcessTo s return ch where - raw h = do + raw h = do fileEncoding h #ifdef mingw32_HOST_OS hSetNewlineMode h noNewlineTranslation diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -11,7 +11,6 @@ import System.IO.Error import System.Directory -import Control.Exception (throw, bracket) import Control.Monad import Control.Monad.IfElse import System.FilePath @@ -57,7 +56,7 @@ dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] where - go [] = return [] + go [] = return [] go (dir:dirs) | skipdir (takeFileName dir) = go dirs | otherwise = unsafeInterleaveIO $ do @@ -88,7 +87,7 @@ dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] where - go c [] = return c + go c [] = return c go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do @@ -114,7 +113,7 @@ whenM (isdir dest) rethrow viaTmp mv dest undefined where - rethrow = throw e + rethrow = throwM e mv tmp _ = do ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] unless ok $ do diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -14,6 +14,7 @@ import Control.Applicative import Data.Maybe import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +40,27 @@ getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - There is, apparently, no way to do this in Windows. Instead, - - environment varuables must be provided when running a new process. -} -setEnv :: String -> String -> Bool -> IO Bool + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess + - Copyright 2011-2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, +) where -import Control.Exception -import qualified Control.Exception as E -import Control.Applicative +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data {- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool +catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = do + catchDefaultIO Nothing $ do + v <- a + return (Just v) {- Catches IO errors and returns a default value. -} -catchDefaultIO :: a -> IO a -> IO a +catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def) {- Catches IO errors and returns the error message. -} -catchMsgIO :: IO a -> IO (Either String a) -catchMsgIO a = either (Left . show) Right <$> tryIO a +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v {- catch specialized for IO errors only -} -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = E.catch +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch {- try specialized for IO errors only -} -tryIO :: IO a -> IO (Either IOException a) -tryIO = try +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) + {- Catches all exceptions except for async exceptions. - This is often better to use than catching them all, so that - ThreadKilled and UserInterrupt get through. -} -catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` - [ Handler (\ (e :: AsyncException) -> throw e) - , Handler (\ (e :: SomeException) -> onerr e) + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) ] -tryNonAsync :: IO a -> IO (Either SomeException a) -tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) {- Catches only DoesNotExist exceptions, and lets all others through. -} -tryWhenExists :: IO a -> IO (Maybe a) -tryWhenExists a = eitherToMaybe <$> - tryJust (guard . isDoesNotExistError) a +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -11,7 +11,6 @@ import System.IO import Control.Monad -import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -111,7 +111,7 @@ #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/Utility/Format.hs b/Utility/Format.hs --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -117,7 +117,7 @@ handle (x:'x':n1:n2:rest) | isescape x && allhex = (fromhex, rest) where - allhex = isHexDigit n1 && isHexDigit n2 + allhex = isHexDigit n1 && isHexDigit n2 fromhex = [chr $ readhex [n1, n2]] readhex h = Prelude.read $ "0x" ++ h :: Int handle (x:n1:n2:n3:rest) diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -16,6 +16,7 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types +import Data.Int {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -23,6 +24,9 @@ - far, *not* an incremental amount since the last call. -} type MeterUpdate = (BytesProcessed -> IO ()) +nullMeterUpdate :: MeterUpdate +nullMeterUpdate _ = return () + {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer deriving (Eq, Ord, Show) @@ -31,6 +35,10 @@ toBytesProcessed :: a -> BytesProcessed fromBytesProcessed :: BytesProcessed -> a +instance AsBytesProcessed BytesProcessed where + toBytesProcessed = id + fromBytesProcessed = id + instance AsBytesProcessed Integer where toBytesProcessed i = BytesProcessed i fromBytesProcessed (BytesProcessed i) = i @@ -39,6 +47,10 @@ toBytesProcessed i = BytesProcessed $ toInteger i fromBytesProcessed (BytesProcessed i) = fromInteger i +instance AsBytesProcessed Int64 where + toBytesProcessed i = BytesProcessed $ toInteger i + fromBytesProcessed (BytesProcessed i) = fromInteger i + instance AsBytesProcessed FileOffset where toBytesProcessed sz = BytesProcessed $ toInteger sz fromBytesProcessed (BytesProcessed sz) = fromInteger sz @@ -76,6 +88,13 @@ meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> meteredWrite meterupdate h b + +{- Applies an offset to a MeterUpdate. This can be useful when + - performing a sequence of actions, such as multiple meteredWriteFiles, + - that all update a common meter progressively. Or when resuming. + -} +offsetMeterUpdate :: MeterUpdate -> BytesProcessed -> MeterUpdate +offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) {- This is like L.hGetContents, but after each chunk is read, a meter - is updated based on the size of the chunk. diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -235,11 +235,11 @@ | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -272,7 +272,7 @@ sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ stdinHandle, stdoutHandle, stderrHandle, + bothHandles, processHandle, devNull, ) where diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -57,7 +57,7 @@ rsyncParamsFixup :: [CommandParam] -> [CommandParam] rsyncParamsFixup = map fixup where - fixup (File f) = File (toCygPath f) + fixup (File f) = File (toCygPath f) fixup p = p {- Runs rsync, but intercepts its progress output and updates a meter. @@ -66,14 +66,8 @@ - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress meterupdate params = do - r <- catchBoolIO $ - withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) - {- For an unknown reason, piping rsync's output like this does - - causes it to run a second ssh process, which it neglects to wait - - on. Reap the resulting zombie. -} - reapZombies - return r +rsyncProgress meterupdate params = catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) where p = proc "rsync" (toCommand $ rsyncParamsFixup params) feedprogress prev buf h = do diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -9,11 +9,11 @@ module Utility.Tmp where -import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import System.FilePath +import Control.Monad.IO.Class import Utility.Exception import Utility.FileSystemEncoding @@ -32,31 +32,31 @@ setup = do createDirectoryIfMissing True dir openTempFile dir template - cleanup (tmpfile, handle) = do - _ <- tryIO $ hClose handle + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h tryIO $ removeFile tmpfile - use (tmpfile, handle) = do - hClose handle + use (tmpfile, h) = do + hClose h a tmpfile content rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. -} -withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = openTempFile tmpdir template - remove (name, handle) = do - hClose handle + create = liftIO $ openTempFile tmpdir template + remove (name, h) = liftIO $ do + hClose h catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle + use (name, h) = a name h {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +git-repair (1.20141026) unstable; urgency=medium + + * Prevent auto gc from happening when fetching from a remote. + * Merge from git-annex. + + -- Joey Hess Sun, 26 Oct 2014 13:37:30 -0400 + git-repair (1.20140914) unstable; urgency=medium * Update to build with optparse-applicative 0.10. Closes: #761552 diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -8,7 +8,8 @@ libghc-missingh-dev, libghc-hslogger-dev, libghc-network-dev, - libghc-extensible-exceptions-dev, + libghc-exceptions-dev (>= 0.6), + libghc-transformers-dev, libghc-unix-compat-dev, libghc-ifelse-dev, libghc-text-dev, diff --git a/git-repair.cabal b/git-repair.cabal --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20140914 +Version: 1.20141026 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess @@ -26,11 +26,13 @@ Main-Is: git-repair.hs GHC-Options: -Wall -threaded Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, - network, extensible-exceptions, unix-compat, bytestring, + network, 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) - if (! os(windows)) + if (os(windows)) + Build-Depends: setenv + else Build-Depends: unix source-repository head diff --git a/git-repair.hs b/git-repair.hs --- a/git-repair.hs +++ b/git-repair.hs @@ -48,7 +48,7 @@ main :: IO () main = execParser opts >>= go where - opts = info (helper <*> parseSettings) desc + opts = info (helper <*> parseSettings) desc desc = fullDesc <> header "git-repair - repair a damanged git repository" go settings