summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joey@kitenet.net>2014-07-21 16:35:23 -0400
committerJoey Hess <joey@kitenet.net>2014-07-21 16:35:23 -0400
commit619c8bd261a4fee0b0d40b664e55c51782e062f7 (patch)
treeba39cd283d4c0fecb61c7a1bbbb803cc9459a222
parent7882653e7856df87e598464379951ec89775cd1a (diff)
downloadgit-repair-619c8bd261a4fee0b0d40b664e55c51782e062f7.tar.gz
Merge from git-annex.
-rw-r--r--Git/Branch.hs64
-rw-r--r--Git/Command.hs9
-rw-r--r--Git/Config.hs1
-rw-r--r--Git/CurrentRepo.hs8
-rw-r--r--Git/Fsck.hs1
-rw-r--r--Git/Index.hs4
-rw-r--r--Git/LsFiles.hs4
-rw-r--r--Git/UpdateIndex.hs1
-rw-r--r--Utility/Applicative.hs2
-rw-r--r--Utility/Batch.hs3
-rw-r--r--Utility/CoProcess.hs8
-rw-r--r--Utility/Data.hs2
-rw-r--r--Utility/Directory.hs103
-rw-r--r--Utility/Env.hs2
-rw-r--r--Utility/Exception.hs4
-rw-r--r--Utility/FileMode.hs2
-rw-r--r--Utility/FileSystemEncoding.hs2
-rw-r--r--Utility/Format.hs2
-rw-r--r--Utility/Metered.hs2
-rw-r--r--Utility/Misc.hs2
-rw-r--r--Utility/Monad.hs2
-rw-r--r--Utility/Path.hs2
-rw-r--r--Utility/PosixFiles.hs2
-rw-r--r--Utility/Process.hs39
-rw-r--r--Utility/QuickCheck.hs2
-rw-r--r--Utility/Rsync.hs2
-rw-r--r--Utility/SafeCommand.hs3
-rw-r--r--Utility/ThreadScheduler.hs5
-rw-r--r--Utility/Tmp.hs23
-rw-r--r--Utility/URI.hs2
-rw-r--r--Utility/UserInfo.hs2
-rw-r--r--debian/changelog6
32 files changed, 222 insertions, 94 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs
index d182ceb..0b7d888 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -14,6 +14,7 @@ import Git
import Git.Sha
import Git.Command
import qualified Git.Ref
+import qualified Git.BuildVersion
{- The currently checked out branch.
-
@@ -52,7 +53,22 @@ changed origbranch newbranch repo
diffs = pipeReadStrict
[ Param "log"
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
- , Params "--oneline -n1"
+ , Param "-n1"
+ , Param "--pretty=%H"
+ ] repo
+
+{- Check if it's possible to fast-forward from the old
+ - ref to the new ref.
+ -
+ - This requires there to be a path from the old to the new. -}
+fastForwardable :: Ref -> Ref -> Repo -> IO Bool
+fastForwardable old new repo = not . null <$>
+ pipeReadStrict
+ [ Param "log"
+ , Param $ fromRef old ++ ".." ++ fromRef new
+ , Param "-n1"
+ , Param "--pretty=%H"
+ , Param "--ancestry-path"
] repo
{- Given a set of refs that are all known to have commits not
@@ -74,7 +90,7 @@ fastForward branch (first:rest) repo =
where
no_ff = return False
do_ff to = do
- run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
+ update branch to repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@@ -88,6 +104,31 @@ fastForward branch (first:rest) repo =
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
+{- The user may have set commit.gpgsign, indending all their manual
+ - commits to be signed. But signing automatic/background commits could
+ - easily lead to unwanted gpg prompts or failures.
+ -}
+data CommitMode = ManualCommit | AutomaticCommit
+ deriving (Eq)
+
+applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
+applyCommitMode commitmode ps
+ | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =
+ Param "--no-gpg-sign" : ps
+ | otherwise = ps
+
+{- Commit via the usual git command. -}
+commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand = commitCommand' runBool
+
+{- Commit will fail when the tree is clean. This suppresses that error. -}
+commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()
+commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps
+
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode ps = runner $
+ Param "commit" : applyCommitMode commitmode ps
+
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha.
-
@@ -97,30 +138,31 @@ fastForward branch (first:rest) repo =
- Unlike git-commit, does not run any hooks, or examine the work tree
- in any way.
-}
-commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
-commit allowempty message branch parentrefs repo = do
+commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
+commit commitmode allowempty message branch parentrefs repo = do
tree <- getSha "write-tree" $
pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree)
( do
- sha <- getSha "commit-tree" $ pipeWriteRead
- (map Param $ ["commit-tree", fromRef tree] ++ ps)
- (Just $ flip hPutStr message) repo
+ sha <- getSha "commit-tree" $
+ pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
update branch sha repo
return $ Just sha
, return Nothing
)
where
- ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
+ ps = applyCommitMode commitmode $
+ map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree
| allowempty = return True
| otherwise = case parentrefs of
[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
_ -> return True
+ sendmsg = Just $ flip hPutStr message
-commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha
-commitAlways message branch parentrefs repo = fromJust
- <$> commit True message branch parentrefs repo
+commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways commitmode message branch parentrefs repo = fromJust
+ <$> commit commitmode True message branch parentrefs repo
{- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String
diff --git a/Git/Command.hs b/Git/Command.hs
index a0c7c4b..30d2dcb 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -9,13 +9,10 @@
module Git.Command where
-import System.Process (std_out, env)
-
import Common
import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess
-import Utility.Batch
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
@@ -33,12 +30,6 @@ runBool :: [CommandParam] -> Repo -> IO Bool
runBool params repo = assertLocal repo $
boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)
-{- Runs git in batch mode. -}
-runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool
-runBatch batchmaker params repo = assertLocal repo $ do
- let (cmd, params') = batchmaker ("git", gitCommandLine params repo)
- boolSystemEnv cmd params' (gitEnv repo)
-
{- Runs git in the specified repo, throwing an error if it fails. -}
run :: [CommandParam] -> Repo -> IO ()
run params repo = assertLocal repo $
diff --git a/Git/Config.hs b/Git/Config.hs
index b5c1be0..d998fd1 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 System.Process (cwd, env)
import Control.Exception.Extensible
import Common
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index ee91a6b..23ebbbc 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -37,8 +37,8 @@ get = do
case wt of
Nothing -> return r
Just d -> do
- cwd <- getCurrentDirectory
- unless (d `dirContains` cwd) $
+ curr <- getCurrentDirectory
+ unless (d `dirContains` curr) $
setCurrentDirectory d
return $ addworktree wt r
where
@@ -57,8 +57,8 @@ get = do
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
- cwd <- getCurrentDirectory
- r <- newFrom $ Local { gitdir = absd, worktree = Just cwd }
+ curr <- getCurrentDirectory
+ r <- newFrom $ Local { gitdir = absd, worktree = Just curr }
Git.Config.read r
configure Nothing Nothing = error "Not in a git repository."
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 80f76dd..c6002f6 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -23,7 +23,6 @@ import Utility.Batch
import qualified Git.Version
import qualified Data.Set as S
-import System.Process (std_out, std_err)
import Control.Concurrent.Async
type MissingObjects = S.Set Sha
diff --git a/Git/Index.hs b/Git/Index.hs
index d9d5b03..d712245 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -30,3 +30,7 @@ override index = do
indexFile :: Repo -> FilePath
indexFile r = localGitDir r </> "index"
+
+{- Git locks the index by creating this file. -}
+indexFileLock :: Repo -> FilePath
+indexFileLock r = indexFile r ++ ".lock"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index e155845..2aa05ba 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -132,8 +132,8 @@ typeChanged' ps l repo = do
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
let top = repoPath repo
- cwd <- getCurrentDirectory
- return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
+ currdir <- getCurrentDirectory
+ return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
where
prefix = [Params "diff --name-only --diff-filter=T -z"]
suffix = Param "--" : (if null l then [File "."] else map File l)
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 4ecd773..7de2f1b 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -30,7 +30,6 @@ import Git.FilePath
import Git.Sha
import Control.Exception (bracket)
-import System.Process (std_in)
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
index 64400c8..fd8944b 100644
--- a/Utility/Applicative.hs
+++ b/Utility/Applicative.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.Applicative where
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index 3f21478..d6dadae 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
@@ -16,7 +16,6 @@ import Control.Concurrent.Async
import System.Posix.Process
#endif
import qualified Control.Exception as E
-import System.Process (env)
{- Runs an operation, at batch priority.
-
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index c113401..332c09d 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -3,7 +3,7 @@
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
@@ -37,8 +37,8 @@ data CoProcessSpec = CoProcessSpec
}
start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
-start numrestarts cmd params env = do
- s <- start' $ CoProcessSpec numrestarts cmd params env
+start numrestarts cmd params environ = do
+ s <- start' $ CoProcessSpec numrestarts cmd params environ
newMVar s
start' :: CoProcessSpec -> IO CoProcessState
@@ -62,7 +62,7 @@ query ch send receive = do
s <- readMVar ch
restartable s (send $ coProcessTo s) $ const $
restartable s (hFlush $ coProcessTo s) $ const $
- restartable s (receive $ coProcessFrom s) $
+ restartable s (receive $ coProcessFrom s)
return
where
restartable s a cont
diff --git a/Utility/Data.hs b/Utility/Data.hs
index 3592582..2df12b3 100644
--- a/Utility/Data.hs
+++ b/Utility/Data.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.Data where
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index f1bcfad..ade5ef8 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,8 +1,8 @@
-{- directory manipulation
+{- directory traversal and manipulation
-
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
@@ -11,12 +11,20 @@ module Utility.Directory where
import System.IO.Error
import System.Directory
-import Control.Exception (throw)
+import Control.Exception (throw, bracket)
import Control.Monad
import Control.Monad.IfElse
import System.FilePath
import Control.Applicative
+import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.Maybe
+
+#ifdef mingw32_HOST_OS
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
import Utility.PosixFiles
import Utility.SafeCommand
@@ -43,7 +51,7 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
- When the directory does not exist, no exception is thrown,
- instead, [] is returned. -}
dirContentsRecursive :: FilePath -> IO [FilePath]
-dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir
+dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
@@ -133,3 +141,90 @@ nukeFile file = void $ tryWhenExists go
#else
go = removeFile file
#endif
+
+#ifndef mingw32_HOST_OS
+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
+#else
+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
+#endif
+
+type IsOpen = MVar () -- full when the handle is open
+
+openDirectory :: FilePath -> IO DirectoryHandle
+openDirectory path = do
+#ifndef mingw32_HOST_OS
+ dirp <- Posix.openDirStream path
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen dirp)
+#else
+ (h, fdat) <- Win32.findFirstFile (path </> "*")
+ -- Indicate that the fdat contains a filename that readDirectory
+ -- has not yet returned, by making the MVar be full.
+ -- (There's always at least a "." entry.)
+ alreadyhave <- newMVar ()
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen h fdat alreadyhave)
+#endif
+
+closeDirectory :: DirectoryHandle -> IO ()
+#ifndef mingw32_HOST_OS
+closeDirectory (DirectoryHandle isopen dirp) =
+ whenOpen isopen $
+ Posix.closeDirStream dirp
+#else
+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
+ whenOpen isopen $ do
+ _ <- tryTakeMVar alreadyhave
+ Win32.findClose h
+#endif
+ where
+ whenOpen :: IsOpen -> IO () -> IO ()
+ whenOpen mv f = do
+ v <- tryTakeMVar mv
+ when (isJust v) f
+
+{- |Reads the next entry from the handle. Once the end of the directory
+is reached, returns Nothing and automatically closes the handle.
+-}
+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
+#ifndef mingw32_HOST_OS
+readDirectory hdl@(DirectoryHandle _ dirp) = do
+ e <- Posix.readDirStream dirp
+ if null e
+ then do
+ closeDirectory hdl
+ return Nothing
+ else return (Just e)
+#else
+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
+ -- If the MVar is full, then the filename in fdat has
+ -- not yet been returned. Otherwise, need to find the next
+ -- file.
+ r <- tryTakeMVar mv
+ case r of
+ Just () -> getfn
+ Nothing -> do
+ more <- Win32.findNextFile h fdat
+ if more
+ then getfn
+ else do
+ closeDirectory hdl
+ return Nothing
+ where
+ getfn = do
+ filename <- Win32.getFindDataFileName fdat
+ return (Just filename)
+#endif
+
+-- True only when directory exists and contains nothing.
+-- Throws exception if directory does not exist.
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
+ where
+ check h = do
+ v <- readDirectory h
+ case v of
+ Nothing -> return True
+ Just f
+ | not (dirCruft f) -> return False
+ | otherwise -> check h
diff --git a/Utility/Env.hs b/Utility/Env.hs
index 90ed58f..6763c24 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index cf2c615..1fecf65 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -2,7 +2,7 @@
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -18,7 +18,7 @@ import Utility.Data
{- Catches IO errors and returns a Bool -}
catchBoolIO :: IO Bool -> IO Bool
-catchBoolIO a = catchDefaultIO False a
+catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: IO a -> IO (Maybe a)
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 9c15da8..c2ef683 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index 690942c..b81fdc5 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/Format.hs b/Utility/Format.hs
index e7a2751..2a5ae5c 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.Format (
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 7ad9b12..0d94c1c 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE TypeSynonymInstances #-}
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 9c19df8..949f41e 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index 1ba43c5..eba3c42 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.Monad where
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 570350d..99c9438 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE PackageImports, CPP #-}
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
index 23edc25..5abbb57 100644
--- a/Utility/PosixFiles.hs
+++ b/Utility/PosixFiles.hs
@@ -4,7 +4,7 @@
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 3f93dc2..1f722af 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -3,14 +3,14 @@
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP, Rank2Types #-}
module Utility.Process (
module X,
- CreateProcess,
+ CreateProcess(..),
StdHandle(..),
readProcess,
readProcessEnv,
@@ -167,10 +167,10 @@ processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts input = processTranscript' cmd opts Nothing input
processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
+processTranscript' cmd opts environ input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
- the process writes them. -}
-processTranscript' cmd opts environ input = do
(readf, writef) <- createPipe
readh <- fdToHandle readf
writeh <- fdToHandle writef
@@ -184,24 +184,13 @@ processTranscript' cmd opts environ input = do
hClose writeh
get <- mkreader readh
-
- -- now write and flush any input
- case input of
- Just s -> do
- let inh = stdinHandle p
- unless (null s) $ do
- hPutStr inh s
- hFlush inh
- hClose inh
- Nothing -> return ()
-
+ writeinput input p
transcript <- get
ok <- checkSuccessProcess pid
return (transcript, ok)
#else
{- This implementation for Windows puts stderr after stdout. -}
-processTranscript' cmd opts environ input = do
p@(_, _, _, pid) <- createProcess $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit
@@ -212,17 +201,9 @@ processTranscript' cmd opts environ input = do
getout <- mkreader (stdoutHandle p)
geterr <- mkreader (stderrHandle p)
-
- case input of
- Just s -> do
- let inh = stdinHandle p
- unless (null s) $ do
- hPutStr inh s
- hFlush inh
- hClose inh
- Nothing -> return ()
-
+ writeinput input p
transcript <- (++) <$> getout <*> geterr
+
ok <- checkSuccessProcess pid
return (transcript, ok)
#endif
@@ -237,6 +218,14 @@ processTranscript' cmd opts environ input = do
takeMVar v
return s
+ writeinput (Just s) p = do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ writeinput Nothing _ = return ()
+
{- Runs a CreateProcessRunner, on a CreateProcess structure, that
- is adjusted to pipe only from/to a single StdHandle, and passes
- the resulting Handle to an action. -}
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index 7f7234c..a498ee6 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 82166f6..6038126 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.Rsync where
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index c8318ec..86e60db 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -2,14 +2,13 @@
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
module Utility.SafeCommand where
import System.Exit
import Utility.Process
-import System.Process (env)
import Data.String.Utils
import Control.Applicative
import System.FilePath
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index dd88dc8..e6a81ae 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -3,7 +3,7 @@
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
- Copyright 2011 Bas van Dijk & Roel van Dijk
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
@@ -57,8 +57,7 @@ unboundDelay time = do
waitForTermination :: IO ()
waitForTermination = do
#ifdef mingw32_HOST_OS
- runEvery (Seconds 600) $
- void getLine
+ forever $ threadDelaySeconds (Seconds 6000)
#else
lock <- newEmptyMVar
let check sig = void $
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index f46e1a5..bed30bb 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
@@ -25,13 +25,20 @@ type Template = String
- then moving it into place. The temp file is stored in the same
- directory as the final file to avoid cross-device renames. -}
viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()
-viaTmp a file content = do
- let (dir, base) = splitFileName file
- createDirectoryIfMissing True dir
- (tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
- hClose handle
- a tmpfile content
- rename tmpfile file
+viaTmp a file content = bracket setup cleanup use
+ where
+ (dir, base) = splitFileName file
+ template = base ++ ".tmp"
+ setup = do
+ createDirectoryIfMissing True dir
+ openTempFile dir template
+ cleanup (tmpfile, handle) = do
+ _ <- tryIO $ hClose handle
+ tryIO $ removeFile tmpfile
+ use (tmpfile, handle) = do
+ hClose handle
+ 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. -}
diff --git a/Utility/URI.hs b/Utility/URI.hs
index 39c2f22..30c6be3 100644
--- a/Utility/URI.hs
+++ b/Utility/URI.hs
@@ -2,7 +2,7 @@
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 9c3bfd4..617c3e9 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/debian/changelog b/debian/changelog
index bff8411..5d5f70a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-repair (1.20140424) UNRELEASED; urgency=medium
+
+ * Merge from git-annex.
+
+ -- Joey Hess <joeyh@debian.org> Mon, 21 Jul 2014 16:35:16 -0400
+
git-repair (1.20140423) unstable; urgency=medium
* Improve memory usage when git fsck finds a great many broken objects.