summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Common.hs4
-rw-r--r--Git/CatFile.hs2
-rw-r--r--Git/Command.hs4
-rw-r--r--Git/Config.hs3
-rw-r--r--Git/LsTree.hs2
-rw-r--r--Git/Objects.hs14
-rw-r--r--Git/Remote.hs10
-rw-r--r--Git/Repair.hs19
-rw-r--r--Git/UpdateIndex.hs2
-rw-r--r--Git/Version.hs2
-rw-r--r--Utility/Batch.hs2
-rw-r--r--Utility/CoProcess.hs4
-rw-r--r--Utility/Directory.hs7
-rw-r--r--Utility/Exception.hs75
-rw-r--r--Utility/FileMode.hs1
-rw-r--r--Utility/FileSystemEncoding.hs2
-rw-r--r--Utility/Format.hs2
-rw-r--r--Utility/Metered.hs19
-rw-r--r--Utility/Path.hs8
-rw-r--r--Utility/Process.hs1
-rw-r--r--Utility/Rsync.hs12
-rw-r--r--Utility/Tmp.hs24
-rw-r--r--debian/changelog7
-rw-r--r--debian/control3
-rw-r--r--git-repair.cabal2
25 files changed, 151 insertions, 80 deletions
diff --git a/Common.hs b/Common.hs
index a6203b9..d64b5ad 100644
--- a/Common.hs
+++ b/Common.hs
@@ -6,16 +6,15 @@ 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.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.Monad as X
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
index 8e64fc5..d0bcef4 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -94,7 +94,7 @@ catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
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
index 30d2dcb..c61cc9f 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -79,7 +79,7 @@ pipeWriteRead params writer repo = assertLocal repo $
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 @@ gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
(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
index d998fd1..32c0dd1 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -9,7 +9,6 @@ module Git.Config where
import qualified Data.Map as M
import Data.Char
-import Control.Exception.Extensible
import Common
import Git
@@ -168,7 +167,7 @@ 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
+ fileEncoding h
val <- hGetContentsStrict h
r' <- store val r
return (r', val)
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 6d3ca48..ca5e323 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -44,7 +44,7 @@ lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
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
index 516aa6d..dadd4f5 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -33,3 +33,17 @@ looseObjectFile :: Repo -> Sha -> FilePath
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
index 9d969c4..7e8e5f8 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -70,7 +70,7 @@ remoteLocationIsSshUrl _ = False
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 @@ parseRemoteLocation s repo = ret $ calcloc s
&& 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
index 43f0a56..77a592b 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -135,11 +135,16 @@ retrieveMissingObjects missing referencerepo r
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 @@ badBranches missing r = filterM isbad =<< getAllRefs r
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 @@ displayList items header
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
index 7de2f1b..ecd154a 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -29,8 +29,6 @@ import Git.Command
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
index 5ad1d59..5c61f85 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -21,7 +21,7 @@ instance Show GitVersion where
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
index d6dadae..ff81318 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -32,7 +32,7 @@ batch :: IO a -> IO a
#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
index 332c09d..97826ec 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -65,7 +65,7 @@ query ch send receive = do
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 @@ rawMode ch = do
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
index ade5ef8..e4e4b80 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -11,7 +11,6 @@ module Utility.Directory where
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 @@ dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
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 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
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 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
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/Exception.hs b/Utility/Exception.hs
index 1fecf65..ef3ab1d 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,59 +1,88 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- 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
index c2ef683..832250b 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -11,7 +11,6 @@ module Utility.FileMode where
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
index b81fdc5..fa4b39a 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -111,7 +111,7 @@ truncateFilePath :: Int -> FilePath -> FilePath
#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
index 2a5ae5c..78620f9 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -117,7 +117,7 @@ decode_c s = unescape ("", s)
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
index 0d94c1c..4618aec 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -16,6 +16,7 @@ import qualified Data.ByteString as S
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 @@ import System.Posix.Types
- 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 @@ class AsBytesProcessed a where
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 @@ instance AsBytesProcessed Int where
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
@@ -77,6 +89,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
index 99c9438..9035cbc 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -235,11 +235,11 @@ toCygPath p
| 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 @@ fileNameLengthLimit dir = do
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
index 1f722af..e25618e 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -31,6 +31,7 @@ module Utility.Process (
stdinHandle,
stdoutHandle,
stderrHandle,
+ bothHandles,
processHandle,
devNull,
) where
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 6038126..8dee609 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -57,7 +57,7 @@ rsync = boolSystem "rsync" . rsyncParamsFixup
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 @@ rsyncParamsFixup = map fixup
- 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
index bed30bb..edd82f5 100644
--- 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 @@ viaTmp a file content = bracket setup cleanup use
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
index f5b71bd..7364372 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+git-repair (1.20140915) UNRELEASED; urgency=medium
+
+ * Prevent auto gc from happening when fetching from a remote.
+ * Merge from git-annex.
+
+ -- Joey Hess <joeyh@debian.org> Sun, 12 Oct 2014 14:31:33 -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
index 37d0e80..42363e2 100644
--- a/debian/control
+++ b/debian/control
@@ -8,7 +8,8 @@ Build-Depends:
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
index a506527..e9befd7 100644
--- a/git-repair.cabal
+++ b/git-repair.cabal
@@ -26,7 +26,7 @@ Executable git-repair
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)