summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRichard Hartmann <richih@debian.org>2015-12-15 23:26:04 -0700
committerRichard Hartmann <richih@debian.org>2015-12-15 23:26:04 -0700
commitd348ed3d2822a8cd4b777f74641baf040e7839e4 (patch)
tree5d46d93d0b237a213f72e1e7ada60a5fecaf2e75
parentad444893f97ed69c4a5f070cb00a6e6cb89bb2cd (diff)
parent3b6310081cde4333494fb1271a7570fc8e5f333a (diff)
downloadgit-repair-d348ed3d2822a8cd4b777f74641baf040e7839e4.tar.gz
Record git-repair (1.20151215-1) in archive suite sid
-rwxr-xr-xBuild/collect-ghc-options.sh12
-rw-r--r--Common.hs5
-rw-r--r--Git.hs36
-rw-r--r--Git/Branch.hs4
-rw-r--r--Git/BuildVersion.hs2
-rw-r--r--Git/CatFile.hs4
-rw-r--r--Git/Command.hs4
-rw-r--r--Git/Config.hs24
-rw-r--r--Git/Construct.hs42
-rw-r--r--Git/CurrentRepo.hs6
-rw-r--r--Git/Destroyer.hs1
-rw-r--r--Git/DiffTreeItem.hs24
-rw-r--r--Git/FilePath.hs5
-rw-r--r--Git/Filename.hs6
-rw-r--r--Git/Fsck.hs2
-rw-r--r--Git/Index.hs23
-rw-r--r--Git/LsFiles.hs85
-rw-r--r--Git/LsTree.hs31
-rw-r--r--Git/Objects.hs2
-rw-r--r--Git/Ref.hs5
-rw-r--r--Git/RefLog.hs22
-rw-r--r--Git/Remote.hs15
-rw-r--r--Git/Repair.hs21
-rw-r--r--Git/Sha.hs2
-rw-r--r--Git/Types.hs2
-rw-r--r--Git/UpdateIndex.hs17
-rw-r--r--Git/Url.hs2
-rw-r--r--Git/Version.hs41
-rw-r--r--Makefile2
-rw-r--r--Utility/Applicative.hs2
-rw-r--r--Utility/Batch.hs2
-rw-r--r--Utility/CoProcess.hs2
-rw-r--r--Utility/Data.hs4
-rw-r--r--Utility/Directory.hs35
-rw-r--r--Utility/DottedVersion.hs38
-rw-r--r--Utility/Env.hs4
-rw-r--r--Utility/Exception.hs23
-rw-r--r--Utility/FileMode.hs44
-rw-r--r--Utility/FileSize.hs35
-rw-r--r--Utility/FileSystemEncoding.hs40
-rw-r--r--Utility/Format.hs8
-rw-r--r--Utility/Metered.hs156
-rw-r--r--Utility/Misc.hs14
-rw-r--r--Utility/Monad.hs4
-rw-r--r--Utility/PartialPrelude.hs2
-rw-r--r--Utility/Path.hs97
-rw-r--r--Utility/PosixFiles.hs3
-rw-r--r--Utility/Process.hs207
-rw-r--r--Utility/Process/Shim.hs3
-rw-r--r--Utility/QuickCheck.hs3
-rw-r--r--Utility/Rsync.hs65
-rw-r--r--Utility/SafeCommand.hs117
-rw-r--r--Utility/ThreadScheduler.hs2
-rw-r--r--Utility/Tmp.hs63
-rw-r--r--Utility/URI.hs2
-rw-r--r--Utility/UserInfo.hs32
-rw-r--r--debian/changelog37
-rw-r--r--debian/control9
-rw-r--r--debian/gbp.conf10
-rw-r--r--debian/git-repair.lintian-overrides1
-rw-r--r--debian/source/format1
-rw-r--r--doc/index.mdwn4
-rw-r--r--doc/news/version_1.20141027.mdwn1
-rw-r--r--git-repair.cabal4
64 files changed, 1061 insertions, 460 deletions
diff --git a/Build/collect-ghc-options.sh b/Build/collect-ghc-options.sh
new file mode 100755
index 0000000..4f75a72
--- /dev/null
+++ b/Build/collect-ghc-options.sh
@@ -0,0 +1,12 @@
+#!/bin/sh
+# Generate --ghc-options to pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc
+# and on to ld, cc, and cpp.
+for w in $LDFLAGS; do
+ printf -- "-optl%s\n" "$w"
+done
+for w in $CFLAGS; do
+ printf -- "-optc%s\n" "$w"
+done
+for w in $CPPFLAGS; do
+ printf -- "-optc-Wp,%s\n" "$w"
+done
diff --git a/Common.hs b/Common.hs
index d64b5ad..a6c5d54 100644
--- a/Common.hs
+++ b/Common.hs
@@ -16,7 +16,7 @@ import System.FilePath as X
import System.Directory as X
import System.IO as X hiding (FilePath)
#ifndef mingw32_HOST_OS
-import System.Posix.IO as X
+import System.Posix.IO as X hiding (createPipe)
#endif
import System.Exit as X
@@ -30,6 +30,7 @@ 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.PosixFiles as X hiding (fileSize)
+import Utility.FileSize as X
import Utility.PartialPrelude as X
diff --git a/Git.hs b/Git.hs
index 55b44a9..1bc789f 100644
--- a/Git.hs
+++ b/Git.hs
@@ -3,7 +3,7 @@
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -30,6 +30,8 @@ module Git (
attributes,
hookPath,
assertLocal,
+ adjustPath,
+ relPath,
) where
import Network.URI (uriPath, uriScheme, unEscapeString)
@@ -58,7 +60,7 @@ repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Local { worktree = Just dir } } = dir
repoLocation Repo { location = Local { gitdir = dir } } = dir
repoLocation Repo { location = LocalUnknown dir } = dir
-repoLocation Repo { location = Unknown } = undefined
+repoLocation Repo { location = Unknown } = error "unknown repoLocation"
{- Path to a repository. For non-bare, this is the worktree, for bare,
- it's the gitdir, and for URL repositories, is the path on the remote
@@ -68,12 +70,12 @@ repoPath Repo { location = Url u } = unEscapeString $ uriPath u
repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
-repoPath Repo { location = Unknown } = undefined
+repoPath Repo { location = Unknown } = error "unknown repoPath"
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> FilePath
localGitDir Repo { location = Local { gitdir = d } } = d
-localGitDir _ = undefined
+localGitDir _ = error "unknown localGitDir"
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
@@ -139,3 +141,29 @@ hookPath script repo = do
#else
isexecutable f = isExecutable . fileMode <$> getFileStatus f
#endif
+
+{- Makes the path to a local Repo be relative to the cwd. -}
+relPath :: Repo -> IO Repo
+relPath = adjustPath torel
+ where
+ torel p = do
+ p' <- relPathCwdToFile p
+ if null p'
+ then return "."
+ else return p'
+
+{- Adusts the path to a local Repo using the provided function. -}
+adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
+adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
+ d' <- f d
+ w' <- maybe (pure Nothing) (Just <$$> f) w
+ return $ r
+ { location = l
+ { gitdir = d'
+ , worktree = w'
+ }
+ }
+adjustPath f r@(Repo { location = LocalUnknown d }) = do
+ d' <- f d
+ return $ r { location = LocalUnknown d' }
+adjustPath _ r = pure r
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 0b7d888..a2225dc 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -1,6 +1,6 @@
{- git branch stuff
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -37,7 +37,7 @@ current r = do
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
- <$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
+ <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where
parse l
| null l = Nothing
diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs
index 832ee8a..50e4a3a 100644
--- a/Git/BuildVersion.hs
+++ b/Git/BuildVersion.hs
@@ -1,6 +1,6 @@
{- git build version
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index d0bcef4..c63a064 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,6 +1,6 @@
{- git cat-file interface
-
- - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011, 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -110,4 +110,4 @@ catTree h treeref = go <$> catObjectDetails h treeref
parsemodefile b =
let (modestr, file) = separate (== ' ') (decodeBS b)
in (file, readmode modestr)
- readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct
+ readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
diff --git a/Git/Command.hs b/Git/Command.hs
index c61cc9f..02e3e5a 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -1,6 +1,6 @@
{- running git commands
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -16,7 +16,7 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
-gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
+gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
setdir : settree ++ gitGlobalOpts r ++ params
where
setdir = Param $ "--git-dir=" ++ gitdir l
diff --git a/Git/Config.hs b/Git/Config.hs
index 32c0dd1..3d62395 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -1,6 +1,6 @@
{- git repository configuration handling
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -14,6 +14,7 @@ import Common
import Git
import Git.Types
import qualified Git.Construct
+import qualified Git.Command
import Utility.UserInfo
{- Returns a single git config setting, or a default value if not set. -}
@@ -66,10 +67,9 @@ global = do
home <- myHomeDir
ifM (doesFileExist $ home </> ".gitconfig")
( do
- repo <- Git.Construct.fromUnknown
- repo' <- withHandle StdoutHandle createProcessSuccess p $
- hRead repo
- return $ Just repo'
+ repo <- withHandle StdoutHandle createProcessSuccess p $
+ hRead (Git.Construct.fromUnknown)
+ return $ Just repo
, return Nothing
)
where
@@ -194,3 +194,17 @@ changeFile f k v = boolSystem "git"
, Param k
, Param v
]
+
+{- Unsets a git config setting, in both the git repo,
+ - and the cached config in the Repo.
+ -
+ - If unsetting the config fails, including in a read-only repo, or
+ - when the config is not set, returns Nothing.
+ -}
+unset :: String -> Repo -> IO (Maybe Repo)
+unset k r = ifM (Git.Command.runBool ps r)
+ ( return $ Just $ r { config = M.delete k (config r) }
+ , return Nothing
+ )
+ where
+ ps = [Param "config", Param "--unset-all", Param k]
diff --git a/Git/Construct.hs b/Git/Construct.hs
index eed2b99..03dd29f 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -1,6 +1,6 @@
{- Construction of Git Repo objects
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -19,8 +19,8 @@ module Git.Construct (
fromRemotes,
fromRemoteLocation,
repoAbsPath,
- newFrom,
checkForRepo,
+ newFrom,
) where
#ifndef mingw32_HOST_OS
@@ -45,10 +45,10 @@ fromCwd = getCurrentDirectory >>= seekUp
seekUp dir = do
r <- checkForRepo dir
case r of
- Nothing -> case parentDir dir of
- "" -> return Nothing
- d -> seekUp d
- Just loc -> Just <$> newFrom loc
+ Nothing -> case upFrom dir of
+ Nothing -> return Nothing
+ Just d -> seekUp d
+ Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
@@ -58,24 +58,29 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
- | absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+ | absoluteGitPath dir = hunt
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
- ret = newFrom . LocalUnknown
- {- Git always looks for "dir.git" in preference to
- - to "dir", even if dir ends in a "/". -}
+ ret = pure . newFrom . LocalUnknown
canondir = dropTrailingPathSeparator dir
- dir' = canondir ++ ".git"
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
| (pathSeparator:".git") `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir </> ".git")
( ret dir
- , ret $ takeDirectory canondir
+ , ret (takeDirectory canondir)
)
- | otherwise = ret dir
+ | otherwise = ifM (doesDirectoryExist dir)
+ ( ret dir
+ -- git falls back to dir.git when dir doesn't
+ -- exist, as long as dir didn't end with a
+ -- path separator
+ , if dir == canondir
+ then ret (dir ++ ".git")
+ else ret dir
+ )
{- Remote Repo constructor. Throws exception on invalid url.
-
@@ -90,13 +95,13 @@ fromUrl url
fromUrlStrict :: String -> IO Repo
fromUrlStrict url
| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u
- | otherwise = newFrom $ Url u
+ | otherwise = pure $ newFrom $ Url u
where
u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
-fromUnknown :: IO Repo
+fromUnknown :: Repo
fromUnknown = newFrom Unknown
{- Converts a local Repo into a remote repo, using the reference repo
@@ -153,7 +158,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
- fromAbsPath $ repoPath repo </> dir'
+ fromPath $ repoPath repo </> dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
@@ -223,8 +228,8 @@ checkForRepo dir =
gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file
-newFrom :: RepoLocation -> IO Repo
-newFrom l = return Repo
+newFrom :: RepoLocation -> Repo
+newFrom l = Repo
{ location = l
, config = M.empty
, fullconfig = M.empty
@@ -234,4 +239,3 @@ newFrom l = return Repo
, gitGlobalOpts = []
}
-
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index f611f7a..dab4ad2 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -1,6 +1,6 @@
{- The current git repository.
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -50,8 +50,8 @@ get = do
configure (Just d) _ = do
absd <- absPath d
curr <- getCurrentDirectory
- r <- newFrom $ Local { gitdir = absd, worktree = Just curr }
- Git.Config.read r
+ Git.Config.read $ newFrom $
+ Local { gitdir = absd, worktree = Just curr }
configure Nothing Nothing = error "Not in a git repository."
addworktree w r = changelocation r $
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
index 2ac4dae..e923796 100644
--- a/Git/Destroyer.hs
+++ b/Git/Destroyer.hs
@@ -21,7 +21,6 @@ import Utility.Tmp
import qualified Data.ByteString as B
import Data.Word
-import System.PosixCompat.Types
{- Ways to damange a git repository. -}
data Damage
diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs
new file mode 100644
index 0000000..859f590
--- /dev/null
+++ b/Git/DiffTreeItem.hs
@@ -0,0 +1,24 @@
+{- git diff-tree item
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.DiffTreeItem (
+ DiffTreeItem(..),
+) where
+
+import System.Posix.Types
+
+import Git.FilePath
+import Git.Types
+
+data DiffTreeItem = DiffTreeItem
+ { srcmode :: FileMode
+ , dstmode :: FileMode
+ , srcsha :: Sha -- nullSha if file was added
+ , dstsha :: Sha -- nullSha if file was deleted
+ , status :: String
+ , file :: TopFilePath
+ } deriving Show
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index 42eb081..edc3c0f 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -5,7 +5,7 @@
- top of the repository even when run in a subdirectory. Adding some
- types helps keep that straight.
-
- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -39,8 +39,7 @@ fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
-toTopFilePath file repo = TopFilePath <$>
- relPathDirToFile (repoPath repo) <$> absPath file
+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input FilePath must already be relative to the top of the git
- repository -}
diff --git a/Git/Filename.hs b/Git/Filename.hs
index 5e076d3..ee84d48 100644
--- a/Git/Filename.hs
+++ b/Git/Filename.hs
@@ -1,7 +1,7 @@
{- Some git commands output encoded filenames, in a rather annoyingly complex
- C-style encoding.
-
- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -24,5 +24,5 @@ encode :: FilePath -> String
encode s = "\"" ++ encode_c s ++ "\""
{- for quickcheck -}
-prop_idempotent_deencode :: String -> Bool
-prop_idempotent_deencode s = s == decode (encode s)
+prop_isomorphic_deencode :: String -> Bool
+prop_isomorphic_deencode s = s == decode (encode s)
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index c6002f6..f3e6db9 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -1,6 +1,6 @@
{- git fsck interface
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/Index.hs b/Git/Index.hs
index c42ac42..551fd98 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -1,6 +1,6 @@
{- git index file stuff
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -11,6 +11,9 @@ import Common
import Git
import Utility.Env
+indexEnv :: String
+indexEnv = "GIT_INDEX_FILE"
+
{- Forces git to use the specified index file.
-
- Returns an action that will reset back to the default
@@ -25,7 +28,7 @@ override index = do
return $ reset res
where
var = "GIT_INDEX_FILE"
- reset (Just v) = setEnv var v True
+ reset (Just v) = setEnv indexEnv v True
reset _ = unsetEnv var
indexFile :: Repo -> FilePath
@@ -34,3 +37,19 @@ indexFile r = localGitDir r </> "index"
{- Git locks the index by creating this file. -}
indexFileLock :: Repo -> FilePath
indexFileLock r = indexFile r ++ ".lock"
+
+{- When the pre-commit hook is run, and git commit has been run with
+ - a file or files specified to commit, rather than committing the staged
+ - index, git provides the pre-commit hook with a "false index file".
+ -
+ - Changes made to this index will influence the commit, but won't
+ - affect the real index file.
+ -
+ - This detects when we're in this situation, using a heuristic, which
+ - might be broken by changes to git. Any use of this should have a test
+ - case to make sure it works.
+ -}
+haveFalseIndex :: IO Bool
+haveFalseIndex = maybe (False) check <$> getEnv indexEnv
+ where
+ check f = "next-index" `isPrefixOf` takeFileName f
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 2aa05ba..f945838 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -1,6 +1,6 @@
{- git ls-files interface
-
- - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010,2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -35,14 +35,23 @@ import System.Posix.Types
{- Scans for files that are checked into git at the specified locations. -}
inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l
+inRepo l = pipeNullSplit $
+ Param "ls-files" :
+ Param "--cached" :
+ Param "-z" :
+ Param "--" :
+ map File l
{- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
notInRepo include_ignored l repo = pipeNullSplit params repo
where
- params = [Params "ls-files --others"] ++ exclude ++
- [Params "-z --"] ++ map File l
+ params = concat
+ [ [ Param "ls-files", Param "--others"]
+ , exclude
+ , [ Param "-z", Param "--" ]
+ , map File l
+ ]
exclude
| include_ignored = []
| otherwise = [Param "--exclude-standard"]
@@ -50,28 +59,51 @@ notInRepo include_ignored l repo = pipeNullSplit params repo
{- Finds all files in the specified locations, whether checked into git or
- not. -}
allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File l
+allFiles l = pipeNullSplit $
+ Param "ls-files" :
+ Param "--cached" :
+ Param "--others" :
+ Param "-z" :
+ Param "--" :
+ map File l
{- Returns a list of files in the specified locations that have been
- deleted. -}
deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
deleted l repo = pipeNullSplit params repo
where
- params = [Params "ls-files --deleted -z --"] ++ map File l
+ params =
+ Param "ls-files" :
+ Param "--deleted" :
+ Param "-z" :
+ Param "--" :
+ map File l
{- Returns a list of files in the specified locations that have been
- modified. -}
modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modified l repo = pipeNullSplit params repo
where
- params = [Params "ls-files --modified -z --"] ++ map File l
+ params =
+ Param "ls-files" :
+ Param "--modified" :
+ Param "-z" :
+ Param "--" :
+ map File l
{- Files that have been modified or are not checked into git (and are not
- ignored). -}
modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modifiedOthers l repo = pipeNullSplit params repo
where
- params = [Params "ls-files --modified --others --exclude-standard -z --"] ++ map File l
+ params =
+ Param "ls-files" :
+ Param "--modified" :
+ Param "--others" :
+ Param "--exclude-standard" :
+ Param "-z" :
+ Param "--" :
+ map File l
{- Returns a list of all files that are staged for commit. -}
staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
@@ -85,7 +117,7 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
where
- prefix = [Params "diff --cached --name-only -z"]
+ prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
suffix = Param "--" : map File l
type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)
@@ -93,7 +125,7 @@ type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)
{- Returns details about files that are staged in the index,
- as well as files not yet in git. Skips ignored files. -}
stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedOthersDetails = stagedDetails' [Params "--others --exclude-standard"]
+stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
{- Returns details about all files that are staged in the index. -}
stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
@@ -106,7 +138,7 @@ stagedDetails' ps l repo = do
(ls, cleanup) <- pipeNullSplit params repo
return (map parse ls, cleanup)
where
- params = Params "ls-files --stage -z" : ps ++
+ params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map File l
parse s
| null file = (s, Nothing, Nothing)
@@ -131,11 +163,16 @@ typeChanged' ps l repo = do
(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
-- 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
+ top <- absPath (repoPath repo)
currdir <- getCurrentDirectory
- return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
+ return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)
where
- prefix = [Params "diff --name-only --diff-filter=T -z"]
+ prefix =
+ [ Param "diff"
+ , Param "--name-only"
+ , Param "--diff-filter=T"
+ , Param "-z"
+ ]
suffix = Param "--" : (if null l then [File "."] else map File l)
{- A item in conflict has two possible values.
@@ -166,7 +203,12 @@ unmerged l repo = do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
where
- params = Params "ls-files --unmerged -z --" : map File l
+ params =
+ Param "ls-files" :
+ Param "--unmerged" :
+ Param "-z" :
+ Param "--" :
+ map File l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
@@ -181,12 +223,13 @@ parseUnmerged s
| otherwise = case words metadata of
(rawblobtype:rawsha:rawstage:_) -> do
stage <- readish rawstage :: Maybe Int
- unless (stage == 2 || stage == 3) $
- fail undefined -- skip stage 1
- blobtype <- readBlobType rawblobtype
- sha <- extractSha rawsha
- return $ InternalUnmerged (stage == 2) file
- (Just blobtype) (Just sha)
+ if stage /= 2 && stage /= 3
+ then Nothing
+ else do
+ blobtype <- readBlobType rawblobtype
+ sha <- extractSha rawsha
+ return $ InternalUnmerged (stage == 2) file
+ (Just blobtype) (Just sha)
_ -> Nothing
where
(metadata, file) = separate (== '\t') s
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index ca5e323..1ed6247 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,6 +1,6 @@
{- git ls-tree interface
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -13,10 +13,6 @@ module Git.LsTree (
parseLsTree
) where
-import Numeric
-import Control.Applicative
-import System.Posix.Types
-
import Common
import Git
import Git.Command
@@ -24,6 +20,9 @@ import Git.Sha
import Git.FilePath
import qualified Git.Filename
+import Numeric
+import System.Posix.Types
+
data TreeItem = TreeItem
{ mode :: FileMode
, typeobj :: String
@@ -35,16 +34,30 @@ data TreeItem = TreeItem
- with lazy output. -}
lsTree :: Ref -> Repo -> IO [TreeItem]
lsTree t repo = map parseLsTree
- <$> pipeNullSplitZombie (lsTreeParams t) repo
+ <$> pipeNullSplitZombie (lsTreeParams t []) repo
-lsTreeParams :: Ref -> [CommandParam]
-lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
+lsTreeParams :: Ref -> [CommandParam] -> [CommandParam]
+lsTreeParams r ps =
+ [ Param "ls-tree"
+ , Param "--full-tree"
+ , Param "-z"
+ , Param "-r"
+ ] ++ ps ++
+ [ Param "--"
+ , File $ fromRef r
+ ]
{- Lists specified files in a tree. -}
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 =
+ [ Param "ls-tree"
+ , Param "--full-tree"
+ , Param "-z"
+ , Param "--"
+ , 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 dadd4f5..bda220b 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -1,6 +1,6 @@
{- .git/objects
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 3d0c68f..6bc47d5 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -1,6 +1,6 @@
{- git ref stuff
-
- - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -88,6 +88,9 @@ sha branch repo = process <$> showref repo
process [] = Nothing
process s = Just $ Ref $ firstLine s
+headSha :: Repo -> IO (Maybe Sha)
+headSha = sha headRef
+
{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
matching refs repo = matching' (map fromRef refs) repo
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
index 98c9d66..57f35e9 100644
--- a/Git/RefLog.hs
+++ b/Git/RefLog.hs
@@ -1,6 +1,6 @@
{- git reflog interface
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -14,9 +14,17 @@ import Git.Sha
{- Gets the reflog for a given branch. -}
get :: Branch -> Repo -> IO [Sha]
-get b = mapMaybe extractSha . lines <$$> pipeReadStrict
- [ Param "log"
- , Param "-g"
- , Param "--format=%H"
- , Param (fromRef b)
- ]
+get b = getMulti [b]
+
+{- Gets reflogs for multiple branches. -}
+getMulti :: [Branch] -> Repo -> IO [Sha]
+getMulti bs = get' (map (Param . fromRef) bs)
+
+get' :: [CommandParam] -> Repo -> IO [Sha]
+get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps'
+ where
+ ps' = catMaybes
+ [ Just $ Param "log"
+ , Just $ Param "-g"
+ , Just $ Param "--format=%H"
+ ] ++ ps
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 7e8e5f8..717b540 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -1,6 +1,6 @@
{- git remote stuff
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -12,8 +12,6 @@ module Git.Remote where
import Common
import Git
import Git.Types
-import qualified Git.Command
-import qualified Git.BuildVersion
import Data.Char
import qualified Data.Map as M
@@ -44,17 +42,6 @@ makeLegalName s = case filter legal $ replace "/" "_" s of
legal '.' = True
legal c = isAlphaNum c
-remove :: RemoteName -> Repo -> IO ()
-remove remotename = Git.Command.run
- [ Param "remote"
- -- name of this subcommand changed
- , Param $
- if Git.BuildVersion.older "1.8.0"
- then "rm"
- else "remove"
- , Param remotename
- ]
-
data RemoteLocation = RemoteUrl String | RemotePath FilePath
remoteLocationIsUrl :: RemoteLocation -> Bool
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 77a592b..b441f13 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -1,6 +1,6 @@
{- git repository recovery
-
- - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -99,7 +99,7 @@ retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResult
retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
- unlessM (boolSystem "git" [Params "init", File tmpdir]) $
+ unlessM (boolSystem "git" [Param "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
@@ -140,7 +140,9 @@ retrieveMissingObjects missing referencerepo r
ps' =
[ Param "fetch"
, Param fetchurl
- , Params "--force --update-head-ok --quiet"
+ , Param "--force"
+ , Param "--update-head-ok"
+ , Param "--quiet"
] ++ ps
fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc }
nogc = [ Param "-c", Param "gc.auto=0" ]
@@ -225,10 +227,13 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = map toref <$> dirContentsRecursive refdir
- where
- refdir = localGitDir r </> "refs"
- toref = Ref . relPathDirToFile (localGitDir r)
+getAllRefs r = getAllRefs' (localGitDir r </> "refs")
+
+getAllRefs' :: FilePath -> IO [Ref]
+getAllRefs' refdir = do
+ let topsegs = length (splitPath refdir) - 1
+ let toref = Ref . joinPath . drop topsegs . splitPath
+ map toref <$> dirContentsRecursive refdir
explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
@@ -336,7 +341,7 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
verifyTree missing treesha r
| S.member treesha missing = return False
| otherwise = do
- (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha) r
+ (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r
let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls
if any isNothing objshas || any (`S.member` missing) (catMaybes objshas)
then do
diff --git a/Git/Sha.hs b/Git/Sha.hs
index cbb66ea..b802c85 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -1,6 +1,6 @@
{- git SHA stuff
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/Types.hs b/Git/Types.hs
index 838c9e0..bb91a17 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -1,6 +1,6 @@
{- git data types
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index ecd154a..55c5b3b 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,6 +1,6 @@
{- git-update-index library
-
- - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -19,7 +19,8 @@ module Git.UpdateIndex (
updateIndexLine,
stageFile,
unstageFile,
- stageSymlink
+ stageSymlink,
+ stageDiffTreeItem,
) where
import Common
@@ -28,6 +29,7 @@ import Git.Types
import Git.Command
import Git.FilePath
import Git.Sha
+import qualified Git.DiffTreeItem as Diff
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
@@ -95,7 +97,10 @@ stageFile sha filetype file repo = do
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
- return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
+ return $ unstageFile' p
+
+unstageFile' :: TopFilePath -> Streamer
+unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
@@ -106,5 +111,11 @@ stageSymlink file sha repo = do
<*> toTopFilePath file repo
return $ pureStreamer line
+{- A streamer that applies a DiffTreeItem to the index. -}
+stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
+stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of
+ Nothing -> unstageFile' (Diff.file d)
+ Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
+
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
diff --git a/Git/Url.hs b/Git/Url.hs
index d383a6a..fa7d200 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -1,6 +1,6 @@
{- git repository urls
-
- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
diff --git a/Git/Version.hs b/Git/Version.hs
index 5c61f85..19ff945 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -1,22 +1,23 @@
{- git versions
-
- - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011, 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
-module Git.Version where
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-import Common
-
-data GitVersion = GitVersion String Integer
- deriving (Eq)
+module Git.Version (
+ installed,
+ older,
+ normalize,
+ GitVersion,
+) where
-instance Ord GitVersion where
- compare (GitVersion _ x) (GitVersion _ y) = compare x y
+import Common
+import Utility.DottedVersion
-instance Show GitVersion where
- show (GitVersion s _) = s
+type GitVersion = DottedVersion
installed :: IO GitVersion
installed = normalize . extract <$> readProcess "git" ["--version"]
@@ -25,19 +26,7 @@ installed = normalize . extract <$> readProcess "git" ["--version"]
[] -> ""
(l:_) -> unwords $ drop 2 $ words l
-{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
- - a somewhat arbitrary integer representation. -}
-normalize :: String -> GitVersion
-normalize v = GitVersion v $
- sum $ mult 1 $ reverse $ extend precision $ take precision $
- map readi $ split "." v
- where
- extend n l = l ++ replicate (n - length l) 0
- mult _ [] = []
- mult n (x:xs) = (n*x) : mult (n*10^width) xs
- readi :: String -> Integer
- readi s = case reads s of
- ((x,_):_) -> x
- _ -> 0
- precision = 10 -- number of segments of the version to compare
- width = length "yyyymmddhhmmss" -- maximum width of a segment
+older :: String -> IO Bool
+older n = do
+ v <- installed
+ return $ v < normalize n
diff --git a/Makefile b/Makefile
index 42848b7..dcdcbbb 100644
--- a/Makefile
+++ b/Makefile
@@ -8,7 +8,7 @@ build: Build/SysConfig.hs
Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
- $(CABAL) configure
+ $(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"
install: build
install -d $(DESTDIR)$(PREFIX)/bin
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
index fd8944b..fce3c04 100644
--- a/Utility/Applicative.hs
+++ b/Utility/Applicative.hs
@@ -1,6 +1,6 @@
{- applicative stuff
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index ff81318..d96f9d3 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -1,6 +1,6 @@
{- Running a long or expensive batch operation niced.
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 97826ec..9854b47 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -1,7 +1,7 @@
{- Interface for running a shell command as a coprocess,
- sending it queries and getting back results.
-
- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Data.hs b/Utility/Data.hs
index 2df12b3..27c0a82 100644
--- a/Utility/Data.hs
+++ b/Utility/Data.hs
@@ -1,10 +1,12 @@
{- utilities for simple data types
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
module Utility.Data where
{- First item in the list that is not Nothing. -}
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index e4e4b80..fae33b5 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,32 +1,34 @@
{- directory traversal and manipulation
-
- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where
import System.IO.Error
import System.Directory
import Control.Monad
-import Control.Monad.IfElse
import System.FilePath
import Control.Applicative
import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
+import Prelude
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
#else
import qualified System.Posix as Posix
+import Utility.SafeCommand
+import Control.Monad.IfElse
#endif
import Utility.PosixFiles
-import Utility.SafeCommand
import Utility.Tmp
import Utility.Exception
import Utility.Monad
@@ -105,21 +107,32 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
onrename (Left e)
| isPermissionError e = rethrow
| isDoesNotExistError e = rethrow
- | otherwise = do
- -- copyFile is likely not as optimised as
- -- the mv command, so we'll use the latter.
- -- But, mv will move into a directory if
- -- dest is one, which is not desired.
- whenM (isdir dest) rethrow
- viaTmp mv dest undefined
+ | otherwise = viaTmp mv dest ""
where
rethrow = throwM e
+
mv tmp _ = do
+ -- copyFile is likely not as optimised as
+ -- the mv command, so we'll use the command.
+ --
+ -- But, while Windows has a "mv", it does not seem very
+ -- reliable, so use copyFile there.
+#ifndef mingw32_HOST_OS
+ -- If dest is a directory, mv would move the file
+ -- into it, which is not desired.
+ whenM (isdir dest) rethrow
ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
+ let e' = e
+#else
+ r <- tryIO $ copyFile src tmp
+ let (ok, e') = case r of
+ Left err -> (False, err)
+ Right _ -> (True, e)
+#endif
unless ok $ do
-- delete any partial
_ <- tryIO $ removeFile tmp
- rethrow
+ throwM e'
isdir f = do
r <- tryIO $ getFileStatus f
diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs
new file mode 100644
index 0000000..ebf4c0b
--- /dev/null
+++ b/Utility/DottedVersion.hs
@@ -0,0 +1,38 @@
+{- dotted versions, such as 1.0.1
+ -
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.DottedVersion where
+
+import Common
+
+data DottedVersion = DottedVersion String Integer
+ deriving (Eq)
+
+instance Ord DottedVersion where
+ compare (DottedVersion _ x) (DottedVersion _ y) = compare x y
+
+instance Show DottedVersion where
+ show (DottedVersion s _) = s
+
+{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
+ - a somewhat arbitrary integer representation. -}
+normalize :: String -> DottedVersion
+normalize v = DottedVersion v $
+ sum $ mult 1 $ reverse $ extend precision $ take precision $
+ map readi $ split "." v
+ where
+ extend n l = l ++ replicate (n - length l) 0
+ mult _ [] = []
+ mult n (x:xs) = (n*x) : mult (n*10^width) xs
+ readi :: String -> Integer
+ readi s = case reads s of
+ ((x,_):_) -> x
+ _ -> 0
+ precision = 10 -- number of segments of the version to compare
+ width = length "yyyymmddhhmmss" -- maximum width of a segment
diff --git a/Utility/Env.hs b/Utility/Env.hs
index ff6644f..c56f4ec 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -1,11 +1,12 @@
{- portable environment variables
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Env where
@@ -13,6 +14,7 @@ module Utility.Env where
import Utility.Exception
import Control.Applicative
import Data.Maybe
+import Prelude
import qualified System.Environment as E
import qualified System.SetEnv
#else
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index ef3ab1d..8b110ae 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,11 +1,12 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
module X,
@@ -19,6 +20,8 @@ module Utility.Exception (
catchNonAsync,
tryNonAsync,
tryWhenExists,
+ catchIOErrorType,
+ IOErrorType(..)
) where
import Control.Monad.Catch as X hiding (Handler)
@@ -26,7 +29,9 @@ 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 System.IO.Error (isDoesNotExistError, ioeGetErrorType)
+import GHC.IO.Exception (IOErrorType(..))
+
import Utility.Data
{- Catches IO errors and returns a Bool -}
@@ -35,10 +40,7 @@ catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
-catchMaybeIO a = do
- catchDefaultIO Nothing $ do
- v <- a
- return (Just v)
+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)
{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
@@ -86,3 +88,12 @@ tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = do
v <- tryJust (guard . isDoesNotExistError) a
return (eitherToMaybe v)
+
+{- Catches only IO exceptions of a particular type.
+ - Ie, use HardwareFault to catch disk IO errors. -}
+catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a
+catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching
+ where
+ onlymatching e
+ | ioeGetErrorType e == errtype = onmatchingerr e
+ | otherwise = throwM e
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 832250b..efef5fa 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -1,13 +1,16 @@
{- File mode utilities.
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
-module Utility.FileMode where
+module Utility.FileMode (
+ module Utility.FileMode,
+ FileMode,
+) where
import System.IO
import Control.Monad
@@ -17,12 +20,15 @@ import Utility.PosixFiles
import System.Posix.Files
#endif
import Foreign (complement)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Catch
import Utility.Exception
{- Applies a conversion function to a file's mode. -}
modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
+
modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
s <- getFileStatus f
@@ -32,6 +38,14 @@ modifyFileMode' f convert = do
setFileMode f new
return old
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+ where
+ setup = modifyFileMode' file convert
+ cleanup oldmode = modifyFileMode file (const oldmode)
+ go _ = a
+
{- Adds the specified FileModes to the input mode, leaving the rest
- unchanged. -}
addModes :: [FileMode] -> FileMode -> FileMode
@@ -41,14 +55,6 @@ addModes ms m = combineModes (m:ms)
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes ms m = m `intersectFileModes` complement (combineModes ms)
-{- Runs an action after changing a file's mode, then restores the old mode. -}
-withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
-withModifiedFileMode file convert a = bracket setup cleanup go
- where
- setup = modifyFileMode' file convert
- cleanup oldmode = modifyFileMode file (const oldmode)
- go _ = a
-
writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
@@ -103,7 +109,7 @@ isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
{- Runs an action without that pesky umask influencing it, unless the
- passed FileMode is the standard one. -}
-noUmask :: FileMode -> IO a -> IO a
+noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
#ifndef mingw32_HOST_OS
noUmask mode a
| mode == stdFileMode = a
@@ -112,19 +118,19 @@ noUmask mode a
noUmask _ a = a
#endif
-withUmask :: FileMode -> IO a -> IO a
+withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
#ifndef mingw32_HOST_OS
withUmask umask a = bracket setup cleanup go
where
- setup = setFileCreationMask umask
- cleanup = setFileCreationMask
+ setup = liftIO $ setFileCreationMask umask
+ cleanup = liftIO . setFileCreationMask
go _ = a
#else
withUmask _ a = a
#endif
combineModes :: [FileMode] -> FileMode
-combineModes [] = undefined
+combineModes [] = 0
combineModes [m] = m
combineModes (m:ms) = foldl unionFileModes m ms
@@ -151,7 +157,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- as writeFile.
-}
writeFileProtected :: FilePath -> String -> IO ()
-writeFileProtected file content = withUmask 0o0077 $
+writeFileProtected file content = writeFileProtected' file
+ (\h -> hPutStr h content)
+
+writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
+writeFileProtected' file writer = withUmask 0o0077 $
withFile file WriteMode $ \h -> do
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
- hPutStr h content
+ writer h
diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs
new file mode 100644
index 0000000..1055754
--- /dev/null
+++ b/Utility/FileSize.hs
@@ -0,0 +1,35 @@
+{- File size.
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileSize where
+
+import System.PosixCompat.Files
+#ifdef mingw32_HOST_OS
+import Control.Exception (bracket)
+import System.IO
+#endif
+
+{- Gets the size of a file.
+ -
+ - This is better than using fileSize, because on Windows that returns a
+ - FileOffset which maxes out at 2 gb.
+ - See https://github.com/jystic/unix-compat/issues/16
+ -}
+getFileSize :: FilePath -> IO Integer
+#ifndef mingw32_HOST_OS
+getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)
+#else
+getFileSize f = bracket (openFile f ReadMode) hClose hFileSize
+#endif
+
+{- Gets the size of the file, when its FileStatus is already known. -}
+getFileSize' :: FilePath -> FileStatus -> IO Integer
+#ifndef mingw32_HOST_OS
+getFileSize' _ s = return $ fromIntegral $ fileSize s
+#else
+getFileSize' f _ = getFileSize f
+#endif
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index fa4b39a..67341d3 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -1,19 +1,23 @@
{- GHC File system encoding handling.
-
- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FileSystemEncoding (
fileEncoding,
withFilePath,
md5FilePath,
decodeBS,
+ encodeBS,
decodeW8,
encodeW8,
+ encodeW8NUL,
+ decodeW8NUL,
truncateFilePath,
) where
@@ -25,11 +29,15 @@ import System.IO.Unsafe
import qualified Data.Hash.MD5 as MD5
import Data.Word
import Data.Bits.Utils
+import Data.List
+import Data.List.Utils
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
+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
@@ -63,12 +71,16 @@ withFilePath fp f = Encoding.getFileSystemEncoding
- only allows doing this conversion with CStrings, and the CString buffer
- is allocated, used, and deallocated within the call, with no side
- effects.
+ -
+ - If the FilePath contains a value that is not legal in the filesystem
+ - encoding, rather than thowing an exception, it will be returned as-is.
-}
{-# NOINLINE _encodeFilePath #-}
_encodeFilePath :: FilePath -> String
_encodeFilePath fp = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
- GHC.withCString enc fp $ GHC.peekCString Encoding.char8
+ GHC.withCString enc fp (GHC.peekCString Encoding.char8)
+ `catchNonAsync` (\_ -> return fp)
{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
md5FilePath :: FilePath -> MD5.Str
@@ -77,18 +89,29 @@ md5FilePath = MD5.Str . _encodeFilePath
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBS :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
-decodeBS = encodeW8 . L.unpack
+decodeBS = encodeW8NUL . L.unpack
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
- only uses unicode for filenames. -}
decodeBS = L8.toString
#endif
+{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}
+encodeBS :: FilePath -> L.ByteString
+#ifndef mingw32_HOST_OS
+encodeBS = L.pack . decodeW8NUL
+#else
+encodeBS = L8.fromString
+#endif
+
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
- w82c produces a String, which may contain Chars that are invalid
- unicode. From there, this is really a simple matter of applying the
- file system encoding, only complicated by GHC's interface to doing so.
+ -
+ - Note that the encoding stops at any NUL in the input. FilePaths
+ - do not normally contain embedded NUL, but Haskell Strings may.
-}
{-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath
@@ -101,6 +124,17 @@ encodeW8 w8 = unsafePerformIO $ do
decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath
+{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
+encodeW8NUL :: [Word8] -> FilePath
+encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul)
+ where
+ nul = ['\NUL']
+
+decodeW8NUL :: FilePath -> [Word8]
+decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul
+ where
+ nul = ['\NUL']
+
{- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk.
-
diff --git a/Utility/Format.hs b/Utility/Format.hs
index 78620f9..7844963 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -1,6 +1,6 @@
{- Formatted string handling.
-
- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -11,7 +11,7 @@ module Utility.Format (
format,
decode_c,
encode_c,
- prop_idempotent_deencode
+ prop_isomorphic_deencode
) where
import Text.Printf (printf)
@@ -174,5 +174,5 @@ encode_c' p = concatMap echar
showoctal i = '\\' : printf "%03o" i
{- for quickcheck -}
-prop_idempotent_deencode :: String -> Bool
-prop_idempotent_deencode s = s == decode_c (encode_c s)
+prop_isomorphic_deencode :: String -> Bool
+prop_isomorphic_deencode s = s == decode_c (encode_c s)
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 4618aec..da83fd8 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,6 +1,6 @@
-{- Metered IO
+{- Metered IO and actions
-
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2105 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -17,6 +17,10 @@ import System.IO.Unsafe
import Foreign.Storable (Storable(sizeOf))
import System.Posix.Types
import Data.Int
+import Data.Bits.Utils
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Monad.IO.Class (MonadIO)
{- An action that can be run repeatedly, updating it on the bytes processed.
-
@@ -27,6 +31,9 @@ type MeterUpdate = (BytesProcessed -> IO ())
nullMeterUpdate :: MeterUpdate
nullMeterUpdate _ = return ()
+combineMeterUpdate :: MeterUpdate -> MeterUpdate -> MeterUpdate
+combineMeterUpdate a b = \n -> a n >> b n
+
{- Total number of bytes processed so far. -}
newtype BytesProcessed = BytesProcessed Integer
deriving (Eq, Ord, Show)
@@ -99,37 +106,156 @@ 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.
-
+ - All the usual caveats about using unsafeInterleaveIO apply to the
+ - meter updates, so use caution.
+ -}
+hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString
+hGetContentsMetered h = hGetUntilMetered h (const True)
+
+{- Reads from the Handle, updating the meter after each chunk.
+ -
- 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.
-
- - All the usual caveats about using unsafeInterleaveIO apply to the
- - meter updates, so use caution.
+ - Stops at EOF, or when keepgoing evaluates to False.
+ - Closes the Handle at EOF, but otherwise leaves it open.
-}
-hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString
-hGetContentsMetered h meterupdate = lazyRead zeroBytesProcessed
+hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString
+hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed
where
lazyRead sofar = unsafeInterleaveIO $ loop sofar
loop sofar = do
- c <- S.hGetSome h defaultChunkSize
+ c <- S.hGet h defaultChunkSize
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'
- {- unsafeInterleaveIO causes this to be
- - deferred until the data is read from the
- - ByteString. -}
- cs <- lazyRead sofar'
- return $ L.append (L.fromChunks [c]) cs
+ if keepgoing (fromBytesProcessed sofar')
+ then do
+ {- unsafeInterleaveIO causes this to be
+ - deferred until the data is read from the
+ - ByteString. -}
+ cs <- lazyRead sofar'
+ return $ L.append (L.fromChunks [c]) cs
+ else return $ L.fromChunks [c]
{- Same default chunk size Lazy ByteStrings use. -}
defaultChunkSize :: Int
defaultChunkSize = 32 * k - chunkOverhead
where
k = 1024
- chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
+ chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific
+
+{- Runs an action, watching a file as it grows and updating the meter. -}
+watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a
+watchFileSize f p a = bracket
+ (liftIO $ forkIO $ watcher zeroBytesProcessed)
+ (liftIO . void . tryIO . killThread)
+ (const a)
+ where
+ watcher oldsz = do
+ v <- catchMaybeIO $ toBytesProcessed <$> getFileSize f
+ newsz <- case v of
+ Just sz | sz /= oldsz -> do
+ p sz
+ return sz
+ _ -> return oldsz
+ threadDelay 500000 -- 0.5 seconds
+ watcher newsz
+
+data OutputHandler = OutputHandler
+ { quietMode :: Bool
+ , stderrHandler :: String -> IO ()
+ }
+
+{- Parses the String looking for a command's progress output, and returns
+ - Maybe the number of bytes done so far, and any any remainder of the
+ - string that could be an incomplete progress output. That remainder
+ - should be prepended to future output, and fed back in. This interface
+ - allows the command's output to be read in any desired size chunk, or
+ - even one character at a time.
+ -}
+type ProgressParser = String -> (Maybe BytesProcessed, String)
+
+{- Runs a command and runs a ProgressParser on its output, in order
+ - to update a meter.
+ -}
+commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
+commandMeter progressparser oh meterupdate cmd params =
+ outputFilter cmd params Nothing
+ (feedprogress zeroBytesProcessed [])
+ handlestderr
+ where
+ feedprogress prev buf h = do
+ b <- S.hGetSome h 80
+ if S.null b
+ then return ()
+ else do
+ unless (quietMode oh) $ do
+ S.hPut stdout b
+ hFlush stdout
+ let s = w82s (S.unpack b)
+ let (mbytes, buf') = progressparser (buf++s)
+ case mbytes of
+ Nothing -> feedprogress prev buf' h
+ (Just bytes) -> do
+ when (bytes /= prev) $
+ meterupdate bytes
+ feedprogress bytes buf' h
+
+ handlestderr h = unlessM (hIsEOF h) $ do
+ stderrHandler oh =<< hGetLine h
+ handlestderr h
+
+{- Runs a command, that may display one or more progress meters on
+ - either stdout or stderr, and prevents the meters from being displayed.
+ -
+ - The other command output is handled as configured by the OutputHandler.
+ -}
+demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool
+demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
+
+demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+demeterCommandEnv oh cmd params environ = outputFilter cmd params environ
+ (\outh -> avoidProgress True outh stdouthandler)
+ (\errh -> avoidProgress True errh $ stderrHandler oh)
+ where
+ stdouthandler l =
+ unless (quietMode oh) $
+ putStrLn l
+
+{- To suppress progress output, while displaying other messages,
+ - filter out lines that contain \r (typically used to reset to the
+ - beginning of the line when updating a progress display).
+ -}
+avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO ()
+avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do
+ s <- hGetLine h
+ unless (doavoid && '\r' `elem` s) $
+ emitter s
+ avoidProgress doavoid h emitter
+
+outputFilter
+ :: FilePath
+ -> [CommandParam]
+ -> Maybe [(String, String)]
+ -> (Handle -> IO ())
+ -> (Handle -> IO ())
+ -> IO Bool
+outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do
+ (_, Just outh, Just errh, pid) <- createProcess p
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ void $ async $ tryIO (outfilter outh) >> hClose outh
+ void $ async $ tryIO (errfilter errh) >> hClose errh
+ ret <- checkSuccessProcess pid
+ return ret
+ where
+ p = (proc cmd (toCommand params))
+ { env = environ }
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 949f41e..ebb4257 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -1,28 +1,30 @@
{- misc utility functions
-
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc where
+import Utility.FileSystemEncoding
+import Utility.Monad
+
import System.IO
import Control.Monad
import Foreign
import Data.Char
import Data.List
-import Control.Applicative
import System.Exit
#ifndef mingw32_HOST_OS
import System.Posix.Process (getAnyProcessStatus)
import Utility.Exception
#endif
-
-import Utility.FileSystemEncoding
-import Utility.Monad
+import Control.Applicative
+import Prelude
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
@@ -134,7 +136,7 @@ hGetSomeString h sz = do
- if this reap gets there first. -}
reapZombies :: IO ()
#ifndef mingw32_HOST_OS
-reapZombies = do
+reapZombies =
-- throws an exception when there are no child processes
catchDefaultIO Nothing (getAnyProcessStatus False True)
>>= maybe (return ()) (const reapZombies)
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index eba3c42..ac75104 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -1,10 +1,12 @@
{- monadic stuff
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
module Utility.Monad where
import Data.Maybe
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
index 6efa093..5579556 100644
--- a/Utility/PartialPrelude.hs
+++ b/Utility/PartialPrelude.hs
@@ -5,6 +5,8 @@
- them being accidentially used.
-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
module Utility.PartialPrelude where
import qualified Data.Maybe
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 9035cbc..f3290d8 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,11 +1,12 @@
{- path manipulation
-
- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE PackageImports, CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
@@ -16,19 +17,21 @@ import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
+import Prelude
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
+import Utility.Exception
#endif
import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
-{- Simplifies a path, removing any ".." or ".", and removing the trailing
- - path separator.
+{- Simplifies a path, removing any "." component, collapsing "dir/..",
+ - and removing the trailing path separator.
-
- On Windows, preserves whichever style of path separator might be used in
- the input FilePaths. This is done because some programs in Windows
@@ -47,7 +50,8 @@ simplifyPath path = dropTrailingPathSeparator $
norm c [] = reverse c
norm c (p:ps)
- | p' == ".." = norm (drop 1 c) ps
+ | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." =
+ norm (drop 1 c) ps
| p' == "." = norm c ps
| otherwise = norm (p:c) ps
where
@@ -65,7 +69,7 @@ absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)
{- On Windows, this converts the paths to unix-style, in order to run
- - MissingH's absNormPath on them. Resulting path will use / separators. -}
+ - MissingH's absNormPath on them. -}
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path
@@ -76,27 +80,29 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
todos = replace "/" "\\"
#endif
-{- Returns the parent directory of a path.
- -
- - To allow this to be easily used in loops, which terminate upon reaching the
- - top, the parent of / is "" -}
+{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
parentDir :: FilePath -> FilePath
-parentDir dir
- | null dirs = ""
- | otherwise = joinDrive drive (join s $ init dirs)
+parentDir = takeDirectory . dropTrailingPathSeparator
+
+{- Just the parent directory of a path, or Nothing if the path has no
+- parent (ie for "/" or ".") -}
+upFrom :: FilePath -> Maybe FilePath
+upFrom dir
+ | length dirs < 2 = Nothing
+ | otherwise = Just $ joinDrive drive (intercalate s $ init dirs)
where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
(drive, path) = splitDrive dir
dirs = filter (not . null) $ split s path
s = [pathSeparator]
-prop_parentDir_basics :: FilePath -> Bool
-prop_parentDir_basics dir
+prop_upFrom_basics :: FilePath -> Bool
+prop_upFrom_basics dir
| null dir = True
- | dir == "/" = parentDir dir == ""
- | otherwise = p /= dir
+ | dir == "/" = p == Nothing
+ | otherwise = p /= Just dir
where
- p = parentDir dir
+ p = upFrom dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
@@ -125,14 +131,25 @@ absPath file = do
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
+relPathCwdToFile f = do
+ c <- getCurrentDirectory
+ relPathDirToFile c f
+
+{- Constructs a relative path from a directory to a file. -}
+relPathDirToFile :: FilePath -> FilePath -> IO FilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
-{- Constructs a relative path from a directory to a file.
+{- This requires the first path to be absolute, and the
+ - second path cannot contain ../ or ./
-
- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+ - On Windows, if the paths are on different drives,
+ - a relative path is not possible and the path is simply
+ - returned as-is.
-}
-relPathDirToFile :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = join s $ dotdots ++ uncommon
+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
+relPathDirToFileAbs from to
+ | takeDrive from /= takeDrive to = to
+ | otherwise = intercalate s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
@@ -145,10 +162,11 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
+ | null from || null to = True
| from == to = null r
| otherwise = not (null r)
where
- r = relPathDirToFile from to
+ r = relPathDirToFileAbs from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
@@ -157,22 +175,31 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
- relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
+ relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
{- Given an original list of paths, and an expanded list derived from it,
- - generates a list of lists, where each sublist corresponds to one of the
- - original paths. When the original path is a directory, any items
- - in the expanded list that are contained in that directory will appear in
- - its segment.
+ - which may be arbitrarily reordered, generates a list of lists, where
+ - each sublist corresponds to one of the original paths.
+ -
+ - When the original path is a directory, any items in the expanded list
+ - that are contained in that directory will appear in its segment.
+ -
+ - The order of the original list of paths is attempted to be preserved in
+ - the order of the returned segments. However, doing so has a O^NM
+ - growth factor. So, if the original list has more than 100 paths on it,
+ - we stop preserving ordering at that point. Presumably a user passing
+ - that many paths in doesn't care too much about order of the later ones.
-}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
-segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
+segmentPaths (l:ls) new = found : segmentPaths ls rest
where
- (found, rest)=partition (l `dirContains`) new
+ (found, rest) = if length ls < 100
+ then partition (l `dirContains`) new
+ else break (\p -> not (l `dirContains` p)) new
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
@@ -186,7 +213,7 @@ relHome :: FilePath -> IO String
relHome path = do
home <- myHomeDir
return $ if dirContains home path
- then "~/" ++ relPathDirToFile home path
+ then "~/" ++ relPathDirToFileAbs home path
else path
{- Checks if a command is available in PATH.
@@ -255,11 +282,12 @@ fileNameLengthLimit :: FilePath -> IO Int
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
- l <- fromIntegral <$> getPathVar dir FileNameLimit
+ -- getPathVar can fail due to statfs(2) overflow
+ l <- catchDefaultIO 0 $
+ fromIntegral <$> getPathVar dir FileNameLimit
if l <= 0
then return 255
else return $ minimum [l, 255]
- where
#endif
{- Given a string that we'd like to use as the basis for FilePath, but that
@@ -267,7 +295,8 @@ fileNameLengthLimit dir = do
- sane FilePath.
-
- All spaces and punctuation and other wacky stuff are replaced
- - with '_', except for '.' "../" will thus turn into ".._", which is safe.
+ - with '_', except for '.'
+ - "../" will thus turn into ".._", which is safe.
-}
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
index 5abbb57..4550beb 100644
--- a/Utility/PosixFiles.hs
+++ b/Utility/PosixFiles.hs
@@ -2,12 +2,13 @@
-
- This is like System.PosixCompat.Files, except with a fixed rename.
-
- - Copyright 2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.PosixFiles (
module X,
diff --git a/Utility/Process.hs b/Utility/Process.hs
index e25618e..c669996 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -1,18 +1,20 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Process (
module X,
CreateProcess(..),
StdHandle(..),
readProcess,
+ readProcess',
readProcessEnv,
writeReadProcessEnv,
forceSuccessProcess,
@@ -24,21 +26,27 @@ module Utility.Process (
processTranscript,
processTranscript',
withHandle,
- withBothHandles,
+ withIOHandles,
+ withOEHandles,
withQuietOutput,
+ feedWithQuietOutput,
createProcess,
+ waitForProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
stderrHandle,
- bothHandles,
+ ioHandles,
processHandle,
devNull,
) where
-import qualified System.Process
-import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
-import System.Process hiding (createProcess, readProcess)
+import qualified Utility.Process.Shim
+import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess)
+import Utility.Misc
+import Utility.Exception
+
import System.Exit
import System.IO
import System.Log.Logger
@@ -46,40 +54,39 @@ import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
#ifndef mingw32_HOST_OS
-import System.Posix.IO
+import qualified System.Posix.IO
#else
import Control.Applicative
#endif
import Data.Maybe
-
-import Utility.Misc
-import Utility.Exception
+import Prelude
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
-{- Normally, when reading from a process, it does not need to be fed any
- - standard input. -}
+-- | Normally, when reading from a process, it does not need to be fed any
+-- standard input.
readProcess :: FilePath -> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
-readProcessEnv cmd args environ =
- withHandle StdoutHandle createProcessSuccess p $ \h -> do
- output <- hGetContentsStrict h
- hClose h
- return output
+readProcessEnv cmd args environ = readProcess' p
where
p = (proc cmd args)
{ std_out = CreatePipe
, env = environ
}
-{- Runs an action to write to a process on its stdin,
- - returns its output, and also allows specifying the environment.
- -}
+readProcess' :: CreateProcess -> IO String
+readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+
+-- | Runs an action to write to a process on its stdin,
+-- returns its output, and also allows specifying the environment.
writeReadProcessEnv
:: FilePath
-> [String]
@@ -119,8 +126,8 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
, env = environ
}
-{- Waits for a ProcessHandle, and throws an IOError if the process
- - did not exit successfully. -}
+-- | Waits for a ProcessHandle, and throws an IOError if the process
+-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
forceSuccessProcess p pid = do
code <- waitForProcess pid
@@ -128,10 +135,10 @@ forceSuccessProcess p pid = do
ExitSuccess -> return ()
ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
-{- Waits for a ProcessHandle and returns True if it exited successfully.
- - Note that using this with createProcessChecked will throw away
- - the Bool, and is only useful to ignore the exit code of a process,
- - while still waiting for it. -}
+-- | Waits for a ProcessHandle and returns True if it exited successfully.
+-- Note that using this with createProcessChecked will throw away
+-- the Bool, and is only useful to ignore the exit code of a process,
+-- while still waiting for it. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
code <- waitForProcess pid
@@ -142,13 +149,13 @@ ignoreFailureProcess pid = do
void $ waitForProcess pid
return True
-{- Runs createProcess, then an action on its handles, and then
- - forceSuccessProcess. -}
+-- | Runs createProcess, then an action on its handles, and then
+-- forceSuccessProcess.
createProcessSuccess :: CreateProcessRunner
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
-{- Runs createProcess, then an action on its handles, and then
- - a checker action on its exit code, which must wait for the process. -}
+-- | Runs createProcess, then an action on its handles, and then
+-- a checker action on its exit code, which must wait for the process.
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
createProcessChecked checker p a = do
t@(_, _, _, pid) <- createProcess p
@@ -156,31 +163,30 @@ createProcessChecked checker p a = do
_ <- checker pid
either E.throw return r
-{- Leaves the process running, suitable for lazy streaming.
- - Note: Zombies will result, and must be waited on. -}
+-- | Leaves the process running, suitable for lazy streaming.
+-- Note: Zombies will result, and must be waited on.
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
-{- Runs a process, optionally feeding it some input, and
- - returns a transcript combining its stdout and stderr, and
- - whether it succeeded or failed. -}
+-- | Runs a process, optionally feeding it some input, and
+-- returns a transcript combining its stdout and stderr, and
+-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+processTranscript = processTranscript' id
-processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
-processTranscript' cmd opts environ input = do
+processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)
+processTranscript' modproc cmd opts input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
- the process writes them. -}
- (readf, writef) <- createPipe
- readh <- fdToHandle readf
- writeh <- fdToHandle writef
- p@(_, _, _, pid) <- createProcess $
+ (readf, writef) <- System.Posix.IO.createPipe
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $ modproc $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit
, std_out = UseHandle writeh
, std_err = UseHandle writeh
- , env = environ
}
hClose writeh
@@ -192,12 +198,11 @@ processTranscript' cmd opts environ input = do
return (transcript, ok)
#else
{- This implementation for Windows puts stderr after stdout. -}
- p@(_, _, _, pid) <- createProcess $
+ p@(_, _, _, pid) <- createProcess $ modproc $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit
, std_out = CreatePipe
, std_err = CreatePipe
- , env = environ
}
getout <- mkreader (stdoutHandle p)
@@ -227,9 +232,9 @@ processTranscript' cmd opts environ input = do
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. -}
+-- | 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.
withHandle
:: StdHandle
-> CreateProcessRunner
@@ -251,13 +256,13 @@ withHandle h creator p a = creator p' $ a . select
| h == StderrHandle =
(stderrHandle, base { std_err = CreatePipe })
-{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
-withBothHandles
+-- | Like withHandle, but passes (stdin, stdout) handles to the action.
+withIOHandles
:: CreateProcessRunner
-> CreateProcess
-> ((Handle, Handle) -> IO a)
-> IO a
-withBothHandles creator p a = creator p' $ a . bothHandles
+withIOHandles creator p a = creator p' $ a . ioHandles
where
p' = p
{ std_in = CreatePipe
@@ -265,8 +270,22 @@ withBothHandles creator p a = creator p' $ a . bothHandles
, std_err = Inherit
}
-{- Forces the CreateProcessRunner to run quietly;
- - both stdout and stderr are discarded. -}
+-- | Like withHandle, but passes (stdout, stderr) handles to the action.
+withOEHandles
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> ((Handle, Handle) -> IO a)
+ -> IO a
+withOEHandles creator p a = creator p' $ a . oeHandles
+ where
+ p' = p
+ { std_in = Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+-- | Forces the CreateProcessRunner to run quietly;
+-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
@@ -278,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
}
creator p' $ const $ return ()
+-- | Stdout and stderr are discarded, while the process is fed stdin
+-- from the handle.
+feedWithQuietOutput
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> (Handle -> IO a)
+ -> IO a
+feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do
+ let p' = p
+ { std_in = CreatePipe
+ , std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ creator p' $ a . stdinHandle
+
devNull :: FilePath
#ifndef mingw32_HOST_OS
devNull = "/dev/null"
@@ -285,11 +319,11 @@ devNull = "/dev/null"
devNull = "NUL"
#endif
-{- Extract a desired handle from createProcess's tuple.
- - These partial functions are safe as long as createProcess is run
- - with appropriate parameters to set up the desired handle.
- - Get it wrong and the runtime crash will always happen, so should be
- - easily noticed. -}
+-- | Extract a desired handle from createProcess's tuple.
+-- These partial functions are safe as long as createProcess is run
+-- with appropriate parameters to set up the desired handle.
+-- Get it wrong and the runtime crash will always happen, so should be
+-- easily noticed.
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
stdinHandle :: HandleExtractor
stdinHandle (Just h, _, _, _) = h
@@ -300,38 +334,25 @@ stdoutHandle _ = error "expected stdoutHandle"
stderrHandle :: HandleExtractor
stderrHandle (_, _, Just h, _) = h
stderrHandle _ = error "expected stderrHandle"
-bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
-bothHandles (Just hin, Just hout, _, _) = (hin, hout)
-bothHandles _ = error "expected bothHandles"
+ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+ioHandles (Just hin, Just hout, _, _) = (hin, hout)
+ioHandles _ = error "expected ioHandles"
+oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+oeHandles (_, Just hout, Just herr, _) = (hout, herr)
+oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
-{- Debugging trace for a CreateProcess. -}
-debugProcess :: CreateProcess -> IO ()
-debugProcess p = do
- debugM "Utility.Process" $ unwords
- [ action ++ ":"
- , showCmd p
- ]
- where
- action
- | piped (std_in p) && piped (std_out p) = "chat"
- | piped (std_in p) = "feed"
- | piped (std_out p) = "read"
- | otherwise = "call"
- piped Inherit = False
- piped _ = True
-
-{- Shows the command that a CreateProcess will run. -}
+-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
where
go (ShellCommand s) = s
go (RawCommand c ps) = c ++ " " ++ show ps
-{- Starts an interactive process. Unlike runInteractiveProcess in
- - System.Process, stderr is inherited. -}
+-- | Starts an interactive process. Unlike runInteractiveProcess in
+-- System.Process, stderr is inherited.
startInteractiveProcess
:: FilePath
-> [String]
@@ -347,8 +368,30 @@ startInteractiveProcess cmd args environ = do
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
-{- Wrapper around System.Process function that does debug logging. -}
+-- | Wrapper around 'System.Process.createProcess' that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p
- System.Process.createProcess p
+ Utility.Process.Shim.createProcess p
+
+-- | Debugging trace for a CreateProcess.
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.
+waitForProcess :: ProcessHandle -> IO ExitCode
+waitForProcess h = do
+ r <- Utility.Process.Shim.waitForProcess h
+ debugM "Utility.Process" ("process done " ++ show r)
+ return r
diff --git a/Utility/Process/Shim.hs b/Utility/Process/Shim.hs
new file mode 100644
index 0000000..09312c7
--- /dev/null
+++ b/Utility/Process/Shim.hs
@@ -0,0 +1,3 @@
+module Utility.Process.Shim (module X) where
+
+import System.Process as X
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index a498ee6..cd408dd 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -1,6 +1,6 @@
{- QuickCheck with additional instances
-
- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -19,6 +19,7 @@ import System.Posix.Types
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Applicative
+import Prelude
instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
arbitrary = M.fromList <$> arbitrary
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 8dee609..3aaf928 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -1,10 +1,12 @@
{- various rsync stuff
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# LANGUAGE CPP #-}
+
module Utility.Rsync where
import Common
@@ -42,7 +44,8 @@ rsyncServerParams =
-- allow resuming of transfers of big files
, Param "--inplace"
-- other options rsync normally uses in server mode
- , Params "-e.Lsf ."
+ , Param "-e.Lsf"
+ , Param "."
]
rsyncUseDestinationPermissions :: CommandParam
@@ -53,37 +56,18 @@ rsync = boolSystem "rsync" . rsyncParamsFixup
{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted
- paths to files. (It thinks that C:foo refers to a host named "C").
- - Fix up all Files in the Params appropriately. -}
+ - Fix up the Params appropriately. -}
rsyncParamsFixup :: [CommandParam] -> [CommandParam]
+#ifdef mingw32_HOST_OS
rsyncParamsFixup = map fixup
where
fixup (File f) = File (toCygPath f)
+ fixup (Param s)
+ | rsyncUrlIsPath s = Param (toCygPath s)
fixup p = p
-
-{- Runs rsync, but intercepts its progress output and updates a meter.
- - The progress output is also output to stdout.
- -
- - The params must enable rsync's --progress mode for this to work.
- -}
-rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
-rsyncProgress meterupdate params = catchBoolIO $
- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])
- where
- p = proc "rsync" (toCommand $ rsyncParamsFixup params)
- feedprogress prev buf h = do
- s <- hGetSomeString h 80
- if null s
- then return True
- else do
- putStr s
- hFlush stdout
- let (mbytes, buf') = parseRsyncProgress (buf++s)
- case mbytes of
- Nothing -> feedprogress prev buf' h
- (Just bytes) -> do
- when (bytes /= prev) $
- meterupdate $ toBytesProcessed bytes
- feedprogress bytes buf' h
+#else
+rsyncParamsFixup = id
+#endif
{- Checks if an rsync url involves the remote shell (ssh or rsh).
- Use of such urls with rsync requires additional shell
@@ -103,17 +87,21 @@ rsyncUrlIsShell s
{- Checks if a rsync url is really just a local path. -}
rsyncUrlIsPath :: String -> Bool
rsyncUrlIsPath s
+#ifdef mingw32_HOST_OS
+ | not (null (takeDrive s)) = True
+#endif
| rsyncUrlIsShell s = False
| otherwise = ':' `notElem` s
-{- Parses the String looking for rsync progress output, and returns
- - Maybe the number of bytes rsynced so far, and any any remainder of the
- - string that could be an incomplete progress output. That remainder
- - should be prepended to future output, and fed back in. This interface
- - allows the output to be read in any desired size chunk, or even one
- - character at a time.
+{- Runs rsync, but intercepts its progress output and updates a progress
+ - meter.
-
- - Strategy: Look for chunks prefixed with \r (rsync writes a \r before
+ - The params must enable rsync's --progress mode for this to work.
+ -}
+rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool
+rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup
+
+{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before
- the first progress output, and each thereafter). The first number
- after the \r is the number of bytes processed. After the number,
- there must appear some whitespace, or we didn't get the whole number,
@@ -122,20 +110,23 @@ rsyncUrlIsPath s
- In some locales, the number will have one or more commas in the middle
- of it.
-}
-parseRsyncProgress :: String -> (Maybe Integer, String)
+parseRsyncProgress :: ProgressParser
parseRsyncProgress = go [] . reverse . progresschunks
where
go remainder [] = (Nothing, remainder)
go remainder (x:xs) = case parsebytes (findbytesstart x) of
Nothing -> go (delim:x++remainder) xs
- Just b -> (Just b, remainder)
+ Just b -> (Just (toBytesProcessed b), remainder)
delim = '\r'
+
{- Find chunks that each start with delim.
- The first chunk doesn't start with it
- (it's empty when delim is at the start of the string). -}
progresschunks = drop 1 . split [delim]
findbytesstart s = dropWhile isSpace s
+
+ parsebytes :: String -> Maybe Integer
parsebytes s = case break isSpace s of
([], _) -> Nothing
(_, []) -> Nothing
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index 86e60db..5ce17a8 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -1,84 +1,94 @@
{- safely running shell commands
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
module Utility.SafeCommand where
import System.Exit
import Utility.Process
import Data.String.Utils
-import Control.Applicative
import System.FilePath
import Data.Char
+import Data.List
+import Control.Applicative
+import Prelude
-{- A type for parameters passed to a shell command. A command can
- - be passed either some Params (multiple parameters can be included,
- - whitespace-separated, or a single Param (for when parameters contain
- - whitespace), or a File.
- -}
-data CommandParam = Params String | Param String | File FilePath
+-- | Parameters that can be passed to a shell command.
+data CommandParam
+ = Param String -- ^ A parameter
+ | File FilePath -- ^ The name of a file
deriving (Eq, Show, Ord)
-{- Used to pass a list of CommandParams to a function that runs
- - a command and expects Strings. -}
+-- | Used to pass a list of CommandParams to a function that runs
+-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
-toCommand = concatMap unwrap
+toCommand = map unwrap
where
- unwrap (Param s) = [s]
- unwrap (Params s) = filter (not . null) (split " " s)
+ unwrap (Param s) = s
-- Files that start with a non-alphanumeric that is not a path
-- separator are modified to avoid the command interpreting them as
-- options or other special constructs.
unwrap (File s@(h:_))
- | isAlphaNum h || h `elem` pathseps = [s]
- | otherwise = ["./" ++ s]
- unwrap (File s) = [s]
+ | isAlphaNum h || h `elem` pathseps = s
+ | otherwise = "./" ++ s
+ unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"
-{- Run a system command, and returns True or False
- - if it succeeded or failed.
- -}
+-- | Run a system command, and returns True or False if it succeeded or failed.
+--
+-- This and other command running functions in this module log the commands
+-- run at debug level, using System.Log.Logger.
boolSystem :: FilePath -> [CommandParam] -> IO Bool
-boolSystem command params = boolSystemEnv command params Nothing
+boolSystem command params = boolSystem' command params id
-boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
-boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
+boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool
+boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess
where
dispatch ExitSuccess = True
dispatch _ = False
-{- Runs a system command, returning the exit status. -}
+boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+boolSystemEnv command params environ = boolSystem' command params $
+ \p -> p { env = environ }
+
+-- | Runs a system command, returning the exit status.
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
-safeSystem command params = safeSystemEnv command params Nothing
+safeSystem command params = safeSystem' command params id
-safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
-safeSystemEnv command params environ = do
- (_, _, _, pid) <- createProcess (proc command $ toCommand params)
- { env = environ }
+safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode
+safeSystem' command params mkprocess = do
+ (_, _, _, pid) <- createProcess p
waitForProcess pid
+ where
+ p = mkprocess $ proc command (toCommand params)
+
+safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
+safeSystemEnv command params environ = safeSystem' command params $
+ \p -> p { env = environ }
-{- Wraps a shell command line inside sh -c, allowing it to be run in a
- - login shell that may not support POSIX shell, eg csh. -}
+-- | Wraps a shell command line inside sh -c, allowing it to be run in a
+-- login shell that may not support POSIX shell, eg csh.
shellWrap :: String -> String
shellWrap cmdline = "sh -c " ++ shellEscape cmdline
-{- Escapes a filename or other parameter to be safely able to be exposed to
- - the shell.
- -
- - This method works for POSIX shells, as well as other shells like csh.
- -}
+-- | Escapes a filename or other parameter to be safely able to be exposed to
+-- the shell.
+--
+-- This method works for POSIX shells, as well as other shells like csh.
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
- escaped = join "'\"'\"'" $ split "'" f
+ escaped = intercalate "'\"'\"'" $ split "'" f
-{- Unescapes a set of shellEscaped words or filenames. -}
+-- | Unescapes a set of shellEscaped words or filenames.
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
@@ -95,25 +105,32 @@ shellUnEscape s = word : shellUnEscape rest
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
-{- For quickcheck. -}
-prop_idempotent_shellEscape :: String -> Bool
-prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
-prop_idempotent_shellEscape_multiword :: [String] -> Bool
-prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
+-- | For quickcheck.
+prop_isomorphic_shellEscape :: String -> Bool
+prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s
+prop_isomorphic_shellEscape_multiword :: [String] -> Bool
+prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
+
+-- | Segments a list of filenames into groups that are all below the maximum
+-- command-line length limit.
+segmentXargsOrdered :: [FilePath] -> [[FilePath]]
+segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
-{- Segements a list of filenames into groups that are all below the manximum
- - command-line length limit. Does not preserve order. -}
-segmentXargs :: [FilePath] -> [[FilePath]]
-segmentXargs l = go l [] 0 []
+-- | Not preserving order is a little faster, and streams better when
+-- there are a great many filenames.
+segmentXargsUnordered :: [FilePath] -> [[FilePath]]
+segmentXargsUnordered l = go l [] 0 []
where
- go [] c _ r = c:r
+ go [] c _ r = (c:r)
go (f:fs) c accumlen r
- | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
+ | newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r)
| otherwise = go fs (f:c) newlen r
where
len = length f
newlen = accumlen + len
- {- 10k of filenames per command, well under Linux's 20k limit;
- - allows room for other parameters etc. -}
+ {- 10k of filenames per command, well under 100k limit
+ - of Linux (and OSX has a similar limit);
+ - allows room for other parameters etc. Also allows for
+ - eg, multibyte characters. -}
maxlen = 10240
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index e6a81ae..da05e99 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -1,6 +1,6 @@
{- thread scheduling
-
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- Copyright 2011 Bas van Dijk & Roel van Dijk
-
- License: BSD-2-clause
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index edd82f5..7610f6c 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,11 +1,12 @@
{- Temporary files and directories.
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp where
@@ -14,6 +15,9 @@ import System.Directory
import Control.Monad.IfElse
import System.FilePath
import Control.Monad.IO.Class
+#ifndef mingw32_HOST_OS
+import System.Posix.Temp (mkdtemp)
+#endif
import Utility.Exception
import Utility.FileSystemEncoding
@@ -24,8 +28,8 @@ type Template = String
{- Runs an action like writeFile, writing to a temp file first and
- 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 = bracket setup cleanup use
+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()
+viaTmp a file content = bracketIO setup cleanup use
where
(dir, base) = splitFileName file
template = base ++ ".tmp"
@@ -36,9 +40,9 @@ viaTmp a file content = bracket setup cleanup use
_ <- tryIO $ hClose h
tryIO $ removeFile tmpfile
use (tmpfile, h) = do
- hClose h
+ liftIO $ hClose h
a tmpfile content
- rename tmpfile file
+ liftIO $ 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. -}
@@ -61,34 +65,47 @@ withTmpFileIn tmpdir template a = bracket create remove use
{- Runs an action with a tmp directory located within the system's tmp
- directory (or within "." if there is none), then removes the tmp
- directory and all its contents. -}
-withTmpDir :: Template -> (FilePath -> IO a) -> IO a
+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
withTmpDir template a = do
- tmpdir <- catchDefaultIO "." getTemporaryDirectory
- withTmpDirIn tmpdir template a
+ topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
+#ifndef mingw32_HOST_OS
+ -- Use mkdtemp to create a temp directory securely in /tmp.
+ bracket
+ (liftIO $ mkdtemp $ topleveltmpdir </> template)
+ removeTmpDir
+ a
+#else
+ withTmpDirIn topleveltmpdir template a
+#endif
{- Runs an action with a tmp directory located within a specified directory,
- then removes the tmp directory and all its contents. -}
-withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
-withTmpDirIn tmpdir template = bracket create remove
+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn tmpdir template = bracketIO create removeTmpDir
where
- remove d = whenM (doesDirectoryExist d) $ do
-#if mingw32_HOST_OS
- -- Windows will often refuse to delete a file
- -- after a process has just written to it and exited.
- -- Because it's crap, presumably. So, ignore failure
- -- to delete the temp directory.
- _ <- tryIO $ removeDirectoryRecursive d
- return ()
-#else
- removeDirectoryRecursive d
-#endif
create = do
createDirectoryIfMissing True tmpdir
makenewdir (tmpdir </> template) (0 :: Int)
makenewdir t n = do
let dir = t ++ "." ++ show n
- either (const $ makenewdir t $ n + 1) (const $ return dir)
- =<< tryIO (createDirectory dir)
+ catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
+ createDirectory dir
+ return dir
+
+{- Deletes the entire contents of the the temporary directory, if it
+ - exists. -}
+removeTmpDir :: MonadIO m => FilePath -> m ()
+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive tmpdir
+ return ()
+#else
+ removeDirectoryRecursive tmpdir
+#endif
{- It's not safe to use a FilePath of an existing file as the template
- for openTempFile, because if the FilePath is really long, the tmpfile
diff --git a/Utility/URI.hs b/Utility/URI.hs
index 30c6be3..e68fda5 100644
--- a/Utility/URI.hs
+++ b/Utility/URI.hs
@@ -1,6 +1,6 @@
{- Network.URI
-
- - Copyright 2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 617c3e9..7e94caf 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -1,11 +1,12 @@
{- user info
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.UserInfo (
myHomeDir,
@@ -13,11 +14,14 @@ module Utility.UserInfo (
myUserGecos,
) where
-import Control.Applicative
-import System.PosixCompat
-
import Utility.Env
+import System.PosixCompat
+#ifndef mingw32_HOST_OS
+import Control.Applicative
+#endif
+import Prelude
+
{- Current user's home directory.
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
@@ -40,16 +44,20 @@ myUserName = myVal env userName
env = ["USERNAME", "USER", "LOGNAME"]
#endif
-myUserGecos :: IO String
-#ifdef __ANDROID__
-myUserGecos = return "" -- userGecos crashes on Android
+myUserGecos :: IO (Maybe String)
+-- userGecos crashes on Android and is not available on Windows.
+#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
+myUserGecos = return Nothing
#else
-myUserGecos = myVal [] userGecos
+myUserGecos = Just <$> myVal [] userGecos
#endif
myVal :: [String] -> (UserEntry -> String) -> IO String
-myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
+myVal envvars extract = go envvars
where
- check [] = return Nothing
- check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
- getpwent = getUserEntryForID =<< getEffectiveUserID
+#ifndef mingw32_HOST_OS
+ go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
+#else
+ go [] = error $ "environment not set: " ++ show envvars
+#endif
+ go (v:vs) = maybe (go vs) return =<< getEnv v
diff --git a/debian/changelog b/debian/changelog
index c6bce87..9b2e1e4 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,40 @@
+git-repair (1.20151215-1) unstable; urgency=medium
+
+ * Package 1.20151215-1
+
+ -- Richard Hartmann <richih@debian.org> Wed, 16 Dec 2015 07:26:04 +0100
+
+git-repair (1.20151215) unstable; urgency=medium
+
+ * Fix insecure temporary permissions and potential denial of
+ service attack when creating temp dirs. Closes: #807341
+ * Merge from git-annex.
+
+ -- Joey Hess <id@joeyh.name> Tue, 15 Dec 2015 20:47:59 -0400
+
+git-repair (1.20150106-2) unstable; urgency=medium
+
+ * Fix typo in description
+
+ -- Richard Hartmann <richih@debian.org> Thu, 20 Aug 2015 13:41:50 +0200
+
+git-repair (1.20150106-1) unstable; urgency=medium
+
+ * Package 1.20150106
+ * Update dependencies (Closes: #789977)
+ * Take over maintenance of package
+ * Bump standards version to 3.9.6
+
+ -- Richard Hartmann <richih@debian.org> Thu, 20 Aug 2015 11:24:46 +0200
+
+git-repair (1.20150106) unstable; urgency=medium
+
+ * Debian package is now maintained by Richard Hartmann.
+ * Fix build with process 1.2.1.0.
+ * Merge from git-annex.
+
+ -- Joey Hess <id@joeyh.name> Tue, 06 Jan 2015 19:09:23 -0400
+
git-repair (1.20141027) unstable; urgency=medium
* Adjust cabal file to support network-uri split.
diff --git a/debian/control b/debian/control
index 42363e2..e1bd4ef 100644
--- a/debian/control
+++ b/debian/control
@@ -16,9 +16,10 @@ Build-Depends:
libghc-quickcheck2-dev,
libghc-utf8-string-dev,
libghc-async-dev,
- libghc-optparse-applicative-dev (>= 0.10.0)
-Maintainer: Joey Hess <joeyh@debian.org>
-Standards-Version: 3.9.5
+ libghc-optparse-applicative-dev (>= 0.10.0),
+ libghc-network-uri-dev
+Maintainer: Richard Hartmann <richih@debian.org>
+Standards-Version: 3.9.6
Vcs-Git: git://git-repair.branchable.com/
Homepage: http://git-repair.branchable.com/
@@ -26,7 +27,7 @@ Package: git-repair
Architecture: any
Section: utils
Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync
-Description: repair various forms of damage to git repositorie
+Description: repair various forms of damage to git repositories
git-repair can repair various forms of damage to git repositories.
.
It is a complement to git fsck, which finds problems, but does not fix them.
diff --git a/debian/gbp.conf b/debian/gbp.conf
new file mode 100644
index 0000000..73ec349
--- /dev/null
+++ b/debian/gbp.conf
@@ -0,0 +1,10 @@
+[DEFAULT]
+upstream-branch = master
+debian-branch = debian
+upstream-tag = %(version)s
+debian-tag = debian/%(version)s
+
+postbuild = lintian $GBP_CHANGES_FILE
+color = on
+compression = xz
+compression-level = 9
diff --git a/debian/git-repair.lintian-overrides b/debian/git-repair.lintian-overrides
new file mode 100644
index 0000000..25d3d4c
--- /dev/null
+++ b/debian/git-repair.lintian-overrides
@@ -0,0 +1 @@
+binary-or-shlib-defines-rpath
diff --git a/debian/source/format b/debian/source/format
new file mode 100644
index 0000000..163aaf8
--- /dev/null
+++ b/debian/source/format
@@ -0,0 +1 @@
+3.0 (quilt)
diff --git a/doc/index.mdwn b/doc/index.mdwn
index a6778ed..503c2c2 100644
--- a/doc/index.mdwn
+++ b/doc/index.mdwn
@@ -49,3 +49,7 @@ tags.
Since this command unpacks all packs in the repository, you may want to
run `git gc` afterwards.
+
+## news
+
+[[!inline pages="news/* and !*/Discussion" show="4" archive=yes]]
diff --git a/doc/news/version_1.20141027.mdwn b/doc/news/version_1.20141027.mdwn
new file mode 100644
index 0000000..b65c652
--- /dev/null
+++ b/doc/news/version_1.20141027.mdwn
@@ -0,0 +1 @@
+git-repair 1.20140613 released
diff --git a/git-repair.cabal b/git-repair.cabal
index c63e803..d4583ea 100644
--- a/git-repair.cabal
+++ b/git-repair.cabal
@@ -1,5 +1,5 @@
Name: git-repair
-Version: 1.20141027
+Version: 1.20151215
Cabal-Version: >= 1.8
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@@ -28,7 +28,7 @@ Flag network-uri
Executable git-repair
Main-Is: git-repair.hs
- GHC-Options: -Wall -threaded
+ GHC-Options: -threaded -Wall -fno-warn-tabs
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,