diff options
author | Richard Hartmann <richih@debian.org> | 2015-12-15 23:26:04 -0700 |
---|---|---|
committer | Richard Hartmann <richih@debian.org> | 2015-12-15 23:26:04 -0700 |
commit | d348ed3d2822a8cd4b777f74641baf040e7839e4 (patch) | |
tree | 5d46d93d0b237a213f72e1e7ada60a5fecaf2e75 | |
parent | ad444893f97ed69c4a5f070cb00a6e6cb89bb2cd (diff) | |
parent | 3b6310081cde4333494fb1271a7570fc8e5f333a (diff) | |
download | git-repair-d348ed3d2822a8cd4b777f74641baf040e7839e4.tar.gz |
Record git-repair (1.20151215-1) in archive suite sid
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 @@ -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 @@ -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. -} @@ -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 @@ -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 @@ -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 @@ -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, |