summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Git.hs8
-rw-r--r--Git/Branch.hs7
-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.hs21
-rw-r--r--Git/CurrentRepo.hs6
-rw-r--r--Git/DiffTreeItem.hs2
-rw-r--r--Git/FilePath.hs5
-rw-r--r--Git/Filename.hs2
-rw-r--r--Git/Fsck.hs2
-rw-r--r--Git/Index.hs2
-rw-r--r--Git/LsFiles.hs19
-rw-r--r--Git/LsTree.hs2
-rw-r--r--Git/Objects.hs2
-rw-r--r--Git/Ref.hs5
-rw-r--r--Git/RefLog.hs19
-rw-r--r--Git/Remote.hs2
-rw-r--r--Git/Repair.hs15
-rw-r--r--Git/Sha.hs2
-rw-r--r--Git/Types.hs2
-rw-r--r--Git/UpdateIndex.hs2
-rw-r--r--Git/Url.hs2
-rw-r--r--Git/Version.hs2
-rw-r--r--Utility/Applicative.hs2
-rw-r--r--Utility/Batch.hs2
-rw-r--r--Utility/CoProcess.hs2
-rw-r--r--Utility/Data.hs2
-rw-r--r--Utility/Directory.hs4
-rw-r--r--Utility/DottedVersion.hs2
-rw-r--r--Utility/Env.hs2
-rw-r--r--Utility/Exception.hs2
-rw-r--r--Utility/FileMode.hs12
-rw-r--r--Utility/FileSystemEncoding.hs19
-rw-r--r--Utility/Format.hs2
-rw-r--r--Utility/Metered.hs93
-rw-r--r--Utility/Misc.hs2
-rw-r--r--Utility/Monad.hs2
-rw-r--r--Utility/Path.hs73
-rw-r--r--Utility/PosixFiles.hs2
-rw-r--r--Utility/Process.hs48
-rw-r--r--Utility/QuickCheck.hs2
-rw-r--r--Utility/Rsync.hs10
-rw-r--r--Utility/SafeCommand.hs25
-rw-r--r--Utility/ThreadScheduler.hs2
-rw-r--r--Utility/Tmp.hs2
-rw-r--r--Utility/URI.hs2
-rw-r--r--Utility/UserInfo.hs2
-rw-r--r--debian/changelog6
50 files changed, 330 insertions, 155 deletions
diff --git a/Git.hs b/Git.hs
index c9750a3..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.
-}
@@ -60,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
@@ -70,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. -}
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 5c6135d..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,15 +37,12 @@ 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
| otherwise = Just $ Git.Ref l
-currentSha :: Repo -> IO (Maybe Git.Sha)
-currentSha r = maybe (pure Nothing) (`Git.Ref.sha` r) =<< current r
-
{- Checks if the second branch has any commits not present on the first
- branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool
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 3c6013a..5b20605 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
+ Nothing -> case upFrom dir of
Nothing -> return Nothing
Just d -> seekUp d
- Just loc -> Just <$> newFrom loc
+ Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
@@ -62,7 +62,7 @@ fromAbsPath dir
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
- ret = newFrom . LocalUnknown
+ ret = pure . newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir
@@ -90,13 +90,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 +153,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 +223,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 +234,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/DiffTreeItem.hs b/Git/DiffTreeItem.hs
index 2389b69..859f590 100644
--- a/Git/DiffTreeItem.hs
+++ b/Git/DiffTreeItem.hs
@@ -1,6 +1,6 @@
{- git diff-tree item
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
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..382eb8d 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.
-}
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 7145bb9..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.
-}
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 2aa05ba..e80c1b2 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.
-}
@@ -131,9 +131,9 @@ 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"]
suffix = Param "--" : (if null l then [File "."] else map File l)
@@ -181,12 +181,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..7ef9518 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.
-}
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..7c20047 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,14 @@ 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 = get' []
+
+get' :: [CommandParam] -> Branch -> Repo -> IO [Sha]
+get' ps b = mapMaybe extractSha . lines <$$> pipeReadStrict ps'
+ where
+ ps' =
+ [ Param "log"
+ , Param "-g"
+ , Param "--format=%H"
+ , Param (fromRef b)
+ ] ++ ps
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 156e308..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.
-}
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 5731138..2557e3b 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.
-}
@@ -225,10 +225,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
@@ -241,7 +244,7 @@ explodePackedRefsFile r = do
where
makeref (sha, ref) = do
let dest = localGitDir r </> fromRef ref
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
unlessM (doesFileExist dest) $
writeFile dest (fromRef sha)
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 613596d..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.
-}
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 73ce2f8..ecd1244 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -1,6 +1,6 @@
{- 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.
-}
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..5ecd218 100644
--- a/Utility/Data.hs
+++ b/Utility/Data.hs
@@ -1,6 +1,6 @@
{- utilities for simple data types
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index e4e4b80..2e037fd 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,6 +1,6 @@
{- directory traversal and manipulation
-
- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -111,7 +111,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
-- But, mv will move into a directory if
-- dest is one, which is not desired.
whenM (isdir dest) rethrow
- viaTmp mv dest undefined
+ viaTmp mv dest ""
where
rethrow = throwM e
mv tmp _ = do
diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs
index 14aa16d..67e40ff 100644
--- a/Utility/DottedVersion.hs
+++ b/Utility/DottedVersion.hs
@@ -1,6 +1,6 @@
{- dotted versions, such as 1.0.1
-
- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Env.hs b/Utility/Env.hs
index ff6644f..fdf06d8 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -1,6 +1,6 @@
{- portable environment variables
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index ef3ab1d..ab47ae9 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,6 +1,6 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 832250b..201b845 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -1,6 +1,6 @@
{- File mode utilities.
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -124,7 +124,7 @@ withUmask _ a = a
#endif
combineModes :: [FileMode] -> FileMode
-combineModes [] = undefined
+combineModes [] = 0
combineModes [m] = m
combineModes (m:ms) = foldl unionFileModes m ms
@@ -151,7 +151,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/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index fa4b39a..139b74f 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -1,6 +1,6 @@
{- 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
-}
@@ -14,6 +14,8 @@ module Utility.FileSystemEncoding (
decodeBS,
decodeW8,
encodeW8,
+ encodeW8NUL,
+ decodeW8NUL,
truncateFilePath,
) where
@@ -25,6 +27,7 @@ import System.IO.Unsafe
import qualified Data.Hash.MD5 as MD5
import Data.Word
import Data.Bits.Utils
+import Data.List.Utils
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
@@ -89,6 +92,9 @@ decodeBS = L8.toString
- 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 +107,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 = join nul . map encodeW8 . split (s2w8 nul)
+ where
+ nul = ['\NUL']
+
+decodeW8NUL :: FilePath -> [Word8]
+decodeW8NUL = join (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..0a6f6ce 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
-}
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index e4f3b44..c34e931 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,8 @@ import System.IO.Unsafe
import Foreign.Storable (Storable(sizeOf))
import System.Posix.Types
import Data.Int
+import Data.Bits.Utils
+import Control.Concurrent.Async
{- An action that can be run repeatedly, updating it on the bytes processed.
-
@@ -142,10 +144,15 @@ defaultChunkSize :: Int
defaultChunkSize = 32 * k - chunkOverhead
where
k = 1024
- chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
+ chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific
+
+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 rsynced so far, and any any remainder of the
+ - 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
@@ -154,21 +161,23 @@ defaultChunkSize = 32 * k - chunkOverhead
type ProgressParser = String -> (Maybe BytesProcessed, String)
{- Runs a command and runs a ProgressParser on its output, in order
- - to update the meter. The command's output is also sent to stdout. -}
-commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
-commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $
- withHandle StdoutHandle createProcessSuccess p $
- feedprogress zeroBytesProcessed []
+ - 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
- p = proc cmd (toCommand params)
-
feedprogress prev buf h = do
- s <- hGetSomeString h 80
- if null s
- then return True
+ b <- S.hGetSome h 80
+ if S.null b
+ then return ()
else do
- putStr s
- hFlush stdout
+ 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
@@ -176,3 +185,55 @@ commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $
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..e4eccac 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -1,6 +1,6 @@
{- misc utility functions
-
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index eba3c42..878e0da 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -1,6 +1,6 @@
{- monadic stuff
-
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 7f03491..9f0737f 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,6 +1,6 @@
{- path manipulation
-
- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -66,7 +66,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
@@ -77,11 +77,15 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
todos = replace "/" "\\"
#endif
+{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
+parentDir :: FilePath -> FilePath
+parentDir = takeDirectory . dropTrailingPathSeparator
+
{- Just the parent directory of a path, or Nothing if the path has no
- - parent (ie for "/") -}
-parentDir :: FilePath -> Maybe FilePath
-parentDir dir
- | null dirs = Nothing
+- parent (ie for "/" or ".") -}
+upFrom :: FilePath -> Maybe FilePath
+upFrom dir
+ | length dirs < 2 = Nothing
| otherwise = Just $ joinDrive drive (join s $ init dirs)
where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
@@ -89,13 +93,13 @@ parentDir 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 == Nothing
+ | 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
@@ -124,14 +128,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 = join s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
@@ -144,10 +159,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
@@ -156,22 +172,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
@@ -185,7 +210,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.
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
index 5abbb57..5a94ead 100644
--- a/Utility/PosixFiles.hs
+++ b/Utility/PosixFiles.hs
@@ -2,7 +2,7 @@
-
- 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
-}
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 8fefaa5..cbbe8a8 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -25,14 +25,16 @@ module Utility.Process (
processTranscript,
processTranscript',
withHandle,
- withBothHandles,
+ withIOHandles,
+ withOEHandles,
withQuietOutput,
+ feedWithQuietOutput,
createProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
stderrHandle,
- bothHandles,
+ ioHandles,
processHandle,
devNull,
) where
@@ -255,12 +257,12 @@ withHandle h creator p a = creator p' $ a . select
(stderrHandle, base { std_err = CreatePipe })
{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
-withBothHandles
+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
@@ -268,6 +270,20 @@ withBothHandles creator p a = creator p' $ a . bothHandles
, std_err = Inherit
}
+{- 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
@@ -281,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"
@@ -303,9 +334,12 @@ 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
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index a498ee6..54200d3 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
-}
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index ed1eab6..4f4c4eb 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -1,6 +1,6 @@
{- various rsync stuff
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -92,13 +92,13 @@ rsyncUrlIsPath s
| rsyncUrlIsShell s = False
| otherwise = ':' `notElem` s
-{- Runs rsync, but intercepts its progress output and updates a meter.
- - The progress output is also output to stdout.
+{- Runs rsync, but intercepts its progress output and updates a progress
+ - meter.
-
- The params must enable rsync's --progress mode for this to work.
-}
-rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
-rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup
+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
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index 86e60db..f44112b 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -1,6 +1,6 @@
{- safely running shell commands
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -101,19 +101,26 @@ 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
-{- 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 []
+{- 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
+
+{- Not preserving data is a little faster, and streams better when
+ - there are a great many filesnames. -}
+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 7599cdd..dc55981 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,6 +1,6 @@
{- Temporary files and directories.
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
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 c82f040..5bf8d5c 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -1,6 +1,6 @@
{- user info
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
diff --git a/debian/changelog b/debian/changelog
index 079a10d..3e1df9a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-repair (1.20150107) UNRELEASED; urgency=medium
+
+ * Merge from git-annex.
+
+ -- Joey Hess <id@joeyh.name> Wed, 29 Apr 2015 14:59:40 -0400
+
git-repair (1.20150106) unstable; urgency=medium
* Debian package is now maintained by Gergely Nagy.