summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore3
-rw-r--r--Build/Configure.hs29
-rw-r--r--Build/TestConfig.hs4
-rw-r--r--Build/Version.hs71
-rw-r--r--CHANGELOG40
-rw-r--r--COPYRIGHT41
-rw-r--r--Common.hs4
-rw-r--r--Git.hs42
-rw-r--r--Git/Branch.hs56
-rw-r--r--Git/CatFile.hs321
-rw-r--r--Git/Command.hs70
-rw-r--r--Git/Config.hs208
-rw-r--r--Git/Construct.hs201
-rw-r--r--Git/CurrentRepo.hs45
-rw-r--r--Git/Destroyer.hs17
-rw-r--r--Git/DiffTreeItem.hs7
-rw-r--r--Git/Env.hs52
-rw-r--r--Git/FilePath.hs13
-rw-r--r--Git/Filename.hs55
-rw-r--r--Git/Fsck.hs73
-rw-r--r--Git/HashObject.hs50
-rw-r--r--Git/Index.hs22
-rw-r--r--Git/LsFiles.hs292
-rw-r--r--Git/LsTree.hs133
-rw-r--r--Git/Objects.hs34
-rw-r--r--Git/Quote.hs122
-rw-r--r--Git/Ref.hs90
-rw-r--r--Git/RefLog.hs5
-rw-r--r--Git/Remote.hs65
-rw-r--r--Git/Repair.hs220
-rw-r--r--Git/Sha.hs65
-rw-r--r--Git/Types.hs62
-rw-r--r--Git/UpdateIndex.hs94
-rw-r--r--Git/Url.hs21
-rw-r--r--Git/Version.hs2
-rw-r--r--Makefile15
-rw-r--r--Utility/Batch.hs30
-rw-r--r--Utility/CoProcess.hs1
-rw-r--r--Utility/CopyFile.hs96
-rw-r--r--Utility/Data.hs18
-rw-r--r--Utility/DataUnits.hs56
-rw-r--r--Utility/Debug.hs102
-rw-r--r--Utility/Directory.hs81
-rw-r--r--Utility/Directory/Create.hs105
-rw-r--r--Utility/DottedVersion.hs2
-rw-r--r--Utility/Env/Set.hs6
-rw-r--r--Utility/Exception.hs29
-rw-r--r--Utility/FileMode.hs75
-rw-r--r--Utility/FileSize.hs16
-rw-r--r--Utility/FileSystemEncoding.hs160
-rw-r--r--Utility/Format.hs185
-rw-r--r--Utility/HumanNumber.hs10
-rw-r--r--Utility/HumanTime.hs10
-rw-r--r--Utility/InodeCache.hs310
-rw-r--r--Utility/Metered.hs251
-rw-r--r--Utility/Misc.hs18
-rw-r--r--Utility/Monad.hs8
-rw-r--r--Utility/MoveFile.hs79
-rw-r--r--Utility/Path.hs326
-rw-r--r--Utility/Path/AbsRel.hs99
-rw-r--r--Utility/Process.hs353
-rw-r--r--Utility/Process/Transcript.hs97
-rw-r--r--Utility/QuickCheck.hs41
-rw-r--r--Utility/RawFilePath.hs125
-rw-r--r--Utility/Rsync.hs6
-rw-r--r--Utility/SafeCommand.hs55
-rw-r--r--Utility/SafeOutput.hs36
-rw-r--r--Utility/SimpleProtocol.hs151
-rw-r--r--Utility/SystemDirectory.hs2
-rw-r--r--Utility/ThreadScheduler.hs1
-rw-r--r--Utility/TimeStamp.hs58
-rw-r--r--Utility/Tmp.hs44
-rw-r--r--Utility/Tmp/Dir.hs8
-rw-r--r--Utility/Url/Parse.hs63
-rw-r--r--Utility/UserInfo.hs27
-rw-r--r--debian/changelog6
-rw-r--r--doc/index.mdwn2
-rw-r--r--doc/index/discussion.mdwn29
-rw-r--r--doc/news/version_1.20141027.mdwn1
-rw-r--r--doc/news/version_1.20151215.mdwn5
-rw-r--r--doc/news/version_1.20161111.mdwn10
-rw-r--r--doc/news/version_1.20161118.mdwn3
-rw-r--r--doc/news/version_1.20170626.mdwn5
-rw-r--r--doc/news/version_1.20200504.mdwn5
-rw-r--r--doc/news/version_1.20210111.mdwn5
-rw-r--r--doc/news/version_1.20210629.mdwn5
-rw-r--r--doc/news/version_1.20220404.mdwn3
-rw-r--r--doc/news/version_1.20230814.mdwn3
-rw-r--r--git-repair.12
-rw-r--r--git-repair.cabal34
-rw-r--r--git-repair.hs4
91 files changed, 4088 insertions, 1818 deletions
diff --git a/.gitignore b/.gitignore
index 720dded..c9453f2 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,3 +2,6 @@ Build/SysConfig
tags
git-repair
dist
+dist-newstyle
+cabal.project.local
+cabal.project.local~
diff --git a/Build/Configure.hs b/Build/Configure.hs
index 1a3527f..5682e8f 100644
--- a/Build/Configure.hs
+++ b/Build/Configure.hs
@@ -1,32 +1,33 @@
-{- Checks system configuration and generates SysConfig. -}
+{- Checks system configuration and generates Build/SysConfig. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.Configure where
-import System.Environment
-import Control.Monad.IfElse
-import Control.Applicative
-import Prelude
-
import Build.TestConfig
-import Build.Version
-import Git.Version
+import Utility.Env.Basic
+import qualified Git.Version
+
+import Control.Monad
tests :: [TestCase]
tests =
- [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)
- , TestCase "git" $ testCmd "git" "git --version >/dev/null"
+ [ TestCase "git" $ testCmd "git" "git --version >/dev/null"
, TestCase "git version" getGitVersion
]
getGitVersion :: Test
-getGitVersion = Config "gitversion" . StringConfig . show
- <$> Git.Version.installed
+getGitVersion = go =<< getEnv "FORCE_GIT_VERSION"
+ where
+ go (Just s) = return $ Config "gitversion" $ StringConfig s
+ go Nothing = do
+ v <- Git.Version.installed
+ let oldestallowed = Git.Version.normalize "2.1"
+ when (v < oldestallowed) $
+ error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)"
+ return $ Config "gitversion" $ StringConfig $ show v
run :: [TestCase] -> IO ()
run ts = do
config <- runTests ts
writeSysConfig config
- whenM (isReleaseBuild) $
- cabalSetup "git-repair.cabal"
diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs
index 2f7213f..5458612 100644
--- a/Build/TestConfig.hs
+++ b/Build/TestConfig.hs
@@ -7,7 +7,7 @@ module Build.TestConfig where
import Utility.Path
import Utility.Monad
import Utility.SafeCommand
-import Utility.Directory
+import Utility.SystemDirectory
import System.IO
import System.FilePath
@@ -97,7 +97,7 @@ searchCmd success failure cmdsparams = search cmdsparams
- the command. -}
findCmdPath :: ConfigKey -> String -> Test
findCmdPath k command = do
- ifM (inPath command)
+ ifM (inSearchPath command)
( return $ Config k $ MaybeStringConfig $ Just command
, do
r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]
diff --git a/Build/Version.hs b/Build/Version.hs
deleted file mode 100644
index d39a0fe..0000000
--- a/Build/Version.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{- Package version determination, for configure script. -}
-
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Build.Version where
-
-import Data.List
-import System.Environment
-import Data.Char
-import System.Process
-import Control.Applicative
-import Prelude
-
-import Utility.Monad
-import Utility.Exception
-import Utility.Directory
-
-type Version = String
-
-{- Set when making an official release. (Distribution vendors should set
- - this too.) -}
-isReleaseBuild :: IO Bool
-isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD")
-
-{- Version is usually based on the major version from the changelog,
- - plus the date of the last commit, plus the git rev of that commit.
- - This works for autobuilds, ad-hoc builds, etc.
- -
- - If git or a git repo is not available, or something goes wrong,
- - or this is a release build, just use the version from the changelog. -}
-getVersion :: IO Version
-getVersion = do
- changelogversion <- getChangelogVersion
- ifM (isReleaseBuild)
- ( return changelogversion
- , catchDefaultIO changelogversion $ do
- let major = takeWhile (/= '.') changelogversion
- autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh"
- [ "-c"
- , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"
- ] ""
- if null autoversion
- then return changelogversion
- else return $ concat [ major, ".", autoversion ]
- )
-
-getChangelogVersion :: IO Version
-getChangelogVersion = do
- changelog <- readFile "CHANGELOG"
- let verline = takeWhile (/= '\n') changelog
- return $ middle (words verline !! 1)
- where
- middle = drop 1 . init
-
-{- Set up cabal file with version. -}
-cabalSetup :: FilePath -> IO ()
-cabalSetup cabalfile = do
- version <- takeWhile (\c -> isDigit c || c == '.')
- <$> getChangelogVersion
- cabal <- readFile cabalfile
- writeFile tmpcabalfile $ unlines $
- map (setfield "Version" version) $
- lines cabal
- renameFile tmpcabalfile cabalfile
- where
- tmpcabalfile = cabalfile++".tmp"
- setfield field value s
- | fullfield `isPrefixOf` s = fullfield ++ value
- | otherwise = s
- where
- fullfield = field ++ ": "
diff --git a/CHANGELOG b/CHANGELOG
index 50f9332..295b8fc 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,43 @@
+git-repair (1.20230814) unstable; urgency=medium
+
+ * Merge from git-annex.
+ * Support building with unix-compat 0.7
+
+ -- Joey Hess <id@joeyh.name> Mon, 14 Aug 2023 12:14:40 -0400
+
+git-repair (1.20220404) unstable; urgency=medium
+
+ * Avoid treating refs that are not commit objects as evidence of
+ repository corruption.
+
+ -- Joey Hess <id@joeyh.name> Wed, 04 May 2022 11:43:15 -0400
+
+git-repair (1.20210629) unstable; urgency=medium
+
+ * Fixed bug that interrupting the program while it was fixing repository
+ corruption would lose objects that were contained in pack files.
+ * Fix reversion in version 1.20200504 that prevented fetching
+ missing objects from remotes.
+
+ -- Joey Hess <id@joeyh.name> Tue, 29 Jun 2021 13:29:10 -0400
+
+git-repair (1.20210111) unstable; urgency=medium
+
+ * Improve output to not give the impression it's stalled running fsck
+ when it's found a problem and is working to repair it.
+ * Merge from git-annex.
+ * Makefile: Support building with cabal 3.0.
+
+ -- Joey Hess <id@joeyh.name> Mon, 11 Jan 2021 22:00:49 -0400
+
+git-repair (1.20200504) unstable; urgency=medium
+
+ * Fix a few documentation typos.
+ * Improve fetching from a remote with an url in host:path format.
+ * Merge from git-annex.
+
+ -- Joey Hess <id@joeyh.name> Mon, 04 May 2020 15:38:53 -0400
+
git-repair (1.20200102) unstable; urgency=medium
* Relicensed AGPL.
diff --git a/COPYRIGHT b/COPYRIGHT
index cd51274..08fb2ea 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -1,14 +1,19 @@
-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Source: native package
+Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+Source: git://git-repair.branchable.com/
Files: *
-Copyright: © 2013-2019 Joey Hess <joey@kitenet.net>
+Copyright: © 2013-2022 Joey Hess <joey@kitenet.net>
License: AGPL-3+
Files: Utility/*
-Copyright: 2012-2019 Joey Hess <joey@kitenet.net>
+Copyright: 2012-2022 Joey Hess <joey@kitenet.net>
License: BSD-2-clause
+Files: Utility/Attoparsec.hs
+Copyright: (C) 2019 Joey Hess <id@joeyh.name>
+ (C) 2007-2015 Bryan O'Sullivan
+License: BSD-3-clause
+
License: BSD-2-clause
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
@@ -31,6 +36,34 @@ License: BSD-2-clause
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+License: BSD-3-clause
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+ .
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ .
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ .
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+ .
+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
License: AGPL-3+
GNU AFFERO GENERAL PUBLIC LICENSE
Version 3, 19 November 2007
diff --git a/Common.hs b/Common.hs
index 6bd2e7a..ebe6d3f 100644
--- a/Common.hs
+++ b/Common.hs
@@ -18,14 +18,16 @@ import System.IO as X hiding (FilePath)
import System.Posix.IO as X hiding (createPipe)
#endif
import System.Exit as X
-import System.PosixCompat.Files as X
+import System.PosixCompat.Files as X (FileStatus)
import Utility.Misc as X
import Utility.Exception as X
import Utility.SafeCommand as X
import Utility.Process as X
import Utility.Path as X
+import Utility.Path.AbsRel as X
import Utility.Directory as X
+import Utility.MoveFile as X
import Utility.Monad as X
import Utility.Data as X
import Utility.Applicative as X
diff --git a/Git.hs b/Git.hs
index 87a8d19..e567917 100644
--- a/Git.hs
+++ b/Git.hs
@@ -1,19 +1,21 @@
{- git repository handling
-
- - This is written to be completely independant of git-annex and should be
+ - This is written to be completely independent of git-annex and should be
- suitable for other uses.
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Git (
Repo(..),
Ref(..),
fromRef,
+ fromRef',
Branch,
Sha,
Tag,
@@ -36,10 +38,12 @@ module Git (
relPath,
) where
+import qualified Data.ByteString as B
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
+import qualified System.FilePath.ByteString as P
import Common
import Git.Types
@@ -51,6 +55,7 @@ import Utility.FileMode
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
+repoDescribe Repo { location = UnparseableUrl url } = url
repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir
@@ -59,10 +64,11 @@ repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
+repoLocation Repo { location = UnparseableUrl url } = url
repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
-repoLocation Repo { location = Unknown } = error "unknown repoLocation"
+repoLocation Repo { location = Unknown } = giveup "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
@@ -72,7 +78,8 @@ repoPath Repo { location = Url u } = toRawFilePath $ 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 } = error "unknown repoPath"
+repoPath Repo { location = Unknown } = giveup "unknown repoPath"
+repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"
repoWorkTree :: Repo -> Maybe RawFilePath
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
@@ -81,12 +88,13 @@ repoWorkTree _ = Nothing
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> RawFilePath
localGitDir Repo { location = Local { gitdir = d } } = d
-localGitDir _ = error "unknown localGitDir"
+localGitDir _ = giveup "unknown localGitDir"
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
+repoIsUrl Repo { location = UnparseableUrl _ } = True
repoIsUrl _ = False
repoIsSsh :: Repo -> Bool
@@ -121,7 +129,7 @@ repoIsLocalUnknown _ = False
assertLocal :: Repo -> a -> a
assertLocal repo action
- | repoIsUrl repo = error $ unwords
+ | repoIsUrl repo = giveup $ unwords
[ "acting on non-local git repo"
, repoDescribe repo
, "not supported"
@@ -129,14 +137,13 @@ assertLocal repo action
| otherwise = action
{- Path to a repository's gitattributes file. -}
-attributes :: Repo -> FilePath
+attributes :: Repo -> RawFilePath
attributes repo
| repoIsLocalBare repo = attributesLocal repo
- | otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes"
+ | otherwise = repoPath repo P.</> ".gitattributes"
-attributesLocal :: Repo -> FilePath
-attributesLocal repo = fromRawFilePath (localGitDir repo)
- </> "info" </> "attributes"
+attributesLocal :: Repo -> RawFilePath
+attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}
@@ -149,7 +156,7 @@ hookPath script repo = do
#if mingw32_HOST_OS
isexecutable f = doesFileExist f
#else
- isexecutable f = isExecutable . fileMode <$> getFileStatus f
+ isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f
#endif
{- Makes the path to a local Repo be relative to the cwd. -}
@@ -158,13 +165,13 @@ relPath = adjustPath torel
where
torel p = do
p' <- relPathCwdToFile p
- return $ if null p' then "." else p'
+ return $ if B.null p' then "." else p'
{- Adusts the path to a local Repo using the provided function. -}
-adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
+adjustPath :: (RawFilePath -> IO RawFilePath) -> 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
+ d' <- f d
+ w' <- maybe (pure Nothing) (Just <$$> f) w
return $ r
{ location = l
{ gitdir = d'
@@ -172,8 +179,7 @@ adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
}
}
where
- f' v = toRawFilePath <$> f (fromRawFilePath v)
adjustPath f r@(Repo { location = LocalUnknown d }) = do
- d' <- toRawFilePath <$> f (fromRawFilePath d)
+ d' <- f d
return $ r { location = LocalUnknown d' }
adjustPath _ r = pure r
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 699fbf5..f30e357 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -1,6 +1,6 @@
{- git branch stuff
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -18,6 +18,7 @@ import qualified Git.Config
import qualified Git.Ref
import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
{- The currently checked out branch.
-
@@ -39,25 +40,27 @@ current r = do
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Branch)
-currentUnsafe r = parse . firstLine'
- <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
+currentUnsafe r = parse . firstLine' <$> pipeReadStrict
+ [ Param "symbolic-ref"
+ , Param "-q"
+ , Param $ fromRef Git.Ref.headRef
+ ] r
where
parse b
| B.null b = Nothing
- | otherwise = Just $ Git.Ref $ decodeBS b
+ | otherwise = Just $ Git.Ref b
{- Checks if the second branch has any commits not present on the first
- branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
- | otherwise = not . null
+ | otherwise = not . B.null
<$> changed' origbranch newbranch [Param "-n1"] repo
where
-changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
-changed' origbranch newbranch extraps repo =
- decodeBS <$> pipeReadStrict ps repo
+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString
+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
where
ps =
[ Param "log"
@@ -68,7 +71,7 @@ changed' origbranch newbranch extraps repo =
{- Lists commits that are in the second branch and not in the first branch. -}
changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
changedCommits origbranch newbranch extraps repo =
- catMaybes . map extractSha . lines
+ catMaybes . map extractSha . B8.lines
<$> changed' origbranch newbranch extraps repo
{- Check if it's possible to fast-forward from the old
@@ -118,6 +121,13 @@ fastForward branch (first:rest) repo =
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
+{- Should the commit avoid the usual summary output? -}
+newtype CommitQuiet = CommitQuiet Bool
+
+applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]
+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps
+applyCommitQuiet (CommitQuiet False) ps = ps
+
{- The user may have set commit.gpgsign, intending all their manual
- commits to be signed. But signing automatic/background commits could
- easily lead to unwanted gpg prompts or failures.
@@ -145,12 +155,14 @@ applyCommitModeForCommitTree commitmode ps r
ps' = applyCommitMode commitmode ps
{- Commit via the usual git command. -}
-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool
commitCommand = commitCommand' runBool
-commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
-commitCommand' runner commitmode ps = runner $
- Param "commit" : applyCommitMode commitmode ps
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode commitquiet ps =
+ runner $ Param "commit" : ps'
+ where
+ ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps)
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha.
@@ -159,12 +171,11 @@ commitCommand' runner commitmode ps = runner $
- one parent, and it has the same tree that would be committed.
-
- Unlike git-commit, does not run any hooks, or examine the work tree
- - in any way.
+ - in any way, or output a summary.
-}
commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
commit commitmode allowempty message branch parentrefs repo = do
- tree <- getSha "write-tree" $
- decodeBS' <$> pipeReadStrict [Param "write-tree"] repo
+ tree <- writeTree repo
ifM (cancommit tree)
( do
sha <- commitTree commitmode message parentrefs tree repo
@@ -183,6 +194,19 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
commitAlways commitmode message branch parentrefs repo = fromJust
<$> commit commitmode True message branch parentrefs repo
+-- Throws exception if the index is locked, with an error message output by
+-- git on stderr.
+writeTree :: Repo -> IO Sha
+writeTree repo = getSha "write-tree" $
+ pipeReadStrict [Param "write-tree"] repo
+
+-- Avoids error output if the command fails due to eg, the index being locked.
+writeTreeQuiet :: Repo -> IO (Maybe Sha)
+writeTreeQuiet repo = extractSha <$> withNullHandle go
+ where
+ go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh })
+ [Param "write-tree"] repo
+
commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
commitTree commitmode message parentrefs tree repo =
getSha "commit-tree" $
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 6402001..daa41ad 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,15 +1,22 @@
{- git cat-file interface
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
+
module Git.CatFile (
CatFileHandle,
+ CatFileMetaDataHandle,
catFileStart,
+ catFileMetaDataStart,
catFileStart',
+ catFileMetaDataStart',
catFileStop,
+ catFileMetaDataStop,
catFile,
catFileDetails,
catTree,
@@ -17,18 +24,26 @@ module Git.CatFile (
catObject,
catObjectDetails,
catObjectMetaData,
+ catObjectStreamLsTree,
+ catObjectStream,
+ catObjectMetaDataStream,
) where
import System.IO
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as L8
-import qualified Data.Map as M
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.Attoparsec.ByteString.Char8 as A8
+import qualified Data.Map.Strict as M
import Data.String
import Data.Char
import Numeric
import System.Posix.Types
import Text.Read
+import Control.Concurrent.Async
+import Control.Concurrent.Chan
+import Control.Monad.IO.Class (MonadIO)
import Common
import Git
@@ -36,15 +51,20 @@ import Git.Sha
import qualified Git.Ref
import Git.Command
import Git.Types
-import Git.FilePath
import Git.HashObject
+import qualified Git.LsTree as LsTree
import qualified Utility.CoProcess as CoProcess
+import qualified Git.BuildVersion as BuildVersion
import Utility.Tuple
data CatFileHandle = CatFileHandle
{ catFileProcess :: CoProcess.CoProcessHandle
- , checkFileProcess :: CoProcess.CoProcessHandle
- , gitRepo :: Repo
+ , catFileGitRepo :: Repo
+ }
+
+data CatFileMetaDataHandle = CatFileMetaDataHandle
+ { checkFileProcess :: CoProcess.CoProcessHandle
+ , checkFileGitRepo :: Repo
}
catFileStart :: Repo -> IO CatFileHandle
@@ -52,28 +72,40 @@ catFileStart = catFileStart' True
catFileStart' :: Bool -> Repo -> IO CatFileHandle
catFileStart' restartable repo = CatFileHandle
- <$> startp "--batch"
- <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"
+ <$> startcat restartable repo "--batch"
<*> pure repo
- where
- startp p = gitCoProcessStart restartable
- [ Param "cat-file"
- , Param p
- ] repo
+
+catFileMetaDataStart :: Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart = catFileMetaDataStart' True
+
+catFileMetaDataStart' :: Bool -> Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart' restartable repo = CatFileMetaDataHandle
+ <$> startcat restartable repo ("--batch-check=" ++ batchFormat)
+ <*> pure repo
+
+batchFormat :: String
+batchFormat = "%(objectname) %(objecttype) %(objectsize)"
+
+startcat :: Bool -> Repo -> String -> IO CoProcess.CoProcessHandle
+startcat restartable repo p = gitCoProcessStart restartable
+ [ Param "cat-file"
+ , Param p
+ ] repo
catFileStop :: CatFileHandle -> IO ()
-catFileStop h = do
- CoProcess.stop (catFileProcess h)
- CoProcess.stop (checkFileProcess h)
+catFileStop = CoProcess.stop . catFileProcess
+
+catFileMetaDataStop :: CatFileMetaDataHandle -> IO ()
+catFileMetaDataStop = CoProcess.stop . checkFileProcess
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
-catFile h branch file = catObject h $ Ref $
- fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
+catFile h branch file = catObject h $
+ Git.Ref.branchFileRef branch file
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
-catFileDetails h branch file = catObjectDetails h $ Ref $
- fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
+catFileDetails h branch file = catObjectDetails h $
+ Git.Ref.branchFileRef branch file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@@ -82,80 +114,89 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do
- header <- hGetLine from
+ header <- S8.hGetLine from
case parseResp object header of
- Just (ParsedResp sha size objtype) -> do
- content <- S.hGet from (fromIntegral size)
- eatchar '\n' from
- return $ Just (L.fromChunks [content], sha, objtype)
+ Just r@(ParsedResp sha objtype _size) -> do
+ content <- readObjectContent from r
+ return $ Just (content, sha, objtype)
Just DNE -> return Nothing
- Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
+ Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object)
where
- eatchar expected from = do
- c <- hGetChar from
- when (c /= expected) $
- error $ "missing " ++ (show expected) ++ " from git cat-file"
-
-- Slow fallback path for filenames containing newlines.
- newlinefallback = queryObjectType object (gitRepo h) >>= \case
+ newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case
Nothing -> return Nothing
- Just objtype -> queryContent object (gitRepo h) >>= \case
+ Just objtype -> queryContent object (catFileGitRepo h) >>= \case
Nothing -> return Nothing
Just content -> do
-- only the --batch interface allows getting
-- the sha, so have to re-hash the object
sha <- hashObject' objtype
(flip L.hPut content)
- (gitRepo h)
+ (catFileGitRepo h)
return (Just (content, sha, objtype))
+readObjectContent :: Handle -> ParsedResp -> IO L.ByteString
+readObjectContent h (ParsedResp _ _ size) = do
+ content <- S.hGet h (fromIntegral size)
+ eatchar '\n'
+ return (L.fromChunks [content])
+ where
+ eatchar expected = do
+ c <- hGetChar h
+ when (c /= expected) $
+ giveup $ "missing " ++ (show expected) ++ " from git cat-file"
+readObjectContent _ DNE = error "internal"
+
{- Gets the size and type of an object, without reading its content. -}
-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
+catObjectMetaData :: CatFileMetaDataHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do
- resp <- hGetLine from
+ resp <- S8.hGetLine from
case parseResp object resp of
- Just (ParsedResp sha size objtype) ->
+ Just (ParsedResp sha objtype size) ->
return $ Just (sha, size, objtype)
Just DNE -> return Nothing
Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)
where
-- Slow fallback path for filenames containing newlines.
newlinefallback = do
- sha <- Git.Ref.sha object (gitRepo h)
- sz <- querySize object (gitRepo h)
- objtype <- queryObjectType object (gitRepo h)
+ sha <- Git.Ref.sha object (checkFileGitRepo h)
+ sz <- querySize object (checkFileGitRepo h)
+ objtype <- queryObjectType object (checkFileGitRepo h)
return $ (,,) <$> sha <*> sz <*> objtype
-data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE
+data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE
+ deriving (Show)
query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a
query hdl object newlinefallback receive
-- git cat-file --batch uses a line based protocol, so when the
-- filename itself contains a newline, have to fall back to another
-- method of getting the information.
- | '\n' `elem` s = newlinefallback
+ | '\n' `S8.elem` s = newlinefallback
-- git strips carriage return from the end of a line, out of some
-- misplaced desire to support windows, so also use the newline
-- fallback for those.
- | "\r" `isSuffixOf` s = newlinefallback
+ | "\r" `S8.isSuffixOf` s = newlinefallback
| otherwise = CoProcess.query hdl send receive
where
- send to = hPutStrLn to s
- s = fromRef object
-
-parseResp :: Ref -> String -> Maybe ParsedResp
-parseResp object l
- | " missing" `isSuffixOf` l -- less expensive than full check
- && l == fromRef object ++ " missing" = Just DNE
- | otherwise = case words l of
- [sha, objtype, size]
- | length sha == shaSize ->
- case (readObjectType (encodeBS objtype), reads size) of
- (Just t, [(bytes, "")]) ->
- Just $ ParsedResp (Ref sha) bytes t
- _ -> Nothing
- | otherwise -> Nothing
- _ -> Nothing
+ send to = S8.hPutStrLn to s
+ s = fromRef' object
+
+parseResp :: Ref -> S.ByteString -> Maybe ParsedResp
+parseResp object s
+ | " missing" `S.isSuffixOf` s -- less expensive than full check
+ && s == fromRef' object <> " missing" = Just DNE
+ | otherwise = eitherToMaybe $ A.parseOnly respParser s
+
+respParser :: A.Parser ParsedResp
+respParser = ParsedResp
+ <$> (maybe (fail "bad sha") return . extractSha =<< nextword)
+ <* A8.char ' '
+ <*> (maybe (fail "bad object type") return . readObjectType =<< nextword)
+ <* A8.char ' '
+ <*> A8.decimal
+ where
+ nextword = A8.takeTill (== ' ')
querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a)
querySingle o r repo reader = assertLocal repo $
@@ -173,14 +214,16 @@ querySingle o r repo reader = assertLocal repo $
, std_in = Inherit
, std_out = CreatePipe
}
- pid <- createProcess p'
- let h = stdoutHandle pid
- output <- reader h
- hClose h
- ifM (checkSuccessProcess (processHandle pid))
+ withCreateProcess p' go
+ where
+ go _ (Just outh) _ pid = do
+ output <- reader outh
+ hClose outh
+ ifM (checkSuccessProcess pid)
( return (Just output)
, return Nothing
)
+ go _ _ _ _ = error "internal"
querySize :: Ref -> Repo -> IO (Maybe FileSize)
querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
@@ -219,41 +262,161 @@ catTree h treeref = go <$> catObjectDetails h treeref
catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)
catCommit h commitref = go <$> catObjectDetails h commitref
where
- go (Just (b, _, CommitObject)) = parseCommit b
+ go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b)
go _ = Nothing
-parseCommit :: L.ByteString -> Maybe Commit
+parseCommit :: S.ByteString -> Maybe Commit
parseCommit b = Commit
- <$> (extractSha . L8.unpack =<< field "tree")
- <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))
+ <$> (extractSha =<< field "tree")
+ <*> Just (maybe [] (mapMaybe extractSha) (fields "parent"))
<*> (parsemetadata <$> field "author")
<*> (parsemetadata <$> field "committer")
- <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)
+ <*> Just (decodeBS $ S.intercalate (S.singleton nl) message)
where
field n = headMaybe =<< fields n
fields n = M.lookup (fromString n) fieldmap
fieldmap = M.fromListWith (++) ((map breakfield) header)
breakfield l =
- let (k, sp_v) = L.break (== sp) l
- in (k, [L.drop 1 sp_v])
- (header, message) = separate L.null ls
- ls = L.split nl b
+ let (k, sp_v) = S.break (== sp) l
+ in (k, [S.drop 1 sp_v])
+ (header, message) = separate S.null ls
+ ls = S.split nl b
-- author and committer lines have the form: "name <email> date"
-- The email is always present, even if empty "<>"
parsemetadata l = CommitMetaData
- { commitName = whenset $ L.init name_sp
+ { commitName = whenset $ S.init name_sp
, commitEmail = whenset email
- , commitDate = whenset $ L.drop 2 gt_sp_date
+ , commitDate = whenset $ S.drop 2 gt_sp_date
}
where
- (name_sp, rest) = L.break (== lt) l
- (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)
+ (name_sp, rest) = S.break (== lt) l
+ (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest)
whenset v
- | L.null v = Nothing
- | otherwise = Just (L8.unpack v)
+ | S.null v = Nothing
+ | otherwise = Just (decodeBS v)
nl = fromIntegral (ord '\n')
sp = fromIntegral (ord ' ')
lt = fromIntegral (ord '<')
gt = fromIntegral (ord '>')
+
+{- Uses cat-file to stream the contents of the files as efficiently
+ - as possible. This is much faster than querying it repeatedly per file.
+ -}
+catObjectStreamLsTree
+ :: (MonadMask m, MonadIO m)
+ => [LsTree.TreeItem]
+ -> (LsTree.TreeItem -> Maybe v)
+ -> Repo
+ -> (IO (Maybe (v, Maybe L.ByteString)) -> m a)
+ -> m a
+catObjectStreamLsTree l want repo reader = withCatFileStream False repo $
+ \c hin hout -> bracketIO
+ (async $ feeder c hin)
+ cancel
+ (const (reader (catObjectReader readObjectContent c hout)))
+ where
+ feeder c h = do
+ forM_ l $ \ti -> case want ti of
+ Nothing -> return ()
+ Just v -> do
+ let sha = LsTree.sha ti
+ liftIO $ writeChan c (sha, v)
+ S8.hPutStrLn h (fromRef' sha)
+ hClose h
+
+catObjectStream
+ :: (MonadMask m, MonadIO m)
+ => Repo
+ -> (
+ ((v, Ref) -> IO ()) -- ^ call to feed values in
+ -> IO () -- call once all values are fed in
+ -> IO (Maybe (v, Maybe L.ByteString)) -- call to read results
+ -> m a
+ )
+ -> m a
+catObjectStream repo a = withCatFileStream False repo go
+ where
+ go c hin hout = a
+ (feeder c hin)
+ (hClose hin)
+ (catObjectReader readObjectContent c hout)
+ feeder c h (v, ref) = do
+ writeChan c (ref, v)
+ S8.hPutStrLn h (fromRef' ref)
+
+catObjectMetaDataStream
+ :: (MonadMask m, MonadIO m)
+ => Repo
+ -> (
+ ((v, Ref) -> IO ()) -- ^ call to feed values in
+ -> IO () -- call once all values are fed in
+ -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results
+ -> m a
+ )
+ -> m a
+catObjectMetaDataStream repo a = withCatFileStream True repo go
+ where
+ go c hin hout = a
+ (feeder c hin)
+ (hClose hin)
+ (catObjectReader (\_h r -> pure (conv r)) c hout)
+
+ feeder c h (v, ref) = do
+ liftIO $ writeChan c (ref, v)
+ S8.hPutStrLn h (fromRef' ref)
+
+ conv (ParsedResp sha ty sz) = (sha, sz, ty)
+ conv DNE = error "internal"
+
+catObjectReader
+ :: (Handle -> ParsedResp -> IO t)
+ -> Chan (Ref, a)
+ -> Handle
+ -> IO (Maybe (a, Maybe t))
+catObjectReader getv c h = ifM (hIsEOF h)
+ ( return Nothing
+ , do
+ (ref, f) <- liftIO $ readChan c
+ resp <- S8.hGetLine h
+ case parseResp ref resp of
+ Just r@(ParsedResp {}) -> do
+ v <- getv h r
+ return (Just (f, Just v))
+ Just DNE -> return (Just (f, Nothing))
+ Nothing -> error $ "unknown response from git cat-file " ++ show resp
+ )
+
+withCatFileStream
+ :: (MonadMask m, MonadIO m)
+ => Bool
+ -> Repo
+ -> (Chan v -> Handle -> Handle -> m a)
+ -> m a
+withCatFileStream check repo reader = assertLocal repo $
+ bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout
+ where
+ params = catMaybes
+ [ Just $ Param "cat-file"
+ , Just $ Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat)
+ -- This option makes it faster, but is not present in
+ -- older versions of git.
+ , if BuildVersion.older "2.4.3"
+ then Nothing
+ else Just $ Param "--buffer"
+ ]
+
+ start = do
+ let p = gitCreateProcess params repo
+ (Just hin, Just hout, _, pid) <- createProcess p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+ c <- newChan
+ return (c, hin, hout, pid)
+
+ stop (_, hin, hout, pid) = do
+ hClose hin
+ hClose hout
+ void $ checkSuccessProcess pid
diff --git a/Git/Command.hs b/Git/Command.hs
index eb20af2..894f6ae 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -1,6 +1,6 @@
{- running git commands
-
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -39,19 +39,23 @@ runBool params repo = assertLocal repo $
run :: [CommandParam] -> Repo -> IO ()
run params repo = assertLocal repo $
unlessM (runBool params repo) $
- error $ "git " ++ show params ++ " failed"
+ giveup $ "git " ++ show params ++ " failed"
{- Runs git and forces it to be quiet, throwing an error if it fails. -}
runQuiet :: [CommandParam] -> Repo -> IO ()
-runQuiet params repo = withQuietOutput createProcessSuccess $
- (proc "git" $ toCommand $ gitCommandLine (params) repo)
- { env = gitEnv repo }
+runQuiet params repo = withNullHandle $ \nullh ->
+ let p = (proc "git" $ toCommand $ gitCommandLine (params) repo)
+ { env = gitEnv repo
+ , std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p
{- Runs a git command and returns its output, lazily.
-
- Also returns an action that should be used when the output is all
- read, that will wait on the command, and
- - return True if it succeeded. Failure to wait will result in zombies.
+ - return True if it succeeded.
-}
pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
@@ -66,33 +70,47 @@ pipeReadLazy params repo = assertLocal repo $ do
- Nonzero exit status is ignored.
-}
pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
-pipeReadStrict = pipeReadStrict' S.hGetContents
-
-{- The reader action must be strict. -}
-pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
-pipeReadStrict' reader params repo = assertLocal repo $
- withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
- output <- reader h
- hClose h
- return output
+pipeReadStrict = pipeReadStrict' id
+
+pipeReadStrict' :: (CreateProcess -> CreateProcess) -> [CommandParam] -> Repo -> IO S.ByteString
+pipeReadStrict' fp params repo = assertLocal repo $ withCreateProcess p go
where
- p = gitCreateProcess params repo
+ p = fp (gitCreateProcess params repo) { std_out = CreatePipe }
+
+ go _ (Just outh) _ pid = do
+ output <- S.hGetContents outh
+ hClose outh
+ void $ waitForProcess pid
+ return output
+ go _ _ _ _ = error "internal"
{- Runs a git command, feeding it an input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
- strictly. -}
-pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String
+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString
pipeWriteRead params writer repo = assertLocal repo $
writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)
- (gitEnv repo) writer (Just adjusthandle)
+ (gitEnv repo) writer'
where
+ writer' = case writer of
+ Nothing -> Nothing
+ Just a -> Just $ \h -> do
+ adjusthandle h
+ a h
adjusthandle h = hSetNewlineMode h noNewlineTranslation
{- Runs a git command, feeding it input on a handle with an action. -}
pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
-pipeWrite params repo = assertLocal repo $
- withHandle StdinHandle createProcessSuccess $
- gitCreateProcess params repo
+pipeWrite params repo feeder = assertLocal repo $
+ let p = (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ in withCreateProcess p (go p)
+ where
+ go p (Just hin) _ _ pid = do
+ feeder hin
+ hClose hin
+ forceSuccessProcess p pid
+ go _ _ _ _ _ = error "internal"
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
@@ -114,16 +132,6 @@ pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo
return $ filter (not . S.null) $ S.split 0 s
-pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
-pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
-
-pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]
-pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo
-
-{- Doesn't run the cleanup action. A zombie results. -}
-leaveZombie :: (a, IO Bool) -> a
-leaveZombie = fst
-
{- Runs a git command as a coprocess. -}
gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
diff --git a/Git/Config.hs b/Git/Config.hs
index 4b60664..4ff3454 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -1,6 +1,6 @@
{- git repository configuration handling
-
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -14,6 +14,7 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Char
import qualified System.FilePath.ByteString as P
+import Control.Concurrent.Async
import Common
import Git
@@ -21,6 +22,8 @@ import Git.Types
import qualified Git.Command
import qualified Git.Construct
import Utility.UserInfo
+import Utility.Process.Transcript
+import Utility.Debug
{- Returns a single git config setting, or a fallback value if not set. -}
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
@@ -54,50 +57,72 @@ reRead r = read' $ r
read' :: Repo -> IO Repo
read' repo = go repo
where
- go Repo { location = Local { gitdir = d } } = git_config d
- go Repo { location = LocalUnknown d } = git_config d
+ -- Passing --git-dir changes git's behavior when run in a
+ -- repository belonging to another user. When the git directory
+ -- was explicitly specified, pass that in order to get the local
+ -- git config.
+ go Repo { location = Local { gitdir = d } }
+ | gitDirSpecifiedExplicitly repo = git_config ["--git-dir=."] d
+ -- Run in worktree when there is one, since running in the .git
+ -- directory will trigger safe.bareRepository=explicit, even
+ -- when not in a bare repository.
+ go Repo { location = Local { worktree = Just d } } = git_config [] d
+ go Repo { location = Local { gitdir = d } } = git_config [] d
+ go Repo { location = LocalUnknown d } = git_config [] d
go _ = assertLocal repo $ error "internal"
- git_config d = withHandle StdoutHandle createProcessSuccess p $
- hRead repo
+ git_config addparams d = withCreateProcess p (git_config' p)
where
- params = ["config", "--null", "--list"]
+ params = addparams ++ ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just (fromRawFilePath d)
, env = gitEnv repo
+ , std_out = CreatePipe
}
+ git_config' p _ (Just hout) _ pid =
+ forceSuccessProcess p pid
+ `after`
+ hRead repo ConfigNullList hout
+ git_config' _ _ _ _ _ = error "internal"
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
home <- myHomeDir
ifM (doesFileExist $ home </> ".gitconfig")
- ( do
- repo <- withHandle StdoutHandle createProcessSuccess p $
- hRead (Git.Construct.fromUnknown)
- return $ Just repo
+ ( Just <$> withCreateProcess p go
, return Nothing
)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
+ { std_out = CreatePipe }
+ go _ (Just hout) _ pid =
+ forceSuccessProcess p pid
+ `after`
+ hRead (Git.Construct.fromUnknown) ConfigNullList hout
+ go _ _ _ _ = error "internal"
{- Reads git config from a handle and populates a repo with it. -}
-hRead :: Repo -> Handle -> IO Repo
-hRead repo h = do
+hRead :: Repo -> ConfigStyle -> Handle -> IO Repo
+hRead repo st h = do
val <- S.hGetContents h
- store val repo
+ let c = parse val st
+ debug (DebugSource "Git.Config") $ "git config read: " ++
+ show (map (\(k, v) -> (show k, map show v)) (M.toList c))
+ storeParsed c repo
{- Stores a git config into a Repo, returning the new version of the Repo.
- The git config may be multiple lines, or a single line.
- Config settings can be updated incrementally.
-}
-store :: S.ByteString -> Repo -> IO Repo
-store s repo = do
- let c = parse s
- updateLocation $ repo
- { config = (M.map Prelude.head c) `M.union` config repo
- , fullconfig = M.unionWith (++) c (fullconfig repo)
- }
+store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo
+store s st = storeParsed (parse s st)
+
+storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo
+storeParsed c repo = updateLocation $ repo
+ { config = (M.map Prelude.head c) `M.union` config repo
+ , fullconfig = M.unionWith (++) c (fullconfig repo)
+ }
{- Stores a single config setting in a Repo, returning the new version of
- the Repo. Config settings can be updated incrementally. -}
@@ -114,14 +139,28 @@ store' k v repo = repo
- based on the core.bare and core.worktree settings.
-}
updateLocation :: Repo -> IO Repo
-updateLocation r@(Repo { location = LocalUnknown d })
- | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit))
- ( updateLocation' r $ Local dotgit Nothing
- , updateLocation' r $ Local d Nothing
- )
- | otherwise = updateLocation' r $ Local dotgit (Just d)
+updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of
+ Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit))
+ ( updateLocation' r $ Local dotgit Nothing
+ , updateLocation' r $ Local d Nothing
+ )
+ Just False -> mknonbare
+ {- core.bare not in config, probably because safe.directory
+ - did not allow reading the config -}
+ Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d))
+ ( mkbare
+ , mknonbare
+ )
where
dotgit = d P.</> ".git"
+ -- git treats eg ~/foo as a bare git repository located in
+ -- ~/foo/.git if ~/foo/.git/config has core.bare=true
+ mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit))
+ ( updateLocation' r $ Local dotgit Nothing
+ , updateLocation' r $ Local d Nothing
+ )
+ mknonbare = updateLocation' r $ Local dotgit (Just d)
+
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r
@@ -131,42 +170,59 @@ updateLocation' r l = do
Nothing -> return l
Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
- top <- absPath $ fromRawFilePath (gitdir l)
- let p = absPathFrom top (fromRawFilePath d)
- return $ l { worktree = Just (toRawFilePath p) }
+ top <- absPath (gitdir l)
+ let p = absPathFrom top d
+ return $ l { worktree = Just p }
+ Just NoConfigValue -> return l
return $ r { location = l' }
+data ConfigStyle = ConfigList | ConfigNullList
+
{- Parses git config --list or git config --null --list output into a
- config map. -}
-parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]
-parse s
+parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]
+parse s st
| S.null s = M.empty
- -- --list output will have a '=' in the first line
- -- (The first line of --null --list output is the name of a key,
- -- which is assumed to never contain '='.)
- | S.elem eq firstline = sep eq $ S.split nl s
- -- --null --list output separates keys from values with newlines
- | otherwise = sep nl $ S.split 0 s
+ | otherwise = case st of
+ ConfigList -> sep eq $ S.split nl s
+ ConfigNullList -> sep nl $ S.split 0 s
where
nl = fromIntegral (ord '\n')
eq = fromIntegral (ord '=')
- firstline = S.takeWhile (/= nl) s
sep c = M.fromListWith (++)
- . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)]))
+ . map (\(k,v) -> (ConfigKey k, [mkval v]))
. map (S.break (== c))
+
+ mkval v
+ | S.null v = NoConfigValue
+ | otherwise = ConfigValue (S.drop 1 v)
{- Checks if a string from git config is a true/false value. -}
isTrueFalse :: String -> Maybe Bool
-isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'
+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS
isTrueFalse' :: ConfigValue -> Maybe Bool
isTrueFalse' (ConfigValue s)
+ | s' == "yes" = Just True
+ | s' == "on" = Just True
| s' == "true" = Just True
+ | s' == "1" = Just True
+
+ | s' == "no" = Just False
+ | s' == "off" = Just False
| s' == "false" = Just False
+ | s' == "0" = Just False
+ | s' == "" = Just False
+
+ -- Git treats any number other than 0 as true,
+ -- including negative numbers.
+ | S8.all (\c -> isDigit c || c == '-') s' = Just True
+
| otherwise = Nothing
where
s' = S8.map toLower s
+isTrueFalse' NoConfigValue = Just True
boolConfig :: Bool -> String
boolConfig True = "true"
@@ -176,32 +232,52 @@ boolConfig' :: Bool -> S.ByteString
boolConfig' True = "true"
boolConfig' False = "false"
-isBare :: Repo -> Bool
-isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r
+{- Note that repoIsLocalBare is often better to use than this. -}
+isBare :: Repo -> Maybe Bool
+isBare r = isTrueFalse' =<< getMaybe coreBare r
coreBare :: ConfigKey
coreBare = "core.bare"
{- Runs a command to get the configuration of a repo,
- and returns a repo populated with the configuration, as well as the raw
- - output of the command. -}
-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))
-fromPipe r cmd params = try $
- withHandle StdoutHandle createProcessSuccess p $ \h -> do
- val <- S.hGetContents h
- r' <- store val r
- return (r', val)
+ - output and the standard error of the command. -}
+fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String))
+fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go
where
- p = proc cmd $ toCommand params
+ p = (proc cmd $ toCommand params)
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ go _ (Just hout) (Just herr) pid =
+ withAsync (getstderr pid herr []) $ \errreader -> do
+ val <- S.hGetContents hout
+ err <- wait errreader
+ forceSuccessProcess p pid
+ r' <- store val st r
+ return (r', val, err)
+ go _ _ _ _ = error "internal"
+
+ getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case
+ Just l -> getstderr pid herr (l:c)
+ Nothing -> return (unlines (reverse c))
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))
+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"
, File f
, Param "--list"
+ ] ConfigList
+
+{- Changes a git config setting in .git/config. -}
+change :: ConfigKey -> S.ByteString -> Repo -> IO Bool
+change (ConfigKey k) v = Git.Command.runBool
+ [ Param "config"
+ , Param (decodeBS k)
+ , Param (decodeBS v)
]
{- Changes a git config setting in the specified config file.
@@ -211,8 +287,8 @@ changeFile f (ConfigKey k) v = boolSystem "git"
[ Param "config"
, Param "--file"
, File f
- , Param (decodeBS' k)
- , Param (decodeBS' v)
+ , Param (decodeBS k)
+ , Param (decodeBS v)
]
{- Unsets a git config setting, in both the git repo,
@@ -227,4 +303,28 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
, return Nothing
)
where
- ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
+ ps = [Param "config", Param "--unset-all", Param (decodeBS k)]
+
+{- git "fixed" CVE-2022-24765 by preventing git-config from
+ - listing per-repo configs when the repo is not owned by
+ - the current user. Detect if this fix is in effect for the
+ - repo.
+ -}
+checkRepoConfigInaccessible :: Repo -> IO Bool
+checkRepoConfigInaccessible r
+ -- When --git-dir or GIT_DIR is used to specify the git
+ -- directory, git does not check for CVE-2022-24765.
+ | gitDirSpecifiedExplicitly r = return False
+ | otherwise = do
+ -- Cannot use gitCommandLine here because specifying --git-dir
+ -- will bypass the git security check.
+ let p = (proc "git" ["config", "--local", "--list"])
+ { cwd = Just (fromRawFilePath (repoPath r))
+ , env = gitEnv r
+ }
+ (out, ok) <- processTranscript' p Nothing
+ if not ok
+ then do
+ debug (DebugSource "Git.Config") ("config output: " ++ out)
+ return True
+ else return False
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 5b656eb..bdab8ed 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -1,10 +1,11 @@
{- Construction of Git Repo objects
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Git.Construct (
@@ -21,6 +22,8 @@ module Git.Construct (
repoAbsPath,
checkForRepo,
newFrom,
+ adjustGitDirFile,
+ isBareRepo,
) where
#ifndef mingw32_HOST_OS
@@ -36,6 +39,10 @@ import Git.Remote
import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
+import Utility.Url.Parse
+
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
{- Finds the git repository used for the cwd, which may be in a parent
- directory. -}
@@ -45,60 +52,65 @@ fromCwd = getCurrentDirectory >>= seekUp
seekUp dir = do
r <- checkForRepo dir
case r of
- Nothing -> case upFrom dir of
+ Nothing -> case upFrom (toRawFilePath dir) of
Nothing -> return Nothing
- Just d -> seekUp d
+ Just d -> seekUp (fromRawFilePath d)
Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
-fromPath :: FilePath -> IO Repo
-fromPath dir = fromAbsPath =<< absPath dir
+fromPath :: RawFilePath -> IO Repo
+fromPath dir
+ -- When dir == "foo/.git", git looks for "foo/.git/.git",
+ -- and failing that, uses "foo" as the repository.
+ | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
+ ( ret dir
+ , ret (P.takeDirectory canondir)
+ )
+ | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
+ ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
+ -- 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
+ )
+ where
+ ret = pure . newFrom . LocalUnknown
+ canondir = P.dropTrailingPathSeparator dir
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
-fromAbsPath :: FilePath -> IO Repo
+fromAbsPath :: RawFilePath -> IO Repo
fromAbsPath dir
- | absoluteGitPath (encodeBS dir) = hunt
+ | absoluteGitPath dir = fromPath dir
| otherwise =
- error $ "internal error, " ++ dir ++ " is not absolute"
- where
- ret = pure . newFrom . LocalUnknown . toRawFilePath
- canondir = dropTrailingPathSeparator dir
- {- 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)
- )
- | 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
- )
+ giveup $ "internal error, " ++ show dir ++ " is not absolute"
-{- Remote Repo constructor. Throws exception on invalid url.
+{- Construct a Repo for a remote's url.
-
- Git is somewhat forgiving about urls to repositories, allowing
- - eg spaces that are not normally allowed unescaped in urls.
+ - eg spaces that are not normally allowed unescaped in urls. Such
+ - characters get escaped.
+ -
+ - This will always succeed, even if the url cannot be parsed
+ - or is invalid, because git can also function despite remotes having
+ - such urls, only failing if such a remote is used.
-}
fromUrl :: String -> IO Repo
fromUrl url
- | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
- | otherwise = fromUrlStrict url
+ | not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
+ | otherwise = fromUrl' url
-fromUrlStrict :: String -> IO Repo
-fromUrlStrict url
- | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u
- | otherwise = pure $ newFrom $ Url u
- where
- u = fromMaybe bad $ parseURI url
- bad = error $ "bad url " ++ url
+fromUrl' :: String -> IO Repo
+fromUrl' url
+ | "file://" `isPrefixOf` url = case parseURIPortable url of
+ Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
+ Nothing -> pure $ newFrom $ UnparseableUrl url
+ | otherwise = case parseURIPortable url of
+ Just u -> pure $ newFrom $ Url u
+ Nothing -> pure $ newFrom $ UnparseableUrl url
{- Creates a repo that has an unknown location. -}
fromUnknown :: Repo
@@ -110,25 +122,26 @@ localToUrl :: Repo -> Repo -> Repo
localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r
- | otherwise = case Url.authority reference of
- Nothing -> r
- Just auth ->
+ | otherwise = case (Url.authority reference, Url.scheme reference) of
+ (Just auth, Just s) ->
let absurl = concat
- [ Url.scheme reference
+ [ s
, "//"
, auth
, fromRawFilePath (repoPath r)
]
- in r { location = Url $ fromJust $ parseURI absurl }
+ in r { location = Url $ fromJust $ parseURIPortable absurl }
+ _ -> r
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
-fromRemotes repo = mapM construct remotepairs
+fromRemotes repo = catMaybes <$> mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
- remotepairs = filterkeys isRemoteKey
- construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
+ remotepairs = filterkeys isRemoteUrlKey
+ construct (k,v) = remoteNamedFromKey k $
+ fromRemoteLocation (fromConfigValue v) False repo
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@@ -138,13 +151,21 @@ remoteNamed n constructor = do
{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
-remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo
-remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
+remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo)
+remoteNamedFromKey k r = case remoteKeyToRemoteName k of
+ Nothing -> pure Nothing
+ Just n -> Just <$> remoteNamed n r
{- Constructs a new Repo for one of a Repo's remotes using a given
- - location (ie, an url). -}
-fromRemoteLocation :: String -> Repo -> IO Repo
-fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
+ - location (ie, an url).
+ -
+ - knownurl can be true if the location is known to be an url. This allows
+ - urls that don't parse as urls to be used, returning UnparseableUrl.
+ - If knownurl is false, the location may still be an url, if it parses as
+ - one.
+ -}
+fromRemoteLocation :: String -> Bool -> Repo -> IO Repo
+fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo
where
gen (RemotePath p) = fromRemotePath p repo
gen (RemoteUrl u) = fromUrl u
@@ -154,24 +175,27 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
- fromPath $ fromRawFilePath (repoPath repo) </> dir'
+ fromPath $ repoPath repo P.</> toRawFilePath dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
-repoAbsPath :: FilePath -> IO FilePath
+repoAbsPath :: RawFilePath -> IO RawFilePath
repoAbsPath d = do
- d' <- expandTilde d
+ d' <- expandTilde (fromRawFilePath d)
h <- myHomeDir
- return $ h </> d'
+ return $ toRawFilePath $ h </> d'
expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS
expandTilde = return
#else
-expandTilde = expandt True
+expandTilde p = expandt True p
+ -- If unable to expand a tilde, eg due to a user not existing,
+ -- use the path as given.
+ `catchNonAsync` (const (return p))
where
expandt _ [] = return ""
expandt _ ('/':cs) = do
@@ -180,6 +204,7 @@ expandTilde = expandt True
expandt True ('~':'/':cs) = do
h <- myHomeDir
return $ h </> cs
+ expandt True "~" = myHomeDir
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
@@ -198,8 +223,8 @@ expandTilde = expandt True
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
check isRepo $
- check gitDirFile $
- check isBareRepo $
+ check (checkGitDirFile (toRawFilePath dir)) $
+ check (checkdir (isBareRepo dir)) $
return Nothing
where
check test cont = maybe cont (return . Just) =<< test
@@ -208,30 +233,49 @@ checkForRepo dir =
, return Nothing
)
isRepo = checkdir $
- gitSignature (".git" </> "config")
+ doesFileExist (dir </> ".git" </> "config")
<||>
- -- A git-worktree lacks .git/config, but has .git/commondir.
+ -- A git-worktree lacks .git/config, but has .git/gitdir.
-- (Normally the .git is a file, not a symlink, but it can
-- be converted to a symlink and git will still work;
-- this handles that case.)
- gitSignature (".git" </> "gitdir")
- isBareRepo = checkdir $ gitSignature "config"
- <&&> doesDirectoryExist (dir </> "objects")
- gitDirFile = do
- -- git-submodule, git-worktree, and --separate-git-dir
- -- make .git be a file pointing to the real git directory.
- c <- firstLine <$>
- catchDefaultIO "" (readFile $ dir </> ".git")
- return $ if gitdirprefix `isPrefixOf` c
- then Just $ Local
- { gitdir = toRawFilePath $ absPathFrom dir $
- drop (length gitdirprefix) c
- , worktree = Just (toRawFilePath dir)
+ doesFileExist (dir </> ".git" </> "gitdir")
+
+isBareRepo :: FilePath -> IO Bool
+isBareRepo dir = doesFileExist (dir </> "config")
+ <&&> doesDirectoryExist (dir </> "objects")
+
+-- Check for a .git file.
+checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
+checkGitDirFile dir = adjustGitDirFile' $ Local
+ { gitdir = dir P.</> ".git"
+ , worktree = Just dir
+ }
+
+-- git-submodule, git-worktree, and --separate-git-dir
+-- make .git be a file pointing to the real git directory.
+-- Detect that, and return a RepoLocation with gitdir pointing
+-- to the real git directory.
+adjustGitDirFile :: RepoLocation -> IO RepoLocation
+adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
+
+adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
+adjustGitDirFile' loc = do
+ let gd = gitdir loc
+ c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
+ if gitdirprefix `isPrefixOf` c
+ then do
+ top <- fromRawFilePath . P.takeDirectory <$> absPath gd
+ return $ Just $ loc
+ { gitdir = absPathFrom
+ (toRawFilePath top)
+ (toRawFilePath
+ (drop (length gitdirprefix) c))
}
- else Nothing
- where
- gitdirprefix = "gitdir: "
- gitSignature file = doesFileExist $ dir </> file
+ else return Nothing
+ where
+ gitdirprefix = "gitdir: "
+
newFrom :: RepoLocation -> Repo
newFrom l = Repo
@@ -242,5 +286,6 @@ newFrom l = Repo
, gitEnv = Nothing
, gitEnvOverridesGitDir = False
, gitGlobalOpts = []
+ , gitDirSpecifiedExplicitly = False
}
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 054a81e..54e05f4 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -1,18 +1,25 @@
{- The current git repository.
-
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.CurrentRepo where
import Common
+import Git
import Git.Types
import Git.Construct
import qualified Git.Config
import Utility.Env
import Utility.Env.Set
+import qualified Utility.RawFilePath as R
+
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
{- Gets the current git repository.
-
@@ -37,49 +44,51 @@ get = do
gd <- getpathenv "GIT_DIR"
r <- configure gd =<< fromCwd
prefix <- getpathenv "GIT_PREFIX"
- wt <- maybe (fromRawFilePath <$> worktree (location r)) Just
+ wt <- maybe (worktree (location r)) Just
<$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of
- Nothing -> return r
+ Nothing -> relPath r
Just d -> do
- curr <- getCurrentDirectory
+ curr <- R.getCurrentDirectory
unless (d `dirContains` curr) $
- setCurrentDirectory d
- return $ addworktree wt r
+ setCurrentDirectory (fromRawFilePath d)
+ relPath $ addworktree wt r
where
getpathenv s = do
v <- getEnv s
case v of
Just d -> do
unsetEnv s
- return (Just d)
+ return (Just (toRawFilePath d))
Nothing -> return Nothing
- getpathenvprefix s (Just prefix) | not (null prefix) =
+ getpathenvprefix s (Just prefix) | not (B.null prefix) =
getpathenv s >>= \case
Nothing -> return Nothing
Just d
| d == "." -> return (Just d)
- | otherwise -> Just <$> absPath (prefix </> d)
+ | otherwise -> Just
+ <$> absPath (prefix P.</> d)
getpathenvprefix s _ = getpathenv s
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
- curr <- getCurrentDirectory
- r <- Git.Config.read $ newFrom $
- Local
- { gitdir = toRawFilePath absd
- , worktree = Just (toRawFilePath curr)
- }
- return $ if Git.Config.isBare r
+ curr <- R.getCurrentDirectory
+ loc <- adjustGitDirFile $ Local
+ { gitdir = absd
+ , worktree = Just curr
+ }
+ r <- Git.Config.read $ (newFrom loc)
+ { gitDirSpecifiedExplicitly = True }
+ return $ if fromMaybe False (Git.Config.isBare r)
then r { location = (location r) { worktree = Nothing } }
else r
-
configure Nothing Nothing = giveup "Not in a git repository."
addworktree w r = changelocation r $ Local
{ gitdir = gitdir (location r)
- , worktree = fmap toRawFilePath w
+ , worktree = w
}
+
changelocation r l = r { location = l }
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
index 3dc8529..9b75178 100644
--- a/Git/Destroyer.hs
+++ b/Git/Destroyer.hs
@@ -18,7 +18,9 @@ import Git
import Utility.QuickCheck
import Utility.FileMode
import Utility.Tmp
+import qualified Utility.RawFilePath as R
+import System.PosixCompat.Files
import qualified Data.ByteString as B
import Data.Word
@@ -95,12 +97,12 @@ applyDamage ds r = do
case d of
Empty s -> withfile s $ \f ->
withSaneMode f $ do
- nukeFile f
+ removeWhenExistsWith R.removeLink (toRawFilePath f)
writeFile f ""
Reverse s -> withfile s $ \f ->
withSaneMode f $
B.writeFile f =<< B.reverse <$> B.readFile f
- Delete s -> withfile s $ nukeFile
+ Delete s -> withfile s $ removeWhenExistsWith R.removeLink . toRawFilePath
AppendGarbage s garbage ->
withfile s $ \f ->
withSaneMode f $
@@ -127,15 +129,15 @@ applyDamage ds r = do
]
ScrambleFileMode s mode ->
withfile s $ \f ->
- setFileMode f mode
+ R.setFileMode (toRawFilePath f) mode
SwapFiles a b ->
withfile a $ \fa ->
withfile b $ \fb ->
unless (fa == fb) $
withTmpFile "swap" $ \tmp _ -> do
- moveFile fa tmp
- moveFile fb fa
- moveFile tmp fa
+ moveFile (toRawFilePath fa) (toRawFilePath tmp)
+ moveFile (toRawFilePath fb) (toRawFilePath fa)
+ moveFile (toRawFilePath tmp) (toRawFilePath fa)
where
-- A broken .git/config is not recoverable.
-- Don't damage hook scripts, to avoid running arbitrary code. ;)
@@ -145,4 +147,5 @@ applyDamage ds r = do
]
withSaneMode :: FilePath -> IO () -> IO ()
-withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
+withSaneMode f = withModifiedFileMode (toRawFilePath f)
+ (addModes [ownerWriteMode, ownerReadMode])
diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs
index ffda2e8..090ad3e 100644
--- a/Git/DiffTreeItem.hs
+++ b/Git/DiffTreeItem.hs
@@ -10,6 +10,7 @@ module Git.DiffTreeItem (
) where
import System.Posix.Types
+import qualified Data.ByteString as S
import Git.FilePath
import Git.Types
@@ -17,8 +18,8 @@ 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
+ , srcsha :: Sha -- null sha if file was added
+ , dstsha :: Sha -- null sha if file was deleted
+ , status :: S.ByteString
, file :: TopFilePath
} deriving Show
diff --git a/Git/Env.hs b/Git/Env.hs
new file mode 100644
index 0000000..fb0377f
--- /dev/null
+++ b/Git/Env.hs
@@ -0,0 +1,52 @@
+{- Adjusting the environment while running git commands.
+ -
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Git.Env where
+
+import Common
+import Git
+import Git.Types
+import Utility.Env
+
+{- Adjusts the gitEnv of a Repo. Copies the system environment if the repo
+ - does not have any gitEnv yet. -}
+adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo
+adjustGitEnv g adj = do
+ e <- maybe getEnvironment return (gitEnv g)
+ let e' = adj e
+ return $ g { gitEnv = Just e' }
+ where
+
+addGitEnv :: Repo -> String -> String -> IO Repo
+addGitEnv g var val = adjustGitEnv g (addEntry var val)
+
+{- Environment variables to use when running a command.
+ - Includes GIT_DIR pointing at the repo, and GIT_WORK_TREE when the repo
+ - is not bare. Also includes anything added to the Repo's gitEnv,
+ - and a copy of the rest of the system environment. -}
+propGitEnv :: Repo -> IO [(String, String)]
+propGitEnv g = do
+ g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g))
+ g'' <- maybe (pure g')
+ (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath)
+ (repoWorkTree g)
+ return $ fromMaybe [] (gitEnv g'')
+
+{- Use with any action that makes a commit to set metadata. -}
+commitWithMetaData :: CommitMetaData -> CommitMetaData -> (Repo -> IO a) -> Repo -> IO a
+commitWithMetaData authormetadata committermetadata a g =
+ a =<< adjustGitEnv g adj
+ where
+ adj = mkadj "AUTHOR" authormetadata
+ . mkadj "COMMITTER" committermetadata
+ mkadj p md = go "NAME" commitName
+ . go "EMAIL" commitEmail
+ . go "DATE" commitDate
+ where
+ go s getv = case getv md of
+ Nothing -> id
+ Just v -> addEntry ("GIT_" ++ p ++ "_" ++ s) v
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index 66a0159..b27c0c7 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-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -30,12 +30,12 @@ module Git.FilePath (
import Common
import Git
+import Git.Quote
import qualified System.FilePath.ByteString as P
import qualified System.FilePath.Posix.ByteString
import GHC.Generics
import Control.DeepSeq
-import qualified Data.ByteString as S
{- A RawFilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
@@ -46,11 +46,11 @@ instance NFData TopFilePath
{- A file in a branch or other treeish. -}
data BranchFilePath = BranchFilePath Ref TopFilePath
deriving (Show, Eq, Ord)
-
+
{- Git uses the branch:file form to refer to a BranchFilePath -}
-descBranchFilePath :: BranchFilePath -> S.ByteString
+descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath
descBranchFilePath (BranchFilePath b f) =
- encodeBS' (fromRef b) <> ":" <> getTopFilePath f
+ UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
@@ -58,8 +58,7 @@ fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
-toTopFilePath file repo = TopFilePath . toRawFilePath
- <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file)
+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input RawFilePath must already be relative to the top of the git
- repository -}
diff --git a/Git/Filename.hs b/Git/Filename.hs
deleted file mode 100644
index 010e5ba..0000000
--- a/Git/Filename.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{- Some git commands output encoded filenames, in a rather annoyingly complex
- - C-style encoding.
- -
- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU AGPL version 3 or higher.
- -}
-
-module Git.Filename where
-
-import Common
-import Utility.Format (decode_c, encode_c)
-
-import Data.Char
-import Data.Word
-import qualified Data.ByteString as S
-
--- encoded filenames will be inside double quotes
-decode :: S.ByteString -> RawFilePath
-decode b = case S.uncons b of
- Nothing -> b
- Just (h, t)
- | h /= q -> b
- | otherwise -> case S.unsnoc t of
- Nothing -> b
- Just (i, l)
- | l /= q -> b
- | otherwise ->
- encodeBS $ decode_c $ decodeBS i
- where
- q :: Word8
- q = fromIntegral (ord '"')
-
-{- Should not need to use this, except for testing decode. -}
-encode :: RawFilePath -> S.ByteString
-encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
-
-prop_encode_decode_roundtrip :: FilePath -> Bool
-prop_encode_decode_roundtrip s = s' ==
- fromRawFilePath (decode (encode (toRawFilePath s')))
- where
- s' = nonul (nohigh s)
- -- Encoding and then decoding roundtrips only when
- -- the string does not contain high unicode, because eg,
- -- both "\12345" and "\227\128\185" are encoded to
- -- "\343\200\271".
- --
- -- This property papers over the problem, by only
- -- testing ascii
- nohigh = filter isAscii
- -- A String can contain a NUL, but toRawFilePath
- -- truncates on the NUL, which is generally fine
- -- because unix filenames cannot contain NUL.
- -- So the encoding only roundtrips when there is no nul.
- nonul = filter (/= '\NUL')
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 6f33e11..4544c13 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -1,4 +1,5 @@
{- git fsck interface
+i it is not fully repoducibleI repeated the same steps
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
@@ -69,37 +70,52 @@ instance Monoid FsckOutput where
- look for anything in its output (both stdout and stderr) that appears
- to be a git sha. Not all such shas are of broken objects, so ask git
- to try to cat the object, and see if it fails.
+ -
+ - Note that there is a possible false positive: When changes are being
+ - made to the repo while this is running, fsck might complain about a
+ - missing object that has not made it to disk yet. Catting the object
+ - then succeeds, so it's not included in the FsckResults. But, fsck then
+ - exits nonzero, and so FsckFailed is returned. Set ignorenonzeroexit
+ - to avoid this false positive, at the risk of perhaps missing a problem
+ - so bad that fsck crashes without outputting any missing shas.
-}
-findBroken :: Bool -> Repo -> IO FsckResults
-findBroken batchmode r = do
+findBroken :: Bool -> Bool -> Repo -> IO FsckResults
+findBroken batchmode ignorenonzeroexit r = do
let (command, params) = ("git", fsckParams r)
(command', params') <- if batchmode
then toBatchCommand (command, params)
else return (command, params)
- p@(_, _, _, pid) <- createProcess $
- (proc command' (toCommand params'))
- { std_out = CreatePipe
- , std_err = CreatePipe
- }
- (o1, o2) <- concurrently
- (parseFsckOutput maxobjs r (stdoutHandle p))
- (parseFsckOutput maxobjs r (stderrHandle p))
- fsckok <- checkSuccessProcess pid
- case mappend o1 o2 of
- FsckOutput badobjs truncated
- | S.null badobjs && not fsckok -> return FsckFailed
- | otherwise -> return $ FsckFoundMissing badobjs truncated
- NoFsckOutput
- | not fsckok -> return FsckFailed
- | otherwise -> return noproblem
- -- If all fsck output was duplicateEntries warnings,
- -- the repository is not broken, it just has some unusual
- -- tree objects in it. So ignore nonzero exit status.
- AllDuplicateEntriesWarning -> return noproblem
+ let p = (proc command' (toCommand params'))
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ withCreateProcess p go
where
+ go _ (Just outh) (Just errh) pid = do
+ (o1, o2) <- concurrently
+ (parseFsckOutput maxobjs r outh pid)
+ (parseFsckOutput maxobjs r errh pid)
+ fsckok <- checkSuccessProcess pid
+ case mappend o1 o2 of
+ FsckOutput badobjs truncated
+ | S.null badobjs && not fsckok -> return fsckfailed
+ | otherwise -> return $ FsckFoundMissing badobjs truncated
+ NoFsckOutput
+ | not fsckok -> return fsckfailed
+ | otherwise -> return noproblem
+ -- If all fsck output was duplicateEntries warnings,
+ -- the repository is not broken, it just has some
+ -- unusual tree objects in it. So ignore nonzero
+ -- exit status.
+ AllDuplicateEntriesWarning -> return noproblem
+ go _ _ _ _ = error "internal"
+
maxobjs = 10000
noproblem = FsckFoundMissing S.empty False
+ fsckfailed
+ | ignorenonzeroexit = noproblem
+ | otherwise = FsckFailed
foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
@@ -117,9 +133,9 @@ knownMissing (FsckFoundMissing s _) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput
-parseFsckOutput maxobjs r h = do
- ls <- lines <$> hGetContents h
+parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput
+parseFsckOutput maxobjs r h pid = do
+ ls <- getlines []
if null ls
then return NoFsckOutput
else if all ("duplicateEntries" `isInfixOf`) ls
@@ -129,6 +145,10 @@ parseFsckOutput maxobjs r h = do
let !truncated = length shas > maxobjs
missingobjs <- findMissing (take maxobjs shas) r
return $ FsckOutput missingobjs truncated
+ where
+ getlines c = hGetLineUntilExitOrEOF pid h >>= \case
+ Nothing -> return (reverse c)
+ Just l -> getlines (l:c)
isMissing :: Sha -> Repo -> IO Bool
isMissing s r = either (const True) (const False) <$> tryIO dump
@@ -139,7 +159,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
] r
findShas :: [String] -> [Sha]
-findShas = catMaybes . map extractSha . concat . map words . filter wanted
+findShas = catMaybes . map (extractSha . encodeBS)
+ . concat . map words . filter wanted
where
wanted l = not ("dangling " `isPrefixOf` l)
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index 3787c9c..1474c57 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -1,6 +1,6 @@
{- git hash-object interface
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -18,28 +18,50 @@ import qualified Utility.CoProcess as CoProcess
import Utility.Tmp
import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
+import Data.Char
-type HashObjectHandle = CoProcess.CoProcessHandle
+data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam]
hashObjectStart :: Bool -> Repo -> IO HashObjectHandle
-hashObjectStart writeobject = gitCoProcessStart True $ catMaybes
- [ Just (Param "hash-object")
- , if writeobject then Just (Param "-w") else Nothing
- , Just (Param "--stdin-paths")
- , Just (Param "--no-filters")
- ]
+hashObjectStart writeobject repo = do
+ h <- gitCoProcessStart True (ps ++ [Param "--stdin-paths"]) repo
+ return (HashObjectHandle h repo ps)
+ where
+ ps = catMaybes
+ [ Just (Param "hash-object")
+ , if writeobject then Just (Param "-w") else Nothing
+ , Just (Param "--no-filters")
+ ]
hashObjectStop :: HashObjectHandle -> IO ()
-hashObjectStop = CoProcess.stop
+hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h
{- Injects a file into git, returning the Sha of the object. -}
-hashFile :: HashObjectHandle -> FilePath -> IO Sha
-hashFile h file = CoProcess.query h send receive
+hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
+hashFile hdl@(HashObjectHandle h _ _) file = do
+ -- git hash-object chdirs to the top of the repository on
+ -- start, so if the filename is relative, it will
+ -- not work. This seems likely to be a git bug.
+ -- So, make the filename absolute, which will work now
+ -- and also if git's behavior later changes.
+ file' <- absPath file
+ if newline `S.elem` file'
+ then hashFile' hdl file
+ else CoProcess.query h (send file') receive
where
- send to = hPutStrLn to =<< absPath file
- receive from = getSha "hash-object" $ hGetLine from
+ send file' to = S8.hPutStrLn to file'
+ receive from = getSha "hash-object" $ S8.hGetLine from
+ newline = fromIntegral (ord '\n')
+
+{- Runs git hash-object once per call, rather than using a running
+ - one, so is slower. But, is able to handle newlines in the filepath,
+ - which --stdin-paths cannot. -}
+hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha
+hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $
+ pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo
class HashableBlob t where
hashableBlobToHandle :: Handle -> t -> IO ()
@@ -59,7 +81,7 @@ hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
- hashFile h tmp
+ hashFile h (toRawFilePath tmp)
{- Injects some content into git, returning its Sha.
-
diff --git a/Git/Index.hs b/Git/Index.hs
index afd29c2..b55fc04 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Index where
import Common
@@ -12,6 +14,8 @@ import Git
import Utility.Env
import Utility.Env.Set
+import qualified System.FilePath.ByteString as P
+
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
@@ -26,8 +30,8 @@ indexEnv = "GIT_INDEX_FILE"
-
- So, an absolute path is the only safe option for this to return.
-}
-indexEnvVal :: FilePath -> IO String
-indexEnvVal = absPath
+indexEnvVal :: RawFilePath -> IO String
+indexEnvVal p = fromRawFilePath <$> absPath p
{- Forces git to use the specified index file.
-
@@ -36,7 +40,7 @@ indexEnvVal = absPath
-
- Warning: Not thread safe.
-}
-override :: FilePath -> Repo -> IO (IO ())
+override :: RawFilePath -> Repo -> IO (IO ())
override index _r = do
res <- getEnv var
val <- indexEnvVal index
@@ -48,13 +52,13 @@ override index _r = do
reset _ = unsetEnv var
{- The normal index file. Does not check GIT_INDEX_FILE. -}
-indexFile :: Repo -> FilePath
-indexFile r = fromRawFilePath (localGitDir r) </> "index"
+indexFile :: Repo -> RawFilePath
+indexFile r = localGitDir r P.</> "index"
{- The index file git will currently use, checking GIT_INDEX_FILE. -}
-currentIndexFile :: Repo -> IO FilePath
-currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv
+currentIndexFile :: Repo -> IO RawFilePath
+currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv
{- Git locks the index by creating this file. -}
-indexFileLock :: FilePath -> FilePath
-indexFileLock f = f ++ ".lock"
+indexFileLock :: RawFilePath -> RawFilePath
+indexFileLock f = f <> ".lock"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 5534307..4eea395 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -1,22 +1,26 @@
{- git ls-files interface
-
- - Copyright 2010-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.LsFiles (
+ Options(..),
inRepo,
+ inRepoDetails,
inRepoOrBranch,
notInRepo,
notInRepoIncludingEmptyDirectories,
allFiles,
deleted,
modified,
- modifiedOthers,
staged,
stagedNotDeleted,
- stagedOthersDetails,
+ usualStageNum,
+ mergeConflictHeadStageNum,
stagedDetails,
typeChanged,
typeChangedStaged,
@@ -24,6 +28,7 @@ module Git.LsFiles (
Unmerged(..),
unmerged,
StagedDetails,
+ inodeCaches,
) where
import Common
@@ -31,101 +36,109 @@ import Git
import Git.Command
import Git.Types
import Git.Sha
+import Utility.InodeCache
+import Utility.TimeStamp
+import Utility.Attoparsec
+import qualified Utility.RawFilePath as R
-import Numeric
import System.Posix.Types
-import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import qualified Data.ByteString as S
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.Attoparsec.ByteString.Char8 as A8
+import qualified System.FilePath.ByteString as P
+
+{- It's only safe to use git ls-files on the current repo, not on a remote.
+ -
+ - Git has some strange behavior when git ls-files is used with repos
+ - that are not the one that the cwd is in:
+ - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying
+ - "../foo is outside repository".
+ - That does not happen when an absolute path is provided.
+ -
+ - Also, the files output by ls-files are relative to the cwd.
+ - Unless it's run on remote. Then it's relative to the top of the remote
+ - repo.
+ -
+ - So, best to avoid that class of problems.
+ -}
+safeForLsFiles :: Repo -> Bool
+safeForLsFiles r = isNothing (remoteName r)
+
+guardSafeForLsFiles :: Repo -> IO a -> IO a
+guardSafeForLsFiles r a
+ | safeForLsFiles r = a
+ | otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
-{- Scans for files that are checked into git's index at the specified locations. -}
-inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepo = inRepo' []
+data Options = ErrorUnmatch
-inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepo' ps l repo = pipeNullSplit' params repo
+opParam :: Options -> CommandParam
+opParam ErrorUnmatch = Param "--error-unmatch"
+
+{- Lists files that are checked into git's index at the specified paths.
+ - With no paths, all files are listed.
+ -}
+inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo = inRepo' [Param "--cached"]
+
+inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
where
params =
Param "ls-files" :
- Param "--cached" :
Param "-z" :
- ps ++
+ map opParam os ++ ps ++
(Param "--" : map (File . fromRawFilePath) l)
+{- Lists the same files inRepo does, but with sha and mode. -}
+inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool)
+inRepoDetails = stagedDetails' parser . map opParam
+ where
+ parser s = case parseStagedDetails s of
+ Just (file, sha, mode, stagenum)
+ | stagenum == usualStageNum || stagenum == mergeConflictHeadStageNum ->
+ Just (file, sha, mode)
+ _ -> Nothing
+
{- Files that are checked into the index or have been committed to a
- branch. -}
-inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]
+inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepoOrBranch b = inRepo'
+ [ Param "--cached"
+ , Param ("--with-tree=" ++ fromRef b)
+ ]
{- Scans for files at the specified locations that are not checked into git. -}
-notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo = notInRepo' []
-notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-notInRepo' ps include_ignored l repo = pipeNullSplit' params repo
+notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepo' ps os include_ignored =
+ inRepo' (Param "--others" : ps ++ exclude) os
where
- params = concat
- [ [ Param "ls-files", Param "--others"]
- , ps
- , exclude
- , [ Param "-z", Param "--" ]
- , map (File . fromRawFilePath) l
- ]
exclude
| include_ignored = []
| otherwise = [Param "--exclude-standard"]
{- Scans for files at the specified locations that are not checked into
- git. Empty directories are included in the result. -}
-notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
{- Finds all files in the specified locations, whether checked into git or
- not. -}
-allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-allFiles l = pipeNullSplit' $
- Param "ls-files" :
- Param "--cached" :
- Param "--others" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+allFiles = inRepo' [Param "--cached", Param "--others"]
{- Returns a list of files in the specified locations that have been
- deleted. -}
-deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-deleted l repo = pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--deleted" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+deleted = inRepo' [Param "--deleted"]
{- Returns a list of files in the specified locations that have been
- modified. -}
-modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-modified l repo = pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--modified" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
-
-{- Files that have been modified or are not checked into git (and are not
- - ignored). -}
-modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-modifiedOthers l repo = pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--modified" :
- Param "--others" :
- Param "--exclude-standard" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+modified = inRepo' [Param "--modified"]
{- Returns a list of all files that are staged for commit. -}
staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
@@ -137,38 +150,55 @@ stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo
+staged' ps l repo = guardSafeForLsFiles repo $
+ pipeNullSplit' (prefix ++ ps ++ suffix) repo
where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
suffix = Param "--" : map (File . fromRawFilePath) l
-type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)
+type StagedDetails = (RawFilePath, Sha, FileMode, StageNum)
+
+type StageNum = Int
-{- Returns details about files that are staged in the index,
- - as well as files not yet in git. Skips ignored files. -}
-stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
+{- Used when not in a merge conflict. -}
+usualStageNum :: Int
+usualStageNum = 0
-{- Returns details about all files that are staged in the index. -}
+{- WHen in a merge conflict, git uses stage number 2 for the local HEAD
+ - side of the merge conflict. -}
+mergeConflictHeadStageNum :: Int
+mergeConflictHeadStageNum = 2
+
+{- Returns details about all files that are staged in the index.
+ -
+ - Note that, during a conflict, a file will appear in the list
+ - more than once with different stage numbers.
+ -}
stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedDetails = stagedDetails' []
+stagedDetails = stagedDetails' parseStagedDetails []
-{- Gets details about staged files, including the Sha of their staged
- - contents. -}
-stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedDetails' ps l repo = do
- (ls, cleanup) <- pipeNullSplit params repo
- return (map parse ls, cleanup)
+stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool)
+stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do
+ (ls, cleanup) <- pipeNullSplit' params repo
+ return (mapMaybe parser ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map (File . fromRawFilePath) l
- parse s
- | null file = (L.toStrict s, Nothing, Nothing)
- | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)
- where
- (metadata, file) = separate (== '\t') (decodeBL' s)
- (mode, rest) = separate (== ' ') metadata
- readmode = fst <$$> headMaybe . readOct
+
+parseStagedDetails :: S.ByteString -> Maybe StagedDetails
+parseStagedDetails = eitherToMaybe . A.parseOnly parser
+ where
+ parser = do
+ mode <- octal
+ void $ A8.char ' '
+ sha <- maybe (fail "bad sha") return . extractSha =<< nextword
+ void $ A8.char ' '
+ stagenum <- A8.decimal
+ void $ A8.char '\t'
+ file <- A.takeByteString
+ return (file, sha, mode, stagenum)
+
+ nextword = A8.takeTill (== ' ')
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
@@ -181,13 +211,13 @@ typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged = typeChanged' []
typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-typeChanged' ps l repo = do
- (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
+typeChanged' ps l repo = guardSafeForLsFiles 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.
- top <- absPath (fromRawFilePath (repoPath repo))
- currdir <- getCurrentDirectory
- return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
+ top <- absPath (repoPath repo)
+ currdir <- R.getCurrentDirectory
+ return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
where
prefix =
[ Param "diff"
@@ -208,7 +238,14 @@ data Unmerged = Unmerged
{ unmergedFile :: RawFilePath
, unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha
- }
+ , unmergedSiblingFile :: Maybe RawFilePath
+ -- ^ Normally this is Nothing, because a
+ -- merge conflict is represented as a single file with two
+ -- stages. However, git resolvers sometimes choose to stage
+ -- two files, one for each side of the merge conflict. In such a case,
+ -- this is used for the name of the second file, which is related
+ -- to the first file. (Eg, "foo" and "foo~ref")
+ } deriving (Show)
{- Returns a list of the files in the specified locations that have
- unresolved merge conflicts.
@@ -218,12 +255,12 @@ data Unmerged = Unmerged
- 1 = old version, can be ignored
- 2 = us
- 3 = them
- - If a line is omitted, that side removed the file.
+ - If line 2 or 3 is omitted, that side removed the file.
-}
unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
-unmerged l repo = do
+unmerged l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit params repo
- return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
+ return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
where
params =
Param "ls-files" :
@@ -237,7 +274,7 @@ data InternalUnmerged = InternalUnmerged
, ifile :: RawFilePath
, itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha
- }
+ } deriving (Show)
parseUnmerged :: String -> Maybe InternalUnmerged
parseUnmerged s
@@ -249,7 +286,7 @@ parseUnmerged s
then Nothing
else do
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
- sha <- extractSha rawsha
+ sha <- extractSha (encodeBS rawsha)
return $ InternalUnmerged (stage == 2) (toRawFilePath file)
(Just treeitemtype) (Just sha)
_ -> Nothing
@@ -268,13 +305,72 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
{ unmergedFile = ifile i
, unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB
, unmergedSha = Conflicting shaA shaB
+ , unmergedSiblingFile = if ifile sibi == ifile i
+ then Nothing
+ else Just (ifile sibi)
}
findsib templatei [] = ([], removed templatei)
findsib templatei (l:ls)
- | ifile l == ifile templatei = (ls, l)
+ | ifile l == ifile templatei || issibfile templatei l = (ls, l)
| otherwise = (l:ls, removed templatei)
removed templatei = templatei
{ isus = not (isus templatei)
, itreeitemtype = Nothing
, isha = Nothing
}
+ -- foo~<ref> are unmerged sibling files of foo
+ -- Some versions or resolvers of git stage the sibling files,
+ -- other versions or resolvers do not.
+ issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y
+ && isus x || isus y
+ && not (isus x && isus y)
+
+{- Gets the InodeCache equivalent information stored in the git index.
+ -
+ - Note that this uses a --debug option whose output could change at some
+ - point in the future. If the output is not as expected, will use Nothing.
+ -}
+inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
+inodeCaches locs repo = guardSafeForLsFiles repo $ do
+ (ls, cleanup) <- pipeNullSplit params repo
+ return (parse Nothing (map decodeBL ls), cleanup)
+ where
+ params =
+ Param "ls-files" :
+ Param "--cached" :
+ Param "-z" :
+ Param "--debug" :
+ Param "--" :
+ map (File . fromRawFilePath) locs
+
+ parse Nothing (f:ls) = parse (Just f) ls
+ parse (Just f) (s:[]) =
+ let i = parsedebug s
+ in (f, i) : []
+ parse (Just f) (s:ls) =
+ let (d, f') = splitdebug s
+ i = parsedebug d
+ in (f, i) : parse (Just f') ls
+ parse _ _ = []
+
+ -- First 5 lines are --debug output, remainder is the next filename.
+ -- This assumes that --debug does not start outputting more lines.
+ splitdebug s = case splitc '\n' s of
+ (d1:d2:d3:d4:d5:rest) ->
+ ( intercalate "\n" [d1, d2, d3, d4, d5]
+ , intercalate "\n" rest
+ )
+ _ -> ("", s)
+
+ -- This parser allows for some changes to the --debug output,
+ -- including reordering, or adding more items.
+ parsedebug s = do
+ let l = words s
+ let iskey v = ":" `isSuffixOf` v
+ let m = M.fromList $ zip
+ (filter iskey l)
+ (filter (not . iskey) l)
+ mkInodeCache
+ <$> (readish =<< M.lookup "ino:" m)
+ <*> (readish =<< M.lookup "size:" m)
+ <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m))
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index a3d8383..9129d18 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,17 +1,18 @@
{- git ls-tree interface
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE BangPatterns #-}
-
module Git.LsTree (
TreeItem(..),
- LsTreeMode(..),
+ LsTreeRecursive(..),
+ LsTreeLong(..),
lsTree,
lsTree',
+ lsTreeStrict,
+ lsTreeStrict',
lsTreeParams,
lsTreeFiles,
parseLsTree,
@@ -21,16 +22,17 @@ module Git.LsTree (
import Common
import Git
import Git.Command
-import Git.Sha
import Git.FilePath
-import qualified Git.Filename
+import qualified Git.Quote
import Utility.Attoparsec
import Numeric
import Data.Either
+import Data.Char
import System.Posix.Types
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
+import qualified Data.Attoparsec.ByteString as AS
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
@@ -38,37 +40,55 @@ data TreeItem = TreeItem
{ mode :: FileMode
, typeobj :: S.ByteString
, sha :: Ref
+ , size :: Maybe FileSize
, file :: TopFilePath
- } deriving Show
+ -- ^ only available when long is used
+ } deriving (Show)
+
+data LsTreeRecursive = LsTreeRecursive | LsTreeNonRecursive
-data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive
+{- Enabling --long also gets the size of tree items.
+ - This slows down ls-tree some, since it has to look up the size of each
+ - blob.
+ -}
+data LsTreeLong = LsTreeLong Bool
{- Lists the contents of a tree, with lazy output. -}
-lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool)
lsTree = lsTree' []
-lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
-lsTree' ps lsmode t repo = do
- (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
- return (rights (map parseLsTree l), cleanup)
+lsTree' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree' ps recursive long t repo = do
+ (l, cleanup) <- pipeNullSplit (lsTreeParams recursive long t ps) repo
+ return (rights (map (parseLsTree long) l), cleanup)
+
+lsTreeStrict :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict = lsTreeStrict' []
-lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
-lsTreeParams lsmode r ps =
+lsTreeStrict' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict' ps recursive long t repo = rights . map (parseLsTreeStrict long)
+ <$> pipeNullSplitStrict (lsTreeParams recursive long t ps) repo
+
+lsTreeParams :: LsTreeRecursive -> LsTreeLong -> Ref -> [CommandParam] -> [CommandParam]
+lsTreeParams recursive long r ps =
[ Param "ls-tree"
, Param "--full-tree"
, Param "-z"
- ] ++ recursiveparams ++ ps ++
+ ] ++ recursiveparams ++ longparams ++ ps ++
[ Param "--"
, File $ fromRef r
]
where
- recursiveparams = case lsmode of
+ recursiveparams = case recursive of
LsTreeRecursive -> [ Param "-r" ]
LsTreeNonRecursive -> []
+ longparams = case long of
+ LsTreeLong True -> [ Param "--long" ]
+ LsTreeLong False -> []
{- Lists specified files in a tree. -}
-lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
-lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
+lsTreeFiles :: LsTreeLong -> Ref -> [FilePath] -> Repo -> IO [TreeItem]
+lsTreeFiles long t fs repo = rights . map (parseLsTree long . L.fromStrict)
<$> pipeNullSplitStrict ps repo
where
ps =
@@ -79,34 +99,57 @@ lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
, File $ fromRef t
] ++ map File fs
-parseLsTree :: L.ByteString -> Either String TreeItem
-parseLsTree b = case A.parse parserLsTree b of
+parseLsTree :: LsTreeLong -> L.ByteString -> Either String TreeItem
+parseLsTree long b = case A.parse (parserLsTree long) b of
A.Done _ r -> Right r
A.Fail _ _ err -> Left err
+parseLsTreeStrict :: LsTreeLong -> S.ByteString -> Either String TreeItem
+parseLsTreeStrict long b = go (AS.parse (parserLsTree long) b)
+ where
+ go (AS.Done _ r) = Right r
+ go (AS.Fail _ _ err) = Left err
+ go (AS.Partial c) = go (c mempty)
+
{- Parses a line of ls-tree output, in format:
- - mode SP type SP sha TAB file
+ - mode SP type SP sha TAB file
+ - Or long format:
+ - mode SP type SP sha SPACES size TAB file
-
- - (The --long format is not currently supported.) -}
-parserLsTree :: A.Parser TreeItem
-parserLsTree = TreeItem
- -- mode
- <$> octal
- <* A8.char ' '
- -- type
- <*> A.takeTill (== 32)
- <* A8.char ' '
- -- sha
- <*> (Ref . decodeBS' <$> A.take shaSize)
- <* A8.char '\t'
- -- file
- <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
-
-{- Inverse of parseLsTree -}
-formatLsTree :: TreeItem -> String
-formatLsTree ti = unwords
- [ showOct (mode ti) ""
- , decodeBS (typeobj ti)
- , fromRef (sha ti)
- , fromRawFilePath (getTopFilePath (file ti))
- ]
+ - The TAB can also be a space. Git does not use that, but an earlier
+ - version of formatLsTree did, and this keeps parsing what it output
+ - working.
+ -}
+parserLsTree :: LsTreeLong -> A.Parser TreeItem
+parserLsTree long = case long of
+ LsTreeLong False ->
+ startparser <*> pure Nothing <* filesep <*> fileparser
+ LsTreeLong True ->
+ startparser <* sizesep <*> sizeparser <* filesep <*> fileparser
+ where
+ startparser = TreeItem
+ -- mode
+ <$> octal
+ <* A8.char ' '
+ -- type
+ <*> A8.takeTill (== ' ')
+ <* A8.char ' '
+ -- sha
+ <*> (Ref <$> A8.takeTill A8.isSpace)
+
+ fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString
+
+ sizeparser = fmap Just A8.decimal
+
+ filesep = A8.space
+
+ sizesep = A.many1 A8.space
+
+{- Inverse of parseLsTree. Note that the long output format is not
+ - generated, so any size information is not included. -}
+formatLsTree :: TreeItem -> S.ByteString
+formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
+ [ encodeBS (showOct (mode ti) "")
+ , typeobj ti
+ , fromRef' (sha ti)
+ ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))
diff --git a/Git/Objects.hs b/Git/Objects.hs
index c9ede4d..9b7165c 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -5,39 +5,45 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Objects where
import Common
import Git
import Git.Sha
-objectsDir :: Repo -> FilePath
-objectsDir r = fromRawFilePath (localGitDir r) </> "objects"
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
+
+objectsDir :: Repo -> RawFilePath
+objectsDir r = localGitDir r P.</> "objects"
-packDir :: Repo -> FilePath
-packDir r = objectsDir r </> "pack"
+packDir :: Repo -> RawFilePath
+packDir r = objectsDir r P.</> "pack"
-packIdxFile :: FilePath -> FilePath
-packIdxFile = flip replaceExtension "idx"
+packIdxFile :: RawFilePath -> RawFilePath
+packIdxFile = flip P.replaceExtension "idx"
listPackFiles :: Repo -> IO [FilePath]
listPackFiles r = filter (".pack" `isSuffixOf`)
- <$> catchDefaultIO [] (dirContents $ packDir r)
+ <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
- mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
- <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)
+ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
+ <$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r))
-looseObjectFile :: Repo -> Sha -> FilePath
-looseObjectFile r sha = objectsDir r </> prefix </> rest
+looseObjectFile :: Repo -> Sha -> RawFilePath
+looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
where
- (prefix, rest) = splitAt 2 (fromRef sha)
+ (prefix, rest) = B.splitAt 2 (fromRef' sha)
listAlternates :: Repo -> IO [FilePath]
-listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile)
+listAlternates r = catchDefaultIO [] $
+ lines <$> readFile (fromRawFilePath alternatesfile)
where
- alternatesfile = objectsDir r </> "info" </> "alternates"
+ alternatesfile = objectsDir r P.</> "info" P.</> "alternates"
{- A repository recently cloned with --shared will have one or more
- alternates listed, and contain no loose objects or packs. -}
diff --git a/Git/Quote.hs b/Git/Quote.hs
new file mode 100644
index 0000000..2ca442e
--- /dev/null
+++ b/Git/Quote.hs
@@ -0,0 +1,122 @@
+{- Some git commands output quoted filenames, in a rather annoyingly complex
+ - C-style encoding.
+ -
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}
+
+module Git.Quote (
+ unquote,
+ quote,
+ noquote,
+ QuotePath(..),
+ StringContainingQuotedPath(..),
+ quotedPaths,
+ prop_quote_unquote_roundtrip,
+) where
+
+import Common
+import Utility.Format (decode_c, encode_c, encode_c', isUtf8Byte)
+import Utility.QuickCheck
+import Utility.SafeOutput
+
+import Data.Char
+import Data.Word
+import Data.String
+import qualified Data.ByteString as S
+import qualified Data.Semigroup as Sem
+import Prelude
+
+unquote :: S.ByteString -> RawFilePath
+unquote b = case S.uncons b of
+ Nothing -> b
+ Just (h, t)
+ | h /= q -> b
+ | otherwise -> case S.unsnoc t of
+ Nothing -> b
+ Just (i, l)
+ | l /= q -> b
+ | otherwise -> decode_c i
+ where
+ q :: Word8
+ q = fromIntegral (ord '"')
+
+-- always encodes and double quotes, even in cases that git does not
+quoteAlways :: RawFilePath -> S.ByteString
+quoteAlways s = "\"" <> encode_c needencode s <> "\""
+ where
+ needencode c = isUtf8Byte c || c == fromIntegral (ord '"')
+
+-- git config core.quotePath controls whether to quote unicode characters
+newtype QuotePath = QuotePath Bool
+
+class Quoteable t where
+ -- double quotes and encodes when git would
+ quote :: QuotePath -> t -> S.ByteString
+
+ noquote :: t -> S.ByteString
+
+instance Quoteable RawFilePath where
+ quote (QuotePath qp) s = case encode_c' needencode s of
+ Nothing -> s
+ Just s' -> "\"" <> s' <> "\""
+ where
+ needencode c
+ | c == fromIntegral (ord '"') = True
+ | qp = isUtf8Byte c
+ | otherwise = False
+
+ noquote = id
+
+-- Allows building up a string that contains paths, which will get quoted.
+-- With OverloadedStrings, strings are passed through without quoting.
+-- Eg: QuotedPath f <> ": not found"
+data StringContainingQuotedPath
+ = UnquotedString String
+ | UnquotedByteString S.ByteString
+ | QuotedPath RawFilePath
+ | StringContainingQuotedPath :+: StringContainingQuotedPath
+ deriving (Show, Eq)
+
+quotedPaths :: [RawFilePath] -> StringContainingQuotedPath
+quotedPaths [] = mempty
+quotedPaths (p:ps) = QuotedPath p <> if null ps
+ then mempty
+ else " " <> quotedPaths ps
+
+instance Quoteable StringContainingQuotedPath where
+ quote _ (UnquotedString s) = safeOutput (encodeBS s)
+ quote _ (UnquotedByteString s) = safeOutput s
+ quote qp (QuotedPath p) = quote qp p
+ quote qp (a :+: b) = quote qp a <> quote qp b
+
+ noquote (UnquotedString s) = encodeBS s
+ noquote (UnquotedByteString s) = s
+ noquote (QuotedPath p) = p
+ noquote (a :+: b) = noquote a <> noquote b
+
+instance IsString StringContainingQuotedPath where
+ fromString = UnquotedByteString . encodeBS
+
+instance Sem.Semigroup StringContainingQuotedPath where
+ UnquotedString a <> UnquotedString b = UnquotedString (a <> b)
+ UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b)
+ a <> b = a :+: b
+
+instance Monoid StringContainingQuotedPath where
+ mempty = UnquotedByteString mempty
+
+-- Encoding and then decoding roundtrips only when the string does not
+-- contain high unicode, because eg, both "\12345" and "\227\128\185"
+-- are encoded to "\343\200\271".
+--
+-- That is not a real-world problem, and using TestableFilePath
+-- limits what's tested to ascii, so avoids running into it.
+prop_quote_unquote_roundtrip :: TestableFilePath -> Bool
+prop_quote_unquote_roundtrip ts =
+ s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s)))
+ where
+ s = fromTestableFilePath ts
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 621e328..2d2874a 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -1,6 +1,6 @@
{- git ref stuff
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -14,9 +14,11 @@ import Git
import Git.Command
import Git.Sha
import Git.Types
+import Git.FilePath
import Data.Char (chr, ord)
import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
headRef :: Ref
headRef = Ref "HEAD"
@@ -25,7 +27,7 @@ headFile :: Repo -> FilePath
headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
-setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)
+setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
@@ -41,10 +43,11 @@ base = removeBase "refs/heads/" . removeBase "refs/remotes/"
{- Removes a directory such as "refs/heads/master" from a
- fully qualified ref. Any ref not starting with it is left as-is. -}
removeBase :: String -> Ref -> Ref
-removeBase dir (Ref r)
- | prefix `isPrefixOf` r = Ref (drop (length prefix) r)
- | otherwise = Ref r
+removeBase dir r
+ | prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs
+ | otherwise = r
where
+ rs = fromRef r
prefix = case end dir of
['/'] -> dir
_ -> dir ++ "/"
@@ -53,7 +56,7 @@ removeBase dir (Ref r)
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
underBase :: String -> Ref -> Ref
-underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
+underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r)
{- Convert a branch such as "master" into a fully qualified ref. -}
branchRef :: Branch -> Ref
@@ -61,26 +64,49 @@ branchRef = underBase "refs/heads"
{- A Ref that can be used to refer to a file in the repository, as staged
- in the index.
- -
- - Prefixing the file with ./ makes this work even if in a subdirectory
- - of a repo.
+ -
+ - If the input file is located outside the repository, returns Nothing.
-}
-fileRef :: RawFilePath -> Ref
-fileRef f = Ref $ ":./" ++ fromRawFilePath f
+fileRef :: RawFilePath -> Repo -> IO (Maybe Ref)
+fileRef f repo = do
+ -- The filename could be absolute, or contain eg "../repo/file",
+ -- neither of which work in a ref, so convert it to a minimal
+ -- relative path.
+ f' <- relPathCwdToFile f
+ return $ if repoPath repo `dirContains` f'
+ -- Prefixing the file with ./ makes this work even when in a
+ -- subdirectory of a repo. Eg, ./foo in directory bar refers
+ -- to bar/foo, not to foo in the top of the repository.
+ then Just $ Ref $ ":./" <> toInternalGitPath f'
+ else Nothing
+
+{- A Ref that can be used to refer to a file in a particular branch. -}
+branchFileRef :: Branch -> RawFilePath -> Ref
+branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
-dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
+dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d
{- A Ref that can be used to refer to a file in the repository as it
- - appears in a given Ref. -}
-fileFromRef :: Ref -> RawFilePath -> Ref
-fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
+ - appears in a given Ref.
+ -
+ - If the file path is located outside the repository, returns Nothing.
+ -}
+fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref)
+fileFromRef r f repo = fileRef f repo >>= return . \case
+ Just (Ref fr) -> Just (Ref (fromRef' r <> fr))
+ Nothing -> Nothing
-{- Checks if a ref exists. -}
+{- Checks if a ref exists. Note that it must be fully qualified,
+ - eg refs/heads/master rather than master. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool
- [Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
+ [ Param "show-ref"
+ , Param "--verify"
+ , Param "-q"
+ , Param $ fromRef ref
+ ]
{- The file used to record a ref. (Git also stores some refs in a
- packed-refs file.) -}
@@ -107,26 +133,26 @@ sha branch repo = process <$> showref repo
]
process s
| S.null s = Nothing
- | otherwise = Just $ Ref $ decodeBS' $ firstLine' s
+ | otherwise = 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
+matching = matching' []
{- Includes HEAD in the output, if asked for it. -}
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
+matchingWithHEAD = matching' [Param "--head"]
-{- List of (shas, branches) matching a given ref spec. -}
-matching' :: [String] -> Repo -> IO [(Sha, Branch)]
-matching' ps repo = map gen . lines . decodeBS' <$>
- pipeReadStrict (Param "show-ref" : map Param ps) repo
+matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)]
+matching' ps rs repo = map gen . S8.lines <$>
+ pipeReadStrict (Param "show-ref" : ps ++ rps) repo
where
- gen l = let (r, b) = separate (== ' ') l
+ gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l
in (Ref r, Ref b)
+ rps = map (Param . fromRef) rs
{- List of (shas, branches) matching a given ref.
- Duplicate shas are filtered out. -}
@@ -137,7 +163,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
{- List of all refs. -}
list :: Repo -> IO [(Sha, Ref)]
-list = matching' []
+list = matching' [] []
{- Deletes a ref. This can delete refs that are not branches,
- which git branch --delete refuses to delete. -}
@@ -154,13 +180,17 @@ delete oldvalue ref = run
- The ref may be something like a branch name, and it could contain
- ":subdir" if a subtree is wanted. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
-tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict
- [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]
+tree (Ref ref) = extractSha <$$> pipeReadStrict
+ [ Param "rev-parse"
+ , Param "--verify"
+ , Param "--quiet"
+ , Param (decodeBS ref')
+ ]
where
- ref' = if ":" `isInfixOf` ref
+ ref' = if ":" `S.isInfixOf` ref
then ref
-- de-reference commit objects to the tree
- else ref ++ ":"
+ else ref <> ":"
{- Checks if a String is a legal git ref name.
-
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
index 7ba8713..b98833c 100644
--- a/Git/RefLog.hs
+++ b/Git/RefLog.hs
@@ -12,6 +12,9 @@ import Git
import Git.Command
import Git.Sha
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+
{- Gets the reflog for a given branch. -}
get :: Branch -> Repo -> IO [Sha]
get b = getMulti [b]
@@ -21,7 +24,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha]
getMulti bs = get' (map (Param . fromRef) bs)
get' :: [CommandParam] -> Repo -> IO [Sha]
-get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'
+get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps'
where
ps' = catMaybes
[ Just $ Param "log"
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 69d6b52..9cdaad6 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -1,6 +1,6 @@
{- git remote stuff
-
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -23,19 +23,27 @@ import Network.URI
import Git.FilePath
#endif
-{- Is a git config key one that specifies the location of a remote? -}
-isRemoteKey :: ConfigKey -> Bool
-isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k
+{- Is a git config key one that specifies the url of a remote? -}
+isRemoteUrlKey :: ConfigKey -> Bool
+isRemoteUrlKey = isRemoteKey "url"
-{- Get a remote's name from the config key that specifies its location. -}
-remoteKeyToRemoteName :: ConfigKey -> RemoteName
-remoteKeyToRemoteName (ConfigKey k) = decodeBS' $
- S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
+isRemoteKey :: S.ByteString -> ConfigKey -> Bool
+isRemoteKey want (ConfigKey k) =
+ "remote." `S.isPrefixOf` k && ("." <> want) `S.isSuffixOf` k
+
+{- Get a remote's name from the a config key such as remote.name.url
+ - or any other per-remote config key. -}
+remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName
+remoteKeyToRemoteName (ConfigKey k)
+ | "remote." `S.isPrefixOf` k =
+ let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
+ in if S.null n then Nothing else Just (decodeBS n)
+ | otherwise = Nothing
{- Construct a legal git remote name out of an arbitrary input string.
-
- There seems to be no formal definition of this in the git source,
- - just some ad-hoc checks, and some other things that fail with certian
+ - just some ad-hoc checks, and some other things that fail with certain
- types of names (like ones starting with '-').
-}
makeLegalName :: String -> RemoteName
@@ -55,7 +63,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of
legal c = isAlphaNum c
data RemoteLocation = RemoteUrl String | RemotePath FilePath
- deriving (Eq)
+ deriving (Eq, Show)
remoteLocationIsUrl :: RemoteLocation -> Bool
remoteLocationIsUrl (RemoteUrl _) = True
@@ -67,34 +75,43 @@ remoteLocationIsSshUrl _ = False
{- Determines if a given remote location is an url, or a local
- path. Takes the repository's insteadOf configuration into account. -}
-parseRemoteLocation :: String -> Repo -> RemoteLocation
-parseRemoteLocation s repo = ret $ calcloc s
+parseRemoteLocation :: String -> Bool -> Repo -> RemoteLocation
+parseRemoteLocation s knownurl repo = go
where
- ret v
+ s' = calcloc s
+ go
#ifdef mingw32_HOST_OS
- | dosstyle v = RemotePath (dospath v)
+ | dosstyle s' = RemotePath (dospath s')
#endif
- | scpstyle v = RemoteUrl (scptourl v)
- | urlstyle v = RemoteUrl v
- | otherwise = RemotePath v
+ | scpstyle s' = RemoteUrl (scptourl s')
+ | urlstyle s' = RemoteUrl s'
+ | knownurl && s' == s = RemoteUrl s'
+ | otherwise = RemotePath s'
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
| otherwise = replacement ++ drop (S.length bestvalue) l
where
- replacement = decodeBS' $ S.drop (S.length prefix) $
+ replacement = decodeBS $ S.drop (S.length prefix) $
S.take (S.length bestkey - S.length suffix) bestkey
- (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs
+ (bestkey, bestvalue) =
+ case maximumBy longestvalue insteadofs of
+ (ConfigKey k, ConfigValue v) -> (k, v)
+ (ConfigKey k, NoConfigValue) -> (k, mempty)
longestvalue (_, a) (_, b) = compare b a
- insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) ->
- prefix `S.isPrefixOf` k &&
- suffix `S.isSuffixOf` k &&
- v `S.isPrefixOf` encodeBS l
+ insteadofs = filterconfig $ \case
+ (ConfigKey k, ConfigValue v) ->
+ prefix `S.isPrefixOf` k &&
+ suffix `S.isSuffixOf` k &&
+ v `S.isPrefixOf` encodeBS l
+ (_, NoConfigValue) -> False
filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs
(prefix, suffix) = ("url." , ".insteadof")
- urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+ -- git supports URIs that contain unescaped characters such as
+ -- spaces. So to test if it's a (git) URI, escape those.
+ urlstyle v = isURI (escapeURIString isUnescapedInURI v)
-- git remotes can be written scp style -- [user@]host:dir
-- but foo::bar is a git-remote-helper location instead
scpstyle v = ":" `isInfixOf` v
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 66e6811..cea57df 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -1,10 +1,12 @@
{- git repository recovery
-
- - Copyright 2013-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Repair (
runRepair,
runRepairOf,
@@ -27,6 +29,8 @@ import Git.Sha
import Git.Types
import Git.Fsck
import Git.Index
+import Git.Env
+import Git.FilePath
import qualified Git.Config as Config
import qualified Git.Construct as Construct
import qualified Git.LsTree as LsTree
@@ -35,13 +39,15 @@ import qualified Git.Ref as Ref
import qualified Git.RefLog as RefLog
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Branch as Branch
+import Utility.Directory.Create
import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
-import Utility.Tuple
+import qualified Utility.RawFilePath as R
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
+import qualified System.FilePath.ByteString as P
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects. -}
@@ -51,21 +57,20 @@ cleanCorruptObjects fsckresults r = do
mapM_ removeLoose (S.toList $ knownMissing fsckresults)
mapM_ removeBad =<< listLooseObjectShas r
where
- removeLoose s = nukeFile (looseObjectFile r s)
+ removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s)
removeBad s = do
- void $ tryIO $ allowRead $ looseObjectFile r s
+ void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $
removeLoose s
-{- Explodes all pack files, and deletes them.
- -
- - First moves all pack files to a temp dir, before unpacking them each in
- - turn.
+{- Explodes all pack files to loose objects, and deletes the pack files.
-
- - This is because unpack-objects will not unpack a pack file if it's in the
- - git repo.
+ - git unpack-objects will not unpack objects from a pack file that are
+ - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary
+ - directory, and the loose objects then are moved into place, before
+ - deleting the pack files.
-
- - Also, this prevents unpack-objects from possibly looking at corrupt
+ - Also, that prevents unpack-objects from possibly looking at corrupt
- pack files to see if they contain an object, while unpacking a
- non-corrupt pack file.
-}
@@ -74,21 +79,32 @@ explodePacks r = go =<< listPackFiles r
where
go [] = return False
go packs = withTmpDir "packs" $ \tmpdir -> do
+ r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
- moveFile packfile (tmpdir </> takeFileName packfile)
- nukeFile $ packIdxFile packfile
- forM_ packs $ \packfile -> do
- let tmp = tmpdir </> takeFileName packfile
- allowRead tmp
+ -- Just in case permissions are messed up.
+ allowRead (toRawFilePath packfile)
-- May fail, if pack file is corrupt.
void $ tryIO $
- pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
- L.hPut h =<< L.readFile tmp
+ pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
+ L.hPut h =<< L.readFile packfile
+ objs <- dirContentsRecursive tmpdir
+ forM_ objs $ \objfile -> do
+ f <- relPathDirToFile
+ (toRawFilePath tmpdir)
+ (toRawFilePath objfile)
+ let dest = objectsDir r P.</> f
+ createDirectoryIfMissing True
+ (fromRawFilePath (parentDir dest))
+ moveFile (toRawFilePath objfile) dest
+ forM_ packs $ \packfile -> do
+ let f = toRawFilePath packfile
+ removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith R.removeLink (packIdxFile f)
return True
{- Try to retrieve a set of missing objects, from the remotes of a
- - repository. Returns any that could not be retreived.
+ - repository. Returns any that could not be retrieved.
-
- If another clone of the repository exists locally, which might not be a
- remote of the repo being repaired, its path can be passed as a reference
@@ -99,8 +115,11 @@ retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
- error $ "failed to create temp repository in " ++ tmpdir
- tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
+ giveup $ "failed to create temp repository in " ++ tmpdir
+ tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
+ let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")
+ whenM (doesFileExist (repoconfig r)) $
+ L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
@@ -122,24 +141,26 @@ retrieveMissingObjects missing referencerepo r
)
pullremotes tmpr (rmt:rmts) fetchrefs ms
| not (foundBroken ms) = return ms
- | otherwise = do
- putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
- ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
- ( do
- void $ explodePacks tmpr
- void $ copyObjects tmpr r
- case ms of
- FsckFailed -> pullremotes tmpr rmts fetchrefs ms
- FsckFoundMissing s t -> do
- stillmissing <- findMissing (S.toList s) r
- pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t)
- , pullremotes tmpr rmts fetchrefs ms
- )
- fetchfrom fetchurl ps fetchr = runBool ps' fetchr'
+ | otherwise = case remoteName rmt of
+ Just n -> do
+ putStrLn $ "Trying to recover missing objects from remote " ++ n ++ "."
+ ifM (fetchfrom n fetchrefs tmpr)
+ ( do
+ void $ explodePacks tmpr
+ void $ copyObjects tmpr r
+ case ms of
+ FsckFailed -> pullremotes tmpr rmts fetchrefs ms
+ FsckFoundMissing s t -> do
+ stillmissing <- findMissing (S.toList s) r
+ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t)
+ , pullremotes tmpr rmts fetchrefs ms
+ )
+ Nothing -> pullremotes tmpr rmts fetchrefs ms
+ fetchfrom loc ps fetchr = runBool ps' fetchr'
where
ps' =
[ Param "fetch"
- , Param fetchurl
+ , Param loc
, Param "--force"
, Param "--update-head-ok"
, Param "--quiet"
@@ -159,8 +180,8 @@ retrieveMissingObjects missing referencerepo r
copyObjects :: Repo -> Repo -> IO Bool
copyObjects srcr destr = rsync
[ Param "-qr"
- , File $ addTrailingPathSeparator $ objectsDir srcr
- , File $ addTrailingPathSeparator $ objectsDir destr
+ , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr
+ , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr
]
{- To deal with missing objects that cannot be recovered, resets any
@@ -232,23 +253,27 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
getAllRefs' :: FilePath -> IO [Ref]
getAllRefs' refdir = do
let topsegs = length (splitPath refdir) - 1
- let toref = Ref . joinPath . drop topsegs . splitPath
+ let toref = Ref . toInternalGitPath . encodeBS
+ . joinPath . drop topsegs . splitPath
map toref <$> dirContentsRecursive refdir
explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
let f = packedRefsFile r
+ let f' = toRawFilePath f
whenM (doesFileExist f) $ do
rs <- mapMaybe parsePacked . lines
- <$> catchDefaultIO "" (safeReadFile f)
+ <$> catchDefaultIO "" (safeReadFile f')
forM_ rs makeref
- nukeFile f
+ removeWhenExistsWith R.removeLink f'
where
makeref (sha, ref) = do
- let dest = fromRawFilePath (localGitDir r) </> fromRef ref
- createDirectoryIfMissing True (parentDir dest)
- unlessM (doesFileExist dest) $
- writeFile dest (fromRef sha)
+ let gitd = localGitDir r
+ let dest = gitd P.</> fromRef' ref
+ let dest' = fromRawFilePath dest
+ createDirectoryUnder [gitd] (parentDir dest)
+ unlessM (doesFileExist dest') $
+ writeFile dest' (fromRef sha)
packedRefsFile :: Repo -> FilePath
packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
@@ -256,14 +281,14 @@ packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
(sha:ref:[])
- | isJust (extractSha sha) && Ref.legal True ref ->
- Just (Ref sha, Ref ref)
+ | isJust (extractSha (encodeBS sha)) && Ref.legal True ref ->
+ Just (Ref (encodeBS sha), Ref (encodeBS ref))
_ -> Nothing
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b
+nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P.</> fromRef' b
{- Finds the most recent commit to a branch that does not need any
- of the missing objects. If the input branch is good as-is, returns it.
@@ -278,13 +303,13 @@ findUncorruptedCommit missing goodcommits branch r = do
if ok
then return (Just branch, goodcommits')
else do
- (ls, cleanup) <- pipeNullSplit
+ (ls, cleanup) <- pipeNullSplit'
[ Param "log"
, Param "-z"
, Param "--format=%H"
, Param (fromRef branch)
] r
- let branchshas = catMaybes $ map (extractSha . decodeBL) ls
+ let branchshas = catMaybes $ map extractSha ls
reflogshas <- RefLog.get branch r
-- XXX Could try a bit harder here, and look
-- for uncorrupted old commits in branches in the
@@ -302,7 +327,11 @@ findUncorruptedCommit missing goodcommits branch r = do
- the commit. Also adds to a set of commit shas that have been verified to
- be good, which can be passed into subsequent calls to avoid
- redundant work when eg, chasing down branches to find the first
- - uncorrupted commit. -}
+ - uncorrupted commit.
+ -
+ - When the sha is not a commit but some other git object, returns
+ - true, but does not add it to the set.
+ -}
verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits)
verifyCommit missing goodcommits commit r
| checkGoodCommit commit goodcommits = return (True, goodcommits)
@@ -314,21 +343,28 @@ verifyCommit missing goodcommits commit r
, Param (fromRef commit)
] r
let committrees = map (parse . decodeBL) ls
- if any isNothing committrees || null committrees
- then do
- void cleanup
- return (False, goodcommits)
- else do
- let cts = catMaybes committrees
- ifM (cleanup <&&> check cts)
- ( return (True, addGoodCommits (map fst cts) goodcommits)
- , return (False, goodcommits)
- )
+ -- git log on an object that is not a commit will
+ -- succeed without any output
+ if null committrees
+ then ifM cleanup
+ ( return (True, goodcommits)
+ , return (False, goodcommits)
+ )
+ else if any isNothing committrees
+ then do
+ void cleanup
+ return (False, goodcommits)
+ else do
+ let cts = catMaybes committrees
+ ifM (cleanup <&&> check cts)
+ ( return (True, addGoodCommits (map fst cts) goodcommits)
+ , return (False, goodcommits)
+ )
where
parse l = case words l of
(commitsha:treesha:[]) -> (,)
- <$> extractSha commitsha
- <*> extractSha treesha
+ <$> extractSha (encodeBS commitsha)
+ <*> extractSha (encodeBS treesha)
_ -> Nothing
check [] = return True
check ((c, t):rest)
@@ -341,8 +377,9 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
verifyTree missing treesha r
| S.member treesha missing = return False
| otherwise = do
- (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r
- let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls
+ let nolong = LsTree.LsTreeLong False
+ (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive nolong treesha []) r
+ let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree nolong) ls
if any (`S.member` missing) objshas
then do
void cleanup
@@ -376,9 +413,8 @@ missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "ind
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
partitionIndex r = do
(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
- l <- forM indexcontents $ \i -> case i of
- (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
- _ -> pure (False, i)
+ l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) ->
+ (,) <$> isMissing sha r <*> pure i
let (bad, good) = partition fst l
return (map snd bad, map snd good, cleanup)
@@ -390,17 +426,16 @@ rewriteIndex r
| otherwise = do
(bad, good, cleanup) <- partitionIndex r
unless (null bad) $ do
- nukeFile (indexFile r)
+ removeWhenExistsWith R.removeLink (indexFile r)
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
- return $ map (fromRawFilePath . fst3) bad
+ return $ map (\(file,_, _, _) -> fromRawFilePath file) bad
where
- reinject (file, Just sha, Just mode) = case toTreeItemType mode of
+ reinject (file, sha, mode, _) = case toTreeItemType mode of
Nothing -> return Nothing
Just treeitemtype -> Just <$>
- UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r
- reinject _ = return Nothing
+ UpdateIndex.stageFile sha treeitemtype file r
newtype GoodCommits = GoodCommits (S.Set Sha)
@@ -439,31 +474,36 @@ displayList items header
preRepair :: Repo -> IO ()
preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
- nukeFile headfile
- writeFile headfile "ref: refs/heads/master"
+ removeWhenExistsWith R.removeLink headfile
+ writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
- unless (repoIsLocalBare g) $ do
- let f = indexFile g
- void $ tryIO $ allowWrite f
+ unless (repoIsLocalBare g) $
+ void $ tryIO $ allowWrite $ indexFile g
where
- headfile = fromRawFilePath (localGitDir g) </> "HEAD"
- validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
+ headfile = localGitDir g P.</> "HEAD"
+ validhead s = "ref: refs/" `isPrefixOf` s
+ || isJust (extractSha (encodeBS s))
{- Put it all together. -}
runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])
runRepair removablebranch forced g = do
preRepair g
putStrLn "Running git fsck ..."
- fsckresult <- findBroken False g
+ fsckresult <- findBroken False False g
if foundBroken fsckresult
- then runRepair' removablebranch fsckresult forced Nothing g
+ then do
+ putStrLn "Fsck found problems, attempting repair."
+ runRepair' removablebranch fsckresult forced Nothing g
else do
+ putStrLn "Fsck found no problems. Checking for broken branches."
bad <- badBranches S.empty g
if null bad
then do
putStrLn "No problems found."
return (True, [])
- else runRepair' removablebranch fsckresult forced Nothing g
+ else do
+ putStrLn "Found problems, attempting repair."
+ runRepair' removablebranch fsckresult forced Nothing g
runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
runRepairOf fsckresult removablebranch forced referencerepo g = do
@@ -473,7 +513,7 @@ runRepairOf fsckresult removablebranch forced referencerepo g = do
runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
runRepair' removablebranch fsckresult forced referencerepo g = do
cleanCorruptObjects fsckresult g
- missing <- findBroken False g
+ missing <- findBroken False False g
stillmissing <- retrieveMissingObjects missing referencerepo g
case stillmissing of
FsckFoundMissing s t
@@ -502,7 +542,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g)
( do
cleanCorruptObjects FsckFailed g
- stillmissing' <- findBroken False g
+ stillmissing' <- findBroken False False g
case stillmissing' of
FsckFailed -> return (False, [])
FsckFoundMissing s t -> forcerepair s t
@@ -548,7 +588,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
-- the repair process.
if fscktruncated
then do
- fsckresult' <- findBroken False g
+ fsckresult' <- findBroken False False g
case fsckresult' of
FsckFailed -> do
putStrLn "git fsck is failing"
@@ -567,10 +607,10 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
else successfulfinish modifiedbranches
corruptedindex = do
- nukeFile (indexFile g)
+ removeWhenExistsWith R.removeLink (indexFile g)
-- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair.
- fsckresult' <- findBroken False g
+ fsckresult' <- findBroken False False g
result <- runRepairOf fsckresult' removablebranch forced referencerepo g
putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."
return result
@@ -611,7 +651,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst
-safeReadFile :: FilePath -> IO String
+safeReadFile :: RawFilePath -> IO String
safeReadFile f = do
allowRead f
- readFileStrict f
+ readFileStrict (fromRawFilePath f)
diff --git a/Git/Sha.hs b/Git/Sha.hs
index cc33cac..389bcc0 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -1,43 +1,74 @@
{- git SHA stuff
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011,2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Sha where
import Common
import Git.Types
+import qualified Data.ByteString as S
+import Data.Char
+
{- Runs an action that causes a git subcommand to emit a Sha, and strips
- any trailing newline, returning the sha. -}
-getSha :: String -> IO String -> IO Sha
+getSha :: String -> IO S.ByteString -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
where
- bad = error $ "failed to read sha from git " ++ subcommand
+ bad = giveup $ "failed to read sha from git " ++ subcommand
-{- Extracts the Sha from a string. There can be a trailing newline after
- - it, but nothing else. -}
-extractSha :: String -> Maybe Sha
+{- Extracts the Sha from a ByteString.
+ -
+ - There can be a trailing newline after it, but nothing else.
+ -}
+extractSha :: S.ByteString -> Maybe Sha
extractSha s
- | len == shaSize = val s
- | len == shaSize + 1 && length s' == shaSize = val s'
+ | len `elem` shaSizes = val s
+ | len - 1 `elem` shaSizes && S.length s' == len - 1 = val s'
| otherwise = Nothing
where
- len = length s
- s' = firstLine s
+ len = S.length s
+ s' = firstLine' s
val v
- | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
+ | S.all validinsha v = Just $ Ref v
| otherwise = Nothing
+ validinsha w = or
+ [ w >= 48 && w <= 57 -- 0-9
+ , w >= 97 && w <= 102 -- a-f
+ , w >= 65 && w <= 70 -- A-F
+ ]
-{- Size of a git sha. -}
-shaSize :: Int
-shaSize = 40
+{- Sizes of git shas. -}
+shaSizes :: [Int]
+shaSizes =
+ [ 40 -- sha1 (must come first)
+ , 64 -- sha256
+ ]
-nullSha :: Ref
-nullSha = Ref $ replicate shaSize '0'
+{- Git plumbing often uses a all 0 sha to represent things like a
+ - deleted file. -}
+nullShas :: [Sha]
+nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes
+ where
+ zero = fromIntegral (ord '0')
-{- Git's magic empty tree. -}
+{- Sha to provide to git plumbing when deleting a file.
+ -
+ - It's ok to provide a sha1; git versions that use sha256 will map the
+ - sha1 to the sha256, or probably just treat all null sha1 specially
+ - the same as all null sha256. -}
+deleteSha :: Sha
+deleteSha = Prelude.head nullShas
+
+{- Git's magic empty tree.
+ -
+ - It's ok to provide the sha1 of this to git to refer to an empty tree;
+ - git versions that use sha256 will map the sha1 to the sha256.
+ -}
emptyTree :: Ref
emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
diff --git a/Git/Types.hs b/Git/Types.hs
index 9c2754a..ce1818e 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -1,12 +1,11 @@
{- git data types
-
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Git.Types where
@@ -18,6 +17,8 @@ import qualified Data.ByteString as S
import System.Posix.Types
import Utility.SafeCommand
import Utility.FileSystemEncoding
+import qualified Data.Semigroup as Sem
+import Prelude
{- Support repositories on local disk, and repositories accessed via an URL.
-
@@ -33,6 +34,7 @@ data RepoLocation
= Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
| LocalUnknown RawFilePath
| Url URI
+ | UnparseableUrl String
| Unknown
deriving (Show, Eq, Ord)
@@ -49,43 +51,67 @@ data Repo = Repo
, gitEnvOverridesGitDir :: Bool
-- global options to pass to git when running git commands
, gitGlobalOpts :: [CommandParam]
+ -- True only when --git-dir or GIT_DIR was used
+ , gitDirSpecifiedExplicitly :: Bool
} deriving (Show, Eq, Ord)
newtype ConfigKey = ConfigKey S.ByteString
deriving (Ord, Eq)
-newtype ConfigValue = ConfigValue S.ByteString
- deriving (Ord, Eq, Semigroup, Monoid)
+data ConfigValue
+ = ConfigValue S.ByteString
+ | NoConfigValue
+ -- ^ git treats a setting with no value as different than a setting
+ -- with an empty value
+ deriving (Ord, Eq)
+
+instance Sem.Semigroup ConfigValue where
+ ConfigValue a <> ConfigValue b = ConfigValue (a <> b)
+ a <> NoConfigValue = a
+ NoConfigValue <> b = b
+
+instance Monoid ConfigValue where
+ mempty = ConfigValue mempty
instance Default ConfigValue where
def = ConfigValue mempty
fromConfigKey :: ConfigKey -> String
-fromConfigKey (ConfigKey s) = decodeBS' s
+fromConfigKey (ConfigKey s) = decodeBS s
instance Show ConfigKey where
show = fromConfigKey
-fromConfigValue :: ConfigValue -> String
-fromConfigValue (ConfigValue s) = decodeBS' s
+class FromConfigValue a where
+ fromConfigValue :: ConfigValue -> a
+
+instance FromConfigValue S.ByteString where
+ fromConfigValue (ConfigValue s) = s
+ fromConfigValue NoConfigValue = mempty
+
+instance FromConfigValue String where
+ fromConfigValue = decodeBS . fromConfigValue
instance Show ConfigValue where
show = fromConfigValue
instance IsString ConfigKey where
- fromString = ConfigKey . encodeBS'
+ fromString = ConfigKey . encodeBS
instance IsString ConfigValue where
- fromString = ConfigValue . encodeBS'
+ fromString = ConfigValue . encodeBS
type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
-newtype Ref = Ref String
+newtype Ref = Ref S.ByteString
deriving (Eq, Ord, Read, Show)
fromRef :: Ref -> String
-fromRef (Ref s) = s
+fromRef = decodeBS . fromRef'
+
+fromRef' :: Ref -> S.ByteString
+fromRef' (Ref s) = s
{- Aliases for Ref. -}
type Branch = Ref
@@ -98,6 +124,7 @@ newtype RefDate = RefDate String
{- Types of objects that can be stored in git. -}
data ObjectType = BlobObject | CommitObject | TreeObject
+ deriving (Show)
readObjectType :: S.ByteString -> Maybe ObjectType
readObjectType "blob" = Just BlobObject
@@ -111,7 +138,12 @@ fmtObjectType CommitObject = "commit"
fmtObjectType TreeObject = "tree"
{- Types of items in a tree. -}
-data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule
+data TreeItemType
+ = TreeFile
+ | TreeExecutable
+ | TreeSymlink
+ | TreeSubmodule
+ | TreeSubtree
deriving (Eq, Show)
{- Git uses magic numbers to denote the type of a tree item. -}
@@ -120,6 +152,7 @@ readTreeItemType "100644" = Just TreeFile
readTreeItemType "100755" = Just TreeExecutable
readTreeItemType "120000" = Just TreeSymlink
readTreeItemType "160000" = Just TreeSubmodule
+readTreeItemType "040000" = Just TreeSubtree
readTreeItemType _ = Nothing
fmtTreeItemType :: TreeItemType -> S.ByteString
@@ -127,12 +160,14 @@ fmtTreeItemType TreeFile = "100644"
fmtTreeItemType TreeExecutable = "100755"
fmtTreeItemType TreeSymlink = "120000"
fmtTreeItemType TreeSubmodule = "160000"
+fmtTreeItemType TreeSubtree = "040000"
toTreeItemType :: FileMode -> Maybe TreeItemType
toTreeItemType 0o100644 = Just TreeFile
toTreeItemType 0o100755 = Just TreeExecutable
toTreeItemType 0o120000 = Just TreeSymlink
toTreeItemType 0o160000 = Just TreeSubmodule
+toTreeItemType 0o040000 = Just TreeSubtree
toTreeItemType _ = Nothing
fromTreeItemType :: TreeItemType -> FileMode
@@ -140,6 +175,7 @@ fromTreeItemType TreeFile = 0o100644
fromTreeItemType TreeExecutable = 0o100755
fromTreeItemType TreeSymlink = 0o120000
fromTreeItemType TreeSubmodule = 0o160000
+fromTreeItemType TreeSubtree = 0o040000
data Commit = Commit
{ commitTree :: Sha
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 9f07cf5..f56bc86 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,6 +1,6 @@
{- git-update-index library
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -12,8 +12,7 @@ module Git.UpdateIndex (
pureStreamer,
streamUpdateIndex,
streamUpdateIndex',
- startUpdateIndex,
- stopUpdateIndex,
+ withUpdateIndex,
lsTree,
lsSubTree,
updateIndexLine,
@@ -32,7 +31,9 @@ import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
+import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
+import Control.Monad.IO.Class
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
@@ -44,28 +45,32 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
- (\h -> forM_ as $ streamUpdateIndex' h)
+streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
+ forM_ as $ streamUpdateIndex' h
-data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
+data UpdateIndexHandle = UpdateIndexHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
-streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
+streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do
L.hPutStr h s
L.hPutStr h "\0"
-startUpdateIndex :: Repo -> IO UpdateIndexHandle
-startUpdateIndex repo = do
- (Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
- { std_in = CreatePipe }
- return $ UpdateIndexHandle p h
+withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
+withUpdateIndex repo a = bracket setup cleanup go
where
params = map Param ["update-index", "-z", "--index-info"]
-
-stopUpdateIndex :: UpdateIndexHandle -> IO Bool
-stopUpdateIndex (UpdateIndexHandle p h) = do
- hClose h
- checkSuccessProcess p
+
+ setup = liftIO $ createProcess $
+ (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ go p = do
+ r <- a (UpdateIndexHandle (stdinHandle p))
+ liftIO $ do
+ hClose (stdinHandle p)
+ void $ checkSuccessProcess (processHandle p)
+ return r
+
+ cleanup = liftIO . cleanupProcess
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
@@ -75,14 +80,14 @@ lsTree (Ref x) repo streamer = do
mapM_ streamer s
void $ cleanup
where
- params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
- params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]
+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
@@ -90,35 +95,35 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
updateIndexLine sha treeitemtype file = L.fromStrict $
fmtTreeItemType treeitemtype
<> " blob "
- <> encodeBS (fromRef sha)
+ <> fromRef' sha
<> "\t"
<> indexPath file
-stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
+stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do
- p <- toTopFilePath (toRawFilePath file) repo
+ p <- toTopFilePath file repo
return $ pureStreamer $ updateIndexLine sha treeitemtype p
{- A streamer that removes a file from the index. -}
-unstageFile :: FilePath -> Repo -> IO Streamer
+unstageFile :: RawFilePath -> Repo -> IO Streamer
unstageFile file repo = do
- p <- toTopFilePath (toRawFilePath file) repo
+ p <- toTopFilePath file repo
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ L.fromStrict $
"0 "
- <> encodeBS' (fromRef nullSha)
+ <> fromRef' deleteSha
<> "\t"
<> indexPath p
{- A streamer that adds a symlink to the index. -}
-stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
+stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
!line <- updateIndexLine
<$> pure sha
<*> pure TreeSymlink
- <*> toTopFilePath (toRawFilePath file) repo
+ <*> toTopFilePath file repo
return $ pureStreamer line
{- A streamer that applies a DiffTreeItem to the index. -}
@@ -130,17 +135,17 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
-{- Refreshes the index, by checking file stat information. -}
-refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
-refreshIndex repo feeder = do
- (Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
- { std_in = CreatePipe }
- feeder $ \f -> do
- hPutStr h f
- hPutStr h "\0"
- hFlush h
- hClose h
- checkSuccessProcess p
+{- Refreshes the index, by checking file stat information.
+ -
+ - The action is passed a callback that it can use to send filenames to
+ - update-index. Sending Nothing will wait for update-index to finish
+ - updating the index.
+ -}
+refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m ()
+refreshIndex repo feeder = bracket
+ (liftIO $ createProcess p)
+ (liftIO . cleanupProcess)
+ go
where
params =
[ Param "update-index"
@@ -149,3 +154,16 @@ refreshIndex repo feeder = do
, Param "-z"
, Param "--stdin"
]
+
+ p = (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+
+ go (Just h, _, _, pid) = do
+ let closer = do
+ hClose h
+ forceSuccessProcess p pid
+ feeder $ \case
+ Just f -> S.hPut h (S.snoc f 0)
+ Nothing -> closer
+ liftIO $ closer
+ go _ = error "internal"
diff --git a/Git/Url.hs b/Git/Url.hs
index 8430655..ad0e61b 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -1,6 +1,6 @@
{- git repository urls
-
- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -18,12 +18,11 @@ import Network.URI hiding (scheme, authority, path)
import Common
import Git.Types
-import Git
{- Scheme of an URL repo. -}
-scheme :: Repo -> String
-scheme Repo { location = Url u } = uriScheme u
-scheme repo = notUrl repo
+scheme :: Repo -> Maybe String
+scheme Repo { location = Url u } = Just (uriScheme u)
+scheme _ = Nothing
{- Work around a bug in the real uriRegName
- <http://trac.haskell.org/network/ticket/40> -}
@@ -65,13 +64,9 @@ authority = authpart assemble
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> Maybe a
authpart a Repo { location = Url u } = a <$> uriAuthority u
-authpart _ repo = notUrl repo
+authpart _ _ = Nothing
{- Path part of an URL repo. -}
-path :: Repo -> FilePath
-path Repo { location = Url u } = uriPath u
-path repo = notUrl repo
-
-notUrl :: Repo -> a
-notUrl repo = error $
- "acting on local git repo " ++ repoDescribe repo ++ " not supported"
+path :: Repo -> Maybe FilePath
+path Repo { location = Url u } = Just (uriPath u)
+path _ = Nothing
diff --git a/Git/Version.hs b/Git/Version.hs
index 5ecaca0..9119f5d 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -14,7 +14,7 @@ module Git.Version (
GitVersion,
) where
-import Common
+import Utility.Process
import Utility.DottedVersion
type GitVersion = DottedVersion
diff --git a/Makefile b/Makefile
index d2cd567..ddb440b 100644
--- a/Makefile
+++ b/Makefile
@@ -7,11 +7,15 @@ PREFIX=/usr
build: Build/SysConfig.hs
$(BUILDER) build $(BUILDEROPTIONS)
if [ "$(BUILDER)" = stack ]; then \
- ln -sf $$(stack path --dist-dir)/build/git-annex/git-repair git-repair; \
+ ln -sf $$(stack path --dist-dir)/build/git-repair/git-repair git-repair; \
else \
- ln -sf dist/build/git-repair/git-repair git-repair; \
+ if [ -d dist-newstyle ]; then \
+ ln -sf $$(cabal exec -- sh -c 'command -v git-repair') git-repair; \
+ else \
+ ln -sf dist/build/git-repair/git-repair git-repair; \
+ fi; \
fi
- @$(MAKE) tags >/dev/null 2>&1 &
+ @$(MAKE) tags
Build/SysConfig.hs: Build/TestConfig.hs Build/Configure.hs
if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi
@@ -29,12 +33,11 @@ install: build
clean:
rm -rf git-repair git-repair-test.log \
- dist configure Build/SysConfig.hs Setup tags
+ dist dist-newstyle configure Build/SysConfig.hs Setup tags
find . -name \*.o -exec rm {} \;
find . -name \*.hi -exec rm {} \;
-# hothasktags chokes on some template haskell etc, so ignore errors
tags:
- (for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags
+ hasktags . -c || true
.PHONY: tags
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index 1d66881..6ed7881 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 <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -10,6 +10,7 @@
module Utility.Batch (
batch,
BatchCommandMaker,
+ nonBatchCommandMaker,
getBatchCommandMaker,
toBatchCommand,
batchCommand,
@@ -22,7 +23,6 @@ import Common
import Control.Concurrent.Async
import System.Posix.Process
#endif
-import qualified Control.Exception as E
{- Runs an operation, at batch priority.
-
@@ -42,21 +42,22 @@ batch a = wait =<< batchthread
batchthread = asyncBound $ do
setProcessPriority 0 maxNice
a
+ maxNice = 19
#else
batch a = a
#endif
-maxNice :: Int
-maxNice = 19
-
{- Makes a command be run by whichever of nice, ionice, and nocache
- are available in the path. -}
type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])
+nonBatchCommandMaker :: BatchCommandMaker
+nonBatchCommandMaker = id
+
getBatchCommandMaker :: IO BatchCommandMaker
getBatchCommandMaker = do
#ifndef mingw32_HOST_OS
- nicers <- filterM (inPath . fst)
+ nicers <- filterM (inSearchPath . fst)
[ ("nice", [])
, ("ionice", ["-c3"])
, ("nocache", [])
@@ -75,11 +76,7 @@ toBatchCommand v = do
return $ batchmaker v
{- Runs a command in a way that's suitable for batch jobs that can be
- - interrupted.
- -
- - If the calling thread receives an async exception, it sends the
- - command a SIGTERM, and after the command finishes shuttting down,
- - it re-raises the async exception. -}
+ - interrupted. -}
batchCommand :: String -> [CommandParam] -> IO Bool
batchCommand command params = batchCommandEnv command params Nothing
@@ -87,13 +84,4 @@ batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bo
batchCommandEnv command params environ = do
batchmaker <- getBatchCommandMaker
let (command', params') = batchmaker (command, params)
- let p = proc command' $ toCommand params'
- (_, _, _, pid) <- createProcess $ p { env = environ }
- r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
- case r of
- Right ExitSuccess -> return True
- Right _ -> return False
- Left asyncexception -> do
- terminateProcess pid
- void $ waitForProcess pid
- E.throwIO asyncexception
+ boolSystemEnv command' params' environ
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 2bae40f..e091d43 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -10,6 +10,7 @@
module Utility.CoProcess (
CoProcessHandle,
+ CoProcessState(..),
start,
stop,
query,
diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs
new file mode 100644
index 0000000..207153d
--- /dev/null
+++ b/Utility/CopyFile.hs
@@ -0,0 +1,96 @@
+{- file copying
+ -
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.CopyFile (
+ copyFileExternal,
+ copyCoW,
+ createLinkOrCopy,
+ CopyMetaData(..)
+) where
+
+import Common
+import qualified BuildInfo
+import qualified Utility.RawFilePath as R
+
+data CopyMetaData
+ -- Copy timestamps when possible, but no other metadata, and
+ -- when copying a symlink, makes a copy of its content.
+ = CopyTimeStamps
+ -- Copy all metadata when possible.
+ | CopyAllMetaData
+ deriving (Eq)
+
+copyMetaDataParams :: CopyMetaData -> [CommandParam]
+copyMetaDataParams meta = map snd $ filter fst
+ [ (allmeta && BuildInfo.cp_a, Param "-a")
+ , (allmeta && BuildInfo.cp_p && not BuildInfo.cp_a
+ , Param "-p")
+ , (not allmeta && BuildInfo.cp_preserve_timestamps
+ , Param "--preserve=timestamps")
+ -- cp -a may preserve xattrs that have special meaning,
+ -- eg to NFS, and have even been observed to prevent later
+ -- changing the permissions of the file. So prevent preserving
+ -- xattrs.
+ , (allmeta && BuildInfo.cp_a && BuildInfo.cp_no_preserve_xattr_supported
+ , Param "--no-preserve=xattr")
+ ]
+ where
+ allmeta = meta == CopyAllMetaData
+
+{- The cp command is used, because I hate reinventing the wheel,
+ - and because this allows easy access to features like cp --reflink
+ - and preserving metadata. -}
+copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool
+copyFileExternal meta src dest = do
+ -- Delete any existing dest file because an unwritable file
+ -- would prevent cp from working.
+ void $ tryIO $ removeFile dest
+ boolSystem "cp" $ params ++ [File src, File dest]
+ where
+ params
+ | BuildInfo.cp_reflink_supported =
+ Param "--reflink=auto" : copyMetaDataParams meta
+ | otherwise = copyMetaDataParams meta
+
+{- When a filesystem supports CoW (and cp does), uses it to make
+ - an efficient copy of a file. Otherwise, returns False.
+ -
+ - The dest file must not exist yet, or it will fail to make a CoW copy,
+ - and will return False.
+ -}
+copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool
+copyCoW meta src dest
+ | BuildInfo.cp_reflink_supported = do
+ -- When CoW is not supported, cp will complain to stderr,
+ -- so have to discard its stderr.
+ ok <- catchBoolIO $ withNullHandle $ \nullh ->
+ let p = (proc "cp" $ toCommand $ params ++ [File src, File dest])
+ { std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
+ -- When CoW is not supported, cp creates the destination
+ -- file but leaves it empty.
+ unless ok $
+ void $ tryIO $ removeFile dest
+ return ok
+ | otherwise = return False
+ where
+ -- Note that in coreutils 9.0, cp uses CoW by default,
+ -- without needing an option. This s only needed to support
+ -- older versions.
+ params = Param "--reflink=always" : copyMetaDataParams meta
+
+{- Create a hard link if the filesystem allows it, and fall back to copying
+ - the file. -}
+createLinkOrCopy :: RawFilePath -> RawFilePath -> IO Bool
+createLinkOrCopy src dest = go `catchIO` const fallback
+ where
+ go = do
+ R.createLink src dest
+ return True
+ fallback = copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest)
diff --git a/Utility/Data.hs b/Utility/Data.hs
index 5510845..faf9b34 100644
--- a/Utility/Data.hs
+++ b/Utility/Data.hs
@@ -1,6 +1,6 @@
{- utilities for simple data types
-
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -10,8 +10,12 @@
module Utility.Data (
firstJust,
eitherToMaybe,
+ s2w8,
+ w82s,
) where
+import Data.Word
+
{- First item in the list that is not Nothing. -}
firstJust :: Eq a => [Maybe a] -> Maybe a
firstJust ms = case dropWhile (== Nothing) ms of
@@ -20,3 +24,15 @@ firstJust ms = case dropWhile (== Nothing) ms of
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just
+
+c2w8 :: Char -> Word8
+c2w8 = fromIntegral . fromEnum
+
+w82c :: Word8 -> Char
+w82c = toEnum . fromIntegral
+
+s2w8 :: String -> [Word8]
+s2w8 = map c2w8
+
+w82s :: [Word8] -> String
+w82s = map w82c
diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs
index a6c9ffc..8d910c6 100644
--- a/Utility/DataUnits.hs
+++ b/Utility/DataUnits.hs
@@ -1,6 +1,6 @@
{- data size display and parsing
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-
@@ -21,14 +21,20 @@
- error. This was bad.
-
- So, a committee was formed. And it arrived at a committee-like decision,
- - which satisfied noone, confused everyone, and made the world an uglier
- - place. As with all committees, this was meh.
+ - which satisfied no one, confused everyone, and made the world an uglier
+ - place. As with all committees, this was meh. Or in this case, "mib".
-
- And the drive manufacturers happily continued selling drives that are
- increasingly smaller than you'd expect, if you don't count on your
- fingers. But that are increasingly too big for anyone to much notice.
- This caused me to need git-annex.
-
+ - Meanwhile, over in telecommunications land, they were using entirely
+ - different units that differ only in capitalization sometimes.
+ - (At one point this convinced me that it was a good idea to buy an ISDN
+ - line because 128 kb/s sounded really fast! But it was really only 128
+ - kbit/s...)
+ -
- Thus, I use units here that I loathe. Because if I didn't, people would
- be confused that their drives seem the wrong size, and other people would
- complain at me for not being standards compliant. And we call this
@@ -38,7 +44,7 @@
module Utility.DataUnits (
dataUnits,
storageUnits,
- memoryUnits,
+ committeeUnits,
bandwidthUnits,
oldSchoolUnits,
Unit(..),
@@ -62,28 +68,30 @@ data Unit = Unit ByteSize Abbrev Name
deriving (Ord, Show, Eq)
dataUnits :: [Unit]
-dataUnits = storageUnits ++ memoryUnits
+dataUnits = storageUnits ++ committeeUnits ++ bandwidthUnits
{- Storage units are (stupidly) powers of ten. -}
storageUnits :: [Unit]
storageUnits =
- [ Unit (p 8) "YB" "yottabyte"
+ [ Unit (p 10) "QB" "quettabyte"
+ , Unit (p 9) "RB" "ronnabyte"
+ , Unit (p 8) "YB" "yottabyte"
, Unit (p 7) "ZB" "zettabyte"
, Unit (p 6) "EB" "exabyte"
, Unit (p 5) "PB" "petabyte"
, Unit (p 4) "TB" "terabyte"
, Unit (p 3) "GB" "gigabyte"
, Unit (p 2) "MB" "megabyte"
- , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
- , Unit (p 0) "B" "byte"
+ , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committee
+ , Unit 1 "B" "byte"
]
where
p :: Integer -> Integer
p n = 1000^n
-{- Memory units are (stupidly named) powers of 2. -}
-memoryUnits :: [Unit]
-memoryUnits =
+{- Committee units are (stupidly named) powers of 2. -}
+committeeUnits :: [Unit]
+committeeUnits =
[ Unit (p 8) "YiB" "yobibyte"
, Unit (p 7) "ZiB" "zebibyte"
, Unit (p 6) "EiB" "exbibyte"
@@ -92,19 +100,37 @@ memoryUnits =
, Unit (p 3) "GiB" "gibibyte"
, Unit (p 2) "MiB" "mebibyte"
, Unit (p 1) "KiB" "kibibyte"
- , Unit (p 0) "B" "byte"
+ , Unit 1 "B" "byte"
]
where
p :: Integer -> Integer
p n = 2^(n*10)
-{- Bandwidth units are only measured in bits if you're some crazy telco. -}
+{- Bandwidth units are (stupidly) measured in bits, not bytes, and are
+ - (also stupidly) powers of ten.
+ -
+ - While it's fairly common for "Mb", "Gb" etc to be used, that differs
+ - from "MB", "GB", etc only in case, and readSize is case-insensitive.
+ - So "Mbit", "Gbit" etc are used instead to avoid parsing ambiguity.
+ -}
bandwidthUnits :: [Unit]
-bandwidthUnits = error "stop trying to rip people off"
+bandwidthUnits =
+ [ Unit (p 8) "Ybit" "yottabit"
+ , Unit (p 7) "Zbit" "zettabit"
+ , Unit (p 6) "Ebit" "exabit"
+ , Unit (p 5) "Pbit" "petabit"
+ , Unit (p 4) "Tbit" "terabit"
+ , Unit (p 3) "Gbit" "gigabit"
+ , Unit (p 2) "Mbit" "megabit"
+ , Unit (p 1) "kbit" "kilobit" -- weird capitalization thanks to committee
+ ]
+ where
+ p :: Integer -> Integer
+ p n = (1000^n) `div` 8
{- Do you yearn for the days when men were men and megabytes were megabytes? -}
oldSchoolUnits :: [Unit]
-oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
+oldSchoolUnits = zipWith (curry mingle) storageUnits committeeUnits
where
mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
diff --git a/Utility/Debug.hs b/Utility/Debug.hs
new file mode 100644
index 0000000..6e6e701
--- /dev/null
+++ b/Utility/Debug.hs
@@ -0,0 +1,102 @@
+{- Debug output
+ -
+ - Copyright 2021 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-tabs -w #-}
+
+module Utility.Debug (
+ DebugSource(..),
+ DebugSelector(..),
+ configureDebug,
+ getDebugSelector,
+ debug,
+ fastDebug
+) where
+
+import qualified Data.ByteString as S
+import Data.IORef
+import Data.String
+import Data.Time
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.Semigroup as Sem
+import Prelude
+
+import Utility.FileSystemEncoding
+
+-- | The source of a debug message. For example, this could be a module or
+-- function name.
+newtype DebugSource = DebugSource S.ByteString
+ deriving (Eq, Show)
+
+instance IsString DebugSource where
+ fromString = DebugSource . encodeBS
+
+-- | Selects whether to display a message from a source.
+data DebugSelector
+ = DebugSelector (DebugSource -> Bool)
+ | NoDebugSelector
+
+instance Sem.Semigroup DebugSelector where
+ DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v)
+ NoDebugSelector <> NoDebugSelector = NoDebugSelector
+ NoDebugSelector <> b = b
+ a <> NoDebugSelector = a
+
+instance Monoid DebugSelector where
+ mempty = NoDebugSelector
+
+-- | Configures debugging.
+configureDebug
+ :: (S.ByteString -> IO ())
+ -- ^ Used to display debug output.
+ -> DebugSelector
+ -> IO ()
+configureDebug src p = writeIORef debugConfigGlobal (src, p)
+
+-- | Gets the currently configured DebugSelector.
+getDebugSelector :: IO DebugSelector
+getDebugSelector = snd <$> readIORef debugConfigGlobal
+
+-- A global variable for the debug configuration.
+{-# NOINLINE debugConfigGlobal #-}
+debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector)
+debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone)
+ where
+ dontshow _ = return ()
+ selectnone = NoDebugSelector
+
+-- | Displays a debug message, if that has been enabled by configureDebug.
+--
+-- This is reasonably fast when debugging is not enabled, but since it does
+-- have to consult a IORef each time, using it in a tight loop may slow
+-- down the program.
+debug :: DebugSource -> String -> IO ()
+debug src msg = readIORef debugConfigGlobal >>= \case
+ (displayer, NoDebugSelector) ->
+ displayer =<< formatDebugMessage src msg
+ (displayer, DebugSelector p)
+ | p src -> displayer =<< formatDebugMessage src msg
+ | otherwise -> return ()
+
+-- | Displays a debug message, if the DebugSelector allows.
+--
+-- When the DebugSelector does not let the message be displayed, this runs
+-- very quickly, allowing it to be used inside tight loops.
+fastDebug :: DebugSelector -> DebugSource -> String -> IO ()
+fastDebug NoDebugSelector src msg = do
+ (displayer, _) <- readIORef debugConfigGlobal
+ displayer =<< formatDebugMessage src msg
+fastDebug (DebugSelector p) src msg
+ | p src = fastDebug NoDebugSelector src msg
+ | otherwise = return ()
+
+formatDebugMessage :: DebugSource -> String -> IO S.ByteString
+formatDebugMessage (DebugSource src) msg = do
+ t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]"
+ <$> getZonedTime
+ return (t <> " (" <> src <> ") " <> encodeBS msg)
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index e2c6a94..a5c023f 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,11 +1,12 @@
{- directory traversal and manipulation
-
- - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory (
@@ -13,25 +14,19 @@ module Utility.Directory (
module Utility.SystemDirectory
) where
-import System.IO.Error
import Control.Monad
import System.FilePath
-import System.PosixCompat.Files
+import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
-#ifndef mingw32_HOST_OS
-import Utility.SafeCommand
-import Control.Monad.IfElse
-#endif
-
import Utility.SystemDirectory
-import Utility.Tmp
import Utility.Exception
import Utility.Monad
-import Utility.Applicative
+import Utility.FileSystemEncoding
+import qualified Utility.RawFilePath as R
dirCruft :: FilePath -> Bool
dirCruft "." = True
@@ -71,7 +66,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
- ms <- catchMaybeIO $ getSymbolicLinkStatus entry
+ ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry)
case ms of
(Just s)
| isDirectory s -> recurse
@@ -93,64 +88,14 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
| skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
- =<< filterM (isDirectory <$$> getSymbolicLinkStatus)
+ =<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs
+ isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p)
-{- Moves one filename to another.
- - First tries a rename, but falls back to moving across devices if needed. -}
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile src dest = tryIO (rename src dest) >>= onrename
- where
- onrename (Right _) = noop
- onrename (Left e)
- | isPermissionError e = rethrow
- | isDoesNotExistError e = rethrow
- | 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
- throwM e'
-
-#ifndef mingw32_HOST_OS
- isdir f = do
- r <- tryIO $ getFileStatus f
- case r of
- (Left _) -> return False
- (Right s) -> return $ isDirectory s
-#endif
-
-{- Removes a file, which may or may not exist, and does not have to
- - be a regular file.
+{- Use with an action that removes something, which may or may not exist.
-
- - Note that an exception is thrown if the file exists but
- - cannot be removed. -}
-nukeFile :: FilePath -> IO ()
-nukeFile file = void $ tryWhenExists go
- where
-#ifndef mingw32_HOST_OS
- go = removeLink file
-#else
- go = removeFile file
-#endif
+ - If an exception is thrown due to it not existing, it is ignored.
+ -}
+removeWhenExistsWith :: (a -> IO ()) -> a -> IO ()
+removeWhenExistsWith f a = void $ tryWhenExists $ f a
diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs
new file mode 100644
index 0000000..5650f96
--- /dev/null
+++ b/Utility/Directory/Create.hs
@@ -0,0 +1,105 @@
+{- directory creating
+ -
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Directory.Create (
+ createDirectoryUnder,
+ createDirectoryUnder',
+) where
+
+import Control.Monad
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.IfElse
+import System.IO.Error
+import Data.Maybe
+import qualified System.FilePath.ByteString as P
+import Prelude
+
+import Utility.SystemDirectory
+import Utility.Path.AbsRel
+import Utility.Exception
+import Utility.FileSystemEncoding
+import qualified Utility.RawFilePath as R
+import Utility.PartialPrelude
+
+{- Like createDirectoryIfMissing True, but it will only create
+ - missing parent directories up to but not including a directory
+ - from the first parameter.
+ -
+ - For example, createDirectoryUnder ["/tmp/foo"] "/tmp/foo/bar/baz"
+ - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
+ - it will throw an exception.
+ -
+ - The exception thrown is the same that createDirectory throws if the
+ - parent directory does not exist.
+ -
+ - If the second FilePath is not under the first
+ - FilePath (or the same as it), it will fail with an exception
+ - even if the second FilePath's parent directory already exists.
+ -
+ - The FilePaths can be relative, or absolute.
+ - They will be normalized as necessary.
+ -
+ - Note that, the second FilePath, if relative, is relative to the current
+ - working directory.
+ -}
+createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()
+createDirectoryUnder topdirs dir =
+ createDirectoryUnder' topdirs dir R.createDirectory
+
+createDirectoryUnder'
+ :: (MonadIO m, MonadCatch m)
+ => [RawFilePath]
+ -> RawFilePath
+ -> (RawFilePath -> m ())
+ -> m ()
+createDirectoryUnder' topdirs dir0 mkdir = do
+ relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
+ let relparts = map P.splitDirectories relps
+ -- Catch cases where dir0 is not beneath a topdir.
+ -- If the relative path between them starts with "..",
+ -- it's not. And on Windows, if they are on different drives,
+ -- the path will not be relative.
+ let notbeneath = \(_topdir, (relp, dirs)) ->
+ headMaybe dirs /= Just ".." && not (P.isAbsolute relp)
+ case filter notbeneath $ zip topdirs (zip relps relparts) of
+ ((topdir, (_relp, dirs)):_)
+ -- If dir0 is the same as the topdir, don't try to
+ -- create it, but make sure it does exist.
+ | null dirs ->
+ liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
+ ioError $ customerror doesNotExistErrorType $
+ "createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist"
+ | otherwise -> createdirs $
+ map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+ _ -> liftIO $ ioError $ customerror userErrorType
+ ("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs))
+ where
+ customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))
+
+ createdirs [] = pure ()
+ createdirs (dir:[]) = createdir dir (liftIO . ioError)
+ createdirs (dir:dirs) = createdir dir $ \_ -> do
+ createdirs dirs
+ createdir dir (liftIO . ioError)
+
+ -- This is the same method used by createDirectoryIfMissing,
+ -- in particular the handling of errors that occur when the
+ -- directory already exists. See its source for explanation
+ -- of several subtleties.
+ createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
+ Right () -> pure ()
+ Left e
+ | isDoesNotExistError e -> notexisthandler e
+ | isAlreadyExistsError e || isPermissionError e ->
+ liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $
+ ioError e
+ | otherwise -> liftIO $ ioError e
diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs
index dff3717..84b8463 100644
--- a/Utility/DottedVersion.hs
+++ b/Utility/DottedVersion.hs
@@ -13,7 +13,7 @@ module Utility.DottedVersion (
normalize,
) where
-import Common
+import Utility.Split
data DottedVersion = DottedVersion String Integer
deriving (Eq)
diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs
index f14674c..45d2e7f 100644
--- a/Utility/Env/Set.hs
+++ b/Utility/Env/Set.hs
@@ -10,6 +10,7 @@
module Utility.Env.Set (
setEnv,
unsetEnv,
+ legalInEnvVar,
) where
#ifdef mingw32_HOST_OS
@@ -18,6 +19,7 @@ import Utility.Env
#else
import qualified System.Posix.Env as PE
#endif
+import Data.Char
{- Sets an environment variable. To overwrite an existing variable,
- overwrite must be True.
@@ -41,3 +43,7 @@ unsetEnv = PE.unsetEnv
#else
unsetEnv = System.SetEnv.unsetEnv
#endif
+
+legalInEnvVar :: Char -> Bool
+legalInEnvVar '_' = True
+legalInEnvVar c = isAsciiLower c || isAsciiUpper c || (isNumber c && isAscii c)
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index bcadb78..cf55c5f 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -1,6 +1,6 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -20,6 +20,7 @@ module Utility.Exception (
bracketIO,
catchNonAsync,
tryNonAsync,
+ nonAsyncHandler,
tryWhenExists,
catchIOErrorType,
IOErrorType(..),
@@ -28,21 +29,24 @@ module Utility.Exception (
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
-import Control.Exception (IOException, AsyncException)
-import Control.Exception (SomeAsyncException)
+import Control.Exception (IOException, AsyncException, SomeAsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
import GHC.IO.Exception (IOErrorType(..))
import Utility.Data
+import Utility.SafeOutput
{- Like error, this throws an exception. Unlike error, if this exception
- is not caught, it won't generate a backtrace. So use this for situations
- - where there's a problem that the user is excpected to see in some
- - circumstances. -}
+ - where there's a problem that the user is expected to see in some
+ - circumstances.
+ -
+ - Also, control characters are filtered out of the message.
+ -}
giveup :: [Char] -> a
-giveup = errorWithoutStackTrace
+giveup = errorWithoutStackTrace . safeOutput
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
@@ -81,11 +85,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
- ThreadKilled and UserInterrupt get through.
-}
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
-catchNonAsync a onerr = a `catches`
- [ M.Handler (\ (e :: AsyncException) -> throwM e)
- , M.Handler (\ (e :: SomeAsyncException) -> throwM e)
- , M.Handler (\ (e :: SomeException) -> onerr e)
- ]
+catchNonAsync a onerr = a `catches` (nonAsyncHandler onerr)
tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
tryNonAsync a = go `catchNonAsync` (return . Left)
@@ -94,6 +94,13 @@ tryNonAsync a = go `catchNonAsync` (return . Left)
v <- a
return (Right v)
+nonAsyncHandler :: MonadCatch m => (SomeException -> m a) -> [M.Handler m a]
+nonAsyncHandler onerr =
+ [ M.Handler (\ (e :: AsyncException) -> throwM e)
+ , M.Handler (\ (e :: SomeAsyncException) -> throwM e)
+ , M.Handler (\ (e :: SomeException) -> onerr e)
+ ]
+
{- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = do
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 7d36c55..ecc19d8 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -1,11 +1,12 @@
{- File mode utilities.
-
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FileMode (
module Utility.FileMode,
@@ -15,32 +16,33 @@ module Utility.FileMode (
import System.IO
import Control.Monad
import System.PosixCompat.Types
-import System.PosixCompat.Files
+import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode)
#ifndef mingw32_HOST_OS
-import System.Posix.Files (symbolicLinkMode)
-import Control.Monad.IO.Class (liftIO)
+import System.PosixCompat.Files (setFileCreationMask)
#endif
-import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.IO.Class
import Foreign (complement)
import Control.Monad.Catch
import Utility.Exception
+import Utility.FileSystemEncoding
+import qualified Utility.RawFilePath as R
{- Applies a conversion function to a file's mode. -}
-modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
-modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
- s <- getFileStatus f
+ s <- R.getFileStatus f
let old = fileMode s
let new = convert old
when (new /= old) $
- setFileMode f new
+ R.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 :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
where
setup = modifyFileMode' file convert
@@ -73,15 +75,15 @@ otherGroupModes =
]
{- Removes the write bits from a file. -}
-preventWrite :: FilePath -> IO ()
+preventWrite :: RawFilePath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes
{- Turns a file's owner write bit back on. -}
-allowWrite :: FilePath -> IO ()
+allowWrite :: RawFilePath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
{- Turns a file's owner read bit back on. -}
-allowRead :: FilePath -> IO ()
+allowRead :: RawFilePath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode]
{- Allows owner and group to read and write to a file. -}
@@ -91,34 +93,29 @@ groupSharedModes =
, ownerReadMode, groupReadMode
]
-groupWriteRead :: FilePath -> IO ()
+groupWriteRead :: RawFilePath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool
checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
-{- Checks if a file mode indicates it's a symlink. -}
-isSymLink :: FileMode -> Bool
-#ifdef mingw32_HOST_OS
-isSymLink _ = False
-#else
-isSymLink = checkMode symbolicLinkMode
-#endif
-
{- Checks if a file has any executable bits set. -}
isExecutable :: FileMode -> Bool
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 :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
-#ifndef mingw32_HOST_OS
-noUmask mode a
- | mode == stdFileMode = a
- | otherwise = withUmask nullFileMode a
-#else
-noUmask _ a = a
-#endif
+data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ())
+
+{- Runs an action which should create the file, passing it the desired
+ - initial file mode. Then runs the ModeSetter's action on the file, which
+ - can adjust the initial mode if umask prevented the file from being
+ - created with the right mode. -}
+applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a
+applyModeSetter (Just (ModeSetter mode modeaction)) file a = do
+ r <- a (Just mode)
+ void $ tryIO $ modeaction file
+ return r
+applyModeSetter Nothing _ a =
+ a Nothing
withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
#ifndef mingw32_HOST_OS
@@ -160,7 +157,7 @@ isSticky = checkMode stickyMode
stickyMode :: FileMode
stickyMode = 512
-setSticky :: FilePath -> IO ()
+setSticky :: RawFilePath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif
@@ -173,15 +170,15 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- On a filesystem that does not support file permissions, this is the same
- as writeFile.
-}
-writeFileProtected :: FilePath -> String -> IO ()
+writeFileProtected :: RawFilePath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content)
-writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
-writeFileProtected' file writer = protectedOutput $
- withFile file WriteMode $ \h -> do
- void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
- writer h
+writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()
+writeFileProtected' file writer = do
+ h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode
+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
+ writer h
protectedOutput :: IO a -> IO a
protectedOutput = withUmask 0o0077
diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs
index 8544ad4..3d216f2 100644
--- a/Utility/FileSize.hs
+++ b/Utility/FileSize.hs
@@ -1,5 +1,7 @@
{- File size.
-
+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>
+ -
- License: BSD-2-clause
-}
@@ -12,11 +14,15 @@ module Utility.FileSize (
getFileSize',
) where
-import System.PosixCompat.Files
#ifdef mingw32_HOST_OS
import Control.Exception (bracket)
import System.IO
+import Utility.FileSystemEncoding
+#else
+import System.PosixCompat.Files (fileSize)
#endif
+import System.PosixCompat.Files (FileStatus)
+import qualified Utility.RawFilePath as R
type FileSize = Integer
@@ -26,18 +32,18 @@ type FileSize = Integer
- FileOffset which maxes out at 2 gb.
- See https://github.com/jystic/unix-compat/issues/16
-}
-getFileSize :: FilePath -> IO FileSize
+getFileSize :: R.RawFilePath -> IO FileSize
#ifndef mingw32_HOST_OS
-getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)
+getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f)
#else
-getFileSize f = bracket (openFile f ReadMode) hClose hFileSize
+getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize
#endif
{- Gets the size of the file, when its FileStatus is already known.
-
- On windows, uses getFileSize. Otherwise, the FileStatus contains the
- size, so this does not do any work. -}
-getFileSize' :: FilePath -> FileStatus -> IO FileSize
+getFileSize' :: R.RawFilePath -> FileStatus -> IO FileSize
#ifndef mingw32_HOST_OS
getFileSize' _ s = return $ fromIntegral $ fileSize s
#else
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index f9e9814..2a1dc81 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -1,6 +1,6 @@
{- GHC File system encoding handling.
-
- - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -11,7 +11,6 @@
module Utility.FileSystemEncoding (
useFileSystemEncoding,
fileEncoding,
- withFilePath,
RawFilePath,
fromRawFilePath,
toRawFilePath,
@@ -19,34 +18,22 @@ module Utility.FileSystemEncoding (
encodeBL,
decodeBS,
encodeBS,
- decodeBL',
- encodeBL',
- decodeBS',
- encodeBS',
truncateFilePath,
- s2w8,
- w82s,
- c2w8,
- w82c,
) where
import qualified GHC.Foreign as GHC
import qualified GHC.IO.Encoding as Encoding
-import Foreign.C
import System.IO
import System.IO.Unsafe
-import Data.Word
-import Data.List
+import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.UTF8 as S8
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
-import Utility.Exception
-import Utility.Split
-
{- Makes all subsequent Handles that are opened, as well as stdio Handles,
- use the filesystem encoding, instead of the encoding of the current
- locale.
@@ -79,40 +66,10 @@ fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
fileEncoding h = hSetEncoding h Encoding.utf8
#endif
-{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
- - storage. The FilePath is encoded using the filesystem encoding,
- - reversing the decoding that should have been done when the FilePath
- - was obtained. -}
-withFilePath :: FilePath -> (CString -> IO a) -> IO a
-withFilePath fp f = Encoding.getFileSystemEncoding
- >>= \enc -> GHC.withCString enc fp f
-
-{- Encodes a FilePath into a String, applying the filesystem encoding.
- -
- - There are very few things it makes sense to do with such an encoded
- - string. It's not a legal filename; it should not be displayed.
- - So this function is not exported, but instead used by the few functions
- - that can usefully consume it.
- -
- - This use of unsafePerformIO is belived to be safe; GHC's interface
- - 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)
- `catchNonAsync` (\_ -> return fp)
-
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBL :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
-decodeBL = encodeW8NUL . L.unpack
+decodeBL = decodeBS . L.toStrict
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
- only uses unicode for filenames. -}
@@ -122,111 +79,44 @@ decodeBL = L8.toString
{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}
encodeBL :: FilePath -> L.ByteString
#ifndef mingw32_HOST_OS
-encodeBL = L.pack . decodeW8NUL
+encodeBL = L.fromStrict . encodeBS
#else
encodeBL = L8.fromString
#endif
decodeBS :: S.ByteString -> FilePath
#ifndef mingw32_HOST_OS
-decodeBS = encodeW8NUL . S.unpack
+-- This does the same thing as System.FilePath.ByteString.decodeFilePath,
+-- with an identical implementation. However, older versions of that library
+-- truncated at NUL, which this must not do, because it may end up used on
+-- something other than a unix filepath.
+{-# NOINLINE decodeBS #-}
+decodeBS b = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ S.useAsCStringLen b (GHC.peekCStringLen enc)
#else
decodeBS = S8.toString
#endif
encodeBS :: FilePath -> S.ByteString
#ifndef mingw32_HOST_OS
-encodeBS = S.pack . decodeW8NUL
+-- This does the same thing as System.FilePath.ByteString.encodeFilePath,
+-- with an identical implementation. However, older versions of that library
+-- truncated at NUL, which this must not do, because it may end up used on
+-- something other than a unix filepath.
+{-# NOINLINE encodeBS #-}
+encodeBS f = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.newCStringLen enc f >>= unsafePackMallocCStringLen
#else
encodeBS = S8.fromString
#endif
-{- Faster version that assumes the string does not contain NUL;
- - if it does it will be truncated before the NUL. -}
-decodeBS' :: S.ByteString -> FilePath
-#ifndef mingw32_HOST_OS
-decodeBS' = encodeW8 . S.unpack
-#else
-decodeBS' = S8.toString
-#endif
-
-encodeBS' :: FilePath -> S.ByteString
-#ifndef mingw32_HOST_OS
-encodeBS' = S.pack . decodeW8
-#else
-encodeBS' = S8.fromString
-#endif
-
-decodeBL' :: L.ByteString -> FilePath
-#ifndef mingw32_HOST_OS
-decodeBL' = encodeW8 . L.unpack
-#else
-decodeBL' = L8.toString
-#endif
-
-encodeBL' :: FilePath -> L.ByteString
-#ifndef mingw32_HOST_OS
-encodeBL' = L.pack . decodeW8
-#else
-encodeBL' = L8.fromString
-#endif
-
-{- Recent versions of the unix package have this alias; defined here
- - for backwards compatibility. -}
-type RawFilePath = S.ByteString
-
-{- Note that the RawFilePath is assumed to never contain NUL,
- - since filename's don't. This should only be used with actual
- - RawFilePaths not arbitrary ByteString that may contain NUL. -}
fromRawFilePath :: RawFilePath -> FilePath
-fromRawFilePath = decodeBS'
+fromRawFilePath = decodeFilePath
-{- Note that the FilePath is assumed to never contain NUL,
- - since filename's don't. This should only be used with actual FilePaths
- - not arbitrary String that may contain NUL. -}
toRawFilePath :: FilePath -> RawFilePath
-toRawFilePath = encodeBS'
-
-{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
- -
- - w82s 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
- - cannot contain embedded NUL, but Haskell Strings may.
- -}
-{-# NOINLINE encodeW8 #-}
-encodeW8 :: [Word8] -> FilePath
-encodeW8 w8 = unsafePerformIO $ do
- enc <- Encoding.getFileSystemEncoding
- GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
-
-decodeW8 :: FilePath -> [Word8]
-decodeW8 = s2w8 . _encodeFilePath
-
-{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
-encodeW8NUL :: [Word8] -> FilePath
-encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul)
- where
- nul = '\NUL'
-
-decodeW8NUL :: FilePath -> [Word8]
-decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul
- where
- nul = '\NUL'
-
-c2w8 :: Char -> Word8
-c2w8 = fromIntegral . fromEnum
-
-w82c :: Word8 -> Char
-w82c = toEnum . fromIntegral
-
-s2w8 :: String -> [Word8]
-s2w8 = map c2w8
-
-w82s :: [Word8] -> String
-w82s = map w82c
+toRawFilePath = encodeFilePath
{- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk.
@@ -239,8 +129,8 @@ truncateFilePath :: Int -> FilePath -> FilePath
truncateFilePath n = go . reverse
where
go f =
- let bytes = decodeW8 f
- in if length bytes <= n
+ let b = encodeBS f
+ in if S.length b <= n
then reverse f
else go (drop 1 f)
#else
diff --git a/Utility/Format.hs b/Utility/Format.hs
index a2470fa..930b7ee 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -1,6 +1,6 @@
{- Formatted string handling.
-
- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -9,8 +9,12 @@ module Utility.Format (
Format,
gen,
format,
+ escapedFormat,
+ formatContainsVar,
decode_c,
encode_c,
+ encode_c',
+ isUtf8Byte,
prop_encode_c_decode_c_roundtrip
) where
@@ -19,19 +23,23 @@ import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Data.List (isPrefixOf)
-import qualified Codec.Binary.UTF8.String
import qualified Data.Map as M
+import qualified Data.ByteString as S
import Utility.PartialPrelude
-
-type FormatString = String
+import Utility.FileSystemEncoding
{- A format consists of a list of fragments. -}
type Format = [Frag]
-{- A fragment is either a constant string,
- - or a variable, with a justification. -}
-data Frag = Const String | Var String Justify
+{- A fragment is either a constant string, or a variable. -}
+data Frag
+ = Const String
+ | Var
+ { varName :: String
+ , varJustify :: Justify
+ , varEscaped :: Bool
+ }
deriving (Show)
data Justify = LeftJustified Int | RightJustified Int | UnJustified
@@ -45,10 +53,9 @@ format :: Format -> Variables -> String
format f vars = concatMap expand f
where
expand (Const s) = s
- expand (Var name j)
- | "escaped_" `isPrefixOf` name =
- justify j $ encode_c_strict $
- getvar $ drop (length "escaped_") name
+ expand (Var name j esc)
+ | esc = justify j $ decodeBS $ escapedFormat $
+ encodeBS $ getvar name
| otherwise = justify j $ getvar name
getvar name = fromMaybe "" $ M.lookup name vars
justify UnJustified s = s
@@ -57,13 +64,22 @@ format f vars = concatMap expand f
pad i s = take (i - length s) spaces
spaces = repeat ' '
+escapedFormat :: S.ByteString -> S.ByteString
+escapedFormat = encode_c needescape
+ where
+ needescape c = isUtf8Byte c ||
+ isSpace (chr (fromIntegral c)) ||
+ c == fromIntegral (ord '"')
+
{- Generates a Format that can be used to expand variables in a
- format string, such as "${foo} ${bar;10} ${baz;-10}\n"
-
- (This is the same type of format string used by dpkg-query.)
+ -
+ - Also, "${escaped_foo}" will apply encode_c to the value of variable foo.
-}
-gen :: FormatString -> Format
-gen = filter (not . empty) . fuse [] . scan [] . decode_c
+gen :: String -> Format
+gen = filter (not . empty) . fuse [] . scan [] . decodeBS . decode_c . encodeBS
where
-- The Format is built up in reverse, for efficiency,
-- and can have many adjacent Consts. Fusing it fixes both
@@ -94,42 +110,71 @@ gen = filter (not . empty) . fuse [] . scan [] . decode_c
| i < 0 = LeftJustified (-1 * i)
| otherwise = RightJustified i
novar v = "${" ++ reverse v
- foundvar f v p = scan (Var (reverse v) p : f)
+ foundvar f varname_r p =
+ let varname = reverse varname_r
+ var = if "escaped_" `isPrefixOf` varname
+ then Var (drop (length "escaped_") varname) p True
+ else Var varname p False
+ in scan (var : f)
empty :: Frag -> Bool
empty (Const "") = True
empty _ = False
+{- Check if a Format contains a variable with a specified name. -}
+formatContainsVar :: String -> Format -> Bool
+formatContainsVar v = any go
+ where
+ go (Var v' _ _) | v' == v = True
+ go _ = False
+
{- Decodes a C-style encoding, where \n is a newline (etc),
- \NNN is an octal encoded character, and \xNN is a hex encoded character.
-}
-decode_c :: FormatString -> String
-decode_c [] = []
-decode_c s = unescape ("", s)
+decode_c :: S.ByteString -> S.ByteString
+decode_c s
+ | S.null s = S.empty
+ | otherwise = unescape (S.empty, s)
where
- e = '\\'
- unescape (b, []) = b
- -- look for escapes starting with '\'
- unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
+ e = fromIntegral (ord '\\')
+ x = fromIntegral (ord 'x')
+ isescape c = c == e
+ unescape (b, v)
+ | S.null v = b
+ | otherwise = b <> fst pair <> unescape (handle $ snd pair)
where
- pair = span (/= e) v
- isescape x = x == e
- handle (x:'x':n1:n2:rest)
- | isescape x && allhex = (fromhex, rest)
+ pair = S.span (not . isescape) v
+ handle b
+ | S.length b >= 1 && isescape (S.index b 0) = handle' b
+ | otherwise = (S.empty, b)
+
+ handle' b
+ | S.length b >= 4
+ && S.index b 1 == x
+ && allhex = (fromhex, rest)
where
+ n1 = chr (fromIntegral (S.index b 2))
+ n2 = chr (fromIntegral (S.index b 3))
+ rest = S.drop 4 b
allhex = isHexDigit n1 && isHexDigit n2
- fromhex = [chr $ readhex [n1, n2]]
+ fromhex = encodeBS [chr $ readhex [n1, n2]]
readhex h = Prelude.read $ "0x" ++ h :: Int
- handle (x:n1:n2:n3:rest)
- | isescape x && alloctal = (fromoctal, rest)
+ handle' b
+ | S.length b >= 4 && alloctal = (fromoctal, rest)
where
+ n1 = chr (fromIntegral (S.index b 1))
+ n2 = chr (fromIntegral (S.index b 2))
+ n3 = chr (fromIntegral (S.index b 3))
+ rest = S.drop 4 b
alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3
- fromoctal = [chr $ readoctal [n1, n2, n3]]
+ fromoctal = encodeBS [chr $ readoctal [n1, n2, n3]]
readoctal o = Prelude.read $ "0o" ++ o :: Int
- -- \C is used for a few special characters
- handle (x:nc:rest)
- | isescape x = ([echar nc], rest)
+ handle' b
+ | S.length b >= 2 =
+ (S.singleton (fromIntegral (ord (echar nc))), rest)
where
+ nc = chr (fromIntegral (S.index b 1))
+ rest = S.drop 2 b
echar 'a' = '\a'
echar 'b' = '\b'
echar 'f' = '\f'
@@ -137,41 +182,50 @@ decode_c s = unescape ("", s)
echar 'r' = '\r'
echar 't' = '\t'
echar 'v' = '\v'
- echar a = a
- handle n = ("", n)
+ echar a = a -- \\ decodes to '\', and \" to '"'
+ handle' b = (S.empty, b)
-{- Inverse of decode_c. -}
-encode_c :: String -> FormatString
-encode_c = encode_c' (const False)
-
-{- Encodes more strictly, including whitespace. -}
-encode_c_strict :: String -> FormatString
-encode_c_strict = encode_c' isSpace
-
-encode_c' :: (Char -> Bool) -> String -> FormatString
-encode_c' p = concatMap echar
+{- Inverse of decode_c. Encodes ascii control characters as well as
+ - bytes that match the predicate. (And also '\' itself.)
+ -}
+encode_c :: (Word8 -> Bool) -> S.ByteString -> S.ByteString
+encode_c p s = fromMaybe s (encode_c' p s)
+
+{- Returns Nothing when nothing needs to be escaped in the input ByteString. -}
+encode_c' :: (Word8 -> Bool) -> S.ByteString -> Maybe S.ByteString
+encode_c' p s
+ | S.any needencode s = Just (S.concatMap echar s)
+ | otherwise = Nothing
where
- e c = '\\' : [c]
- echar '\a' = e 'a'
- echar '\b' = e 'b'
- echar '\f' = e 'f'
- echar '\n' = e 'n'
- echar '\r' = e 'r'
- echar '\t' = e 't'
- echar '\v' = e 'v'
- echar '\\' = e '\\'
- echar '"' = e '"'
+ e = fromIntegral (ord '\\')
+ q = fromIntegral (ord '"')
+ del = 0x7F
+ iscontrol c = c < 0x20
+
+ echar 0x7 = ec 'a'
+ echar 0x8 = ec 'b'
+ echar 0x0C = ec 'f'
+ echar 0x0A = ec 'n'
+ echar 0x0D = ec 'r'
+ echar 0x09 = ec 't'
+ echar 0x0B = ec 'v'
echar c
- | ord c < 0x20 = e_asc c -- low ascii
- | ord c >= 256 = e_utf c -- unicode
- | ord c > 0x7E = e_asc c -- high ascii
- | p c = e_asc c -- unprintable ascii
- | otherwise = [c] -- printable ascii
- -- unicode character is decomposed to individual Word8s,
- -- and each is shown in octal
- e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
- e_asc c = showoctal $ ord c
- showoctal i = '\\' : printf "%03o" i
+ | iscontrol c = showoctal c -- other control characters
+ | c == e = ec '\\' -- escape the escape character itself
+ | c == del = showoctal c
+ | p c = if c == q
+ then ec '"' -- escape double quote
+ else showoctal c
+ | otherwise = S.singleton c
+
+ needencode c = iscontrol c || c == e || c == del || p c
+
+ ec c = S.pack [e, fromIntegral (ord c)]
+
+ showoctal i = encodeBS ('\\' : printf "%03o" i)
+
+isUtf8Byte :: Word8 -> Bool
+isUtf8Byte c = c >= 0x80
{- For quickcheck.
-
@@ -182,6 +236,7 @@ encode_c' p = concatMap echar
- This property papers over the problem, by only testing ascii.
-}
prop_encode_c_decode_c_roundtrip :: String -> Bool
-prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s')
+prop_encode_c_decode_c_roundtrip s = s' ==
+ decodeBS (decode_c (encode_c isUtf8Byte (encodeBS s')))
where
s' = filter isAscii s
diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs
index 6143cef..04a18b0 100644
--- a/Utility/HumanNumber.hs
+++ b/Utility/HumanNumber.hs
@@ -1,6 +1,6 @@
{- numbers for humans
-
- - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -11,11 +11,15 @@ module Utility.HumanNumber (showImprecise) where
- of decimal digits. -}
showImprecise :: RealFrac a => Int -> a -> String
showImprecise precision n
- | precision == 0 || remainder == 0 = show (round n :: Integer)
- | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)
+ | precision == 0 || remainder' == 0 = show (round n :: Integer)
+ | otherwise = show int' ++ "." ++ striptrailing0s (pad0s $ show remainder')
where
int :: Integer
(int, frac) = properFraction n
remainder = round (frac * 10 ^ precision) :: Integer
+ (int', remainder')
+ -- carry the 1
+ | remainder == 10 ^ precision = (int + 1, 0)
+ | otherwise = (int, remainder)
pad0s s = replicate (precision - length s) '0' ++ s
striptrailing0s = reverse . dropWhile (== '0') . reverse
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
index 51338b3..5178531 100644
--- a/Utility/HumanTime.hs
+++ b/Utility/HumanTime.hs
@@ -44,8 +44,10 @@ daysToDuration :: Integer -> Duration
daysToDuration i = Duration $ i * dsecs
{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
-parseDuration :: MonadFail m => String -> m Duration
-parseDuration = maybe parsefail (return . Duration) . go 0
+parseDuration :: String -> Either String Duration
+parseDuration d
+ | null d = parsefail
+ | otherwise = maybe parsefail (Right . Duration) $ go 0 d
where
go n [] = return n
go n s = do
@@ -55,7 +57,7 @@ parseDuration = maybe parsefail (return . Duration) . go 0
u <- M.lookup c unitmap
go (n + num * u) rest
_ -> return $ n + num
- parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\""
+ parsefail = Left $ "failed to parse duration \"" ++ d ++ "\" (expected eg \"5m\" or \"1h5m\")"
fromDuration :: Duration -> String
fromDuration Duration { durationSeconds = d }
@@ -101,4 +103,4 @@ instance Arbitrary Duration where
arbitrary = Duration <$> nonNegative arbitrary
prop_duration_roundtrips :: Duration -> Bool
-prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d
+prop_duration_roundtrips d = parseDuration (fromDuration d) == Right d
diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs
new file mode 100644
index 0000000..3828bc6
--- /dev/null
+++ b/Utility/InodeCache.hs
@@ -0,0 +1,310 @@
+{- Caching a file's inode, size, and modification time
+ - to see when it's changed.
+ -
+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utility.InodeCache (
+ InodeCache,
+ mkInodeCache,
+ InodeComparisonType(..),
+ inodeCacheFileSize,
+
+ compareStrong,
+ compareWeak,
+ compareBy,
+
+ readInodeCache,
+ showInodeCache,
+ genInodeCache,
+ toInodeCache,
+ toInodeCache',
+
+ InodeCacheKey,
+ inodeCacheToKey,
+ inodeCacheToFileSize,
+ inodeCacheToMtime,
+ inodeCacheToEpochTime,
+ inodeCacheEpochTimeRange,
+ replaceInode,
+
+ SentinalFile(..),
+ SentinalStatus(..),
+ TSDelta,
+ noTSDelta,
+ writeSentinalFile,
+ checkSentinalFile,
+ sentinalFileExists,
+
+ prop_read_show_inodecache
+) where
+
+import Common
+import Utility.TimeStamp
+import Utility.QuickCheck
+import qualified Utility.RawFilePath as R
+
+import System.PosixCompat.Types
+import System.PosixCompat.Files (isRegularFile, fileID)
+import Data.Time.Clock.POSIX
+
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.Files as Posix
+#endif
+
+data InodeCachePrim = InodeCachePrim FileID FileSize MTime
+ deriving (Show, Eq, Ord)
+
+newtype InodeCache = InodeCache InodeCachePrim
+ deriving (Show)
+
+mkInodeCache :: FileID -> FileSize -> POSIXTime -> InodeCache
+mkInodeCache inode sz mtime = InodeCache $
+ InodeCachePrim inode sz (MTimeHighRes mtime)
+
+inodeCacheFileSize :: InodeCache -> FileSize
+inodeCacheFileSize (InodeCache (InodeCachePrim _ sz _)) = sz
+
+{- Inode caches can be compared in two different ways, either weakly
+ - or strongly. -}
+data InodeComparisonType = Weakly | Strongly
+ deriving (Eq, Ord, Show)
+
+{- Strong comparison, including inodes. -}
+compareStrong :: InodeCache -> InodeCache -> Bool
+compareStrong (InodeCache x) (InodeCache y) = x == y
+
+{- Weak comparison of the inode caches, comparing the size and mtime,
+ - but not the actual inode. Useful when inodes have changed, perhaps
+ - due to some filesystems being remounted.
+ -
+ - The weak mtime comparison treats any mtimes that are within 2 seconds
+ - of one-another as the same. This is because FAT has only a 2 second
+ - resolution. When a FAT filesystem is used on Linux, higher resolution
+ - timestamps maybe are cached and used by Linux, but they are lost
+ - on unmount, so after a remount, the timestamp can appear to have changed.
+ -}
+compareWeak :: InodeCache -> InodeCache -> Bool
+compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) =
+ size1 == size2 && (abs (lowResTime mtime1 - lowResTime mtime2) < 2)
+
+compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool
+compareBy Strongly = compareStrong
+compareBy Weakly = compareWeak
+
+{- For use in a Map; it's determined at creation time whether this
+ - uses strong or weak comparison for Eq. -}
+data InodeCacheKey = InodeCacheKey InodeComparisonType InodeCachePrim
+ deriving (Ord, Show)
+
+instance Eq InodeCacheKey where
+ (InodeCacheKey ctx x) == (InodeCacheKey cty y) =
+ compareBy (maximum [ctx,cty]) (InodeCache x ) (InodeCache y)
+
+inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey
+inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim
+
+inodeCacheToFileSize :: InodeCache -> FileSize
+inodeCacheToFileSize (InodeCache (InodeCachePrim _ sz _)) = sz
+
+inodeCacheToMtime :: InodeCache -> POSIXTime
+inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = highResTime mtime
+
+inodeCacheToEpochTime :: InodeCache -> EpochTime
+inodeCacheToEpochTime (InodeCache (InodeCachePrim _ _ mtime)) = lowResTime mtime
+
+-- Returns min, max EpochTime that weakly match the time of the InodeCache.
+inodeCacheEpochTimeRange :: InodeCache -> (EpochTime, EpochTime)
+inodeCacheEpochTimeRange i =
+ let t = inodeCacheToEpochTime i
+ in (t-1, t+1)
+
+replaceInode :: FileID -> InodeCache -> InodeCache
+replaceInode inode (InodeCache (InodeCachePrim _ sz mtime)) =
+ InodeCache (InodeCachePrim inode sz mtime)
+
+{- For backwards compatibility, support low-res mtime with no
+ - fractional seconds. -}
+data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime
+ deriving (Show, Ord)
+
+{- A low-res time compares equal to any high-res time in the same second. -}
+instance Eq MTime where
+ MTimeLowRes a == MTimeLowRes b = a == b
+ MTimeHighRes a == MTimeHighRes b = a == b
+ MTimeHighRes a == MTimeLowRes b = lowResTime a == b
+ MTimeLowRes a == MTimeHighRes b = a == lowResTime b
+
+class MultiResTime t where
+ lowResTime :: t -> EpochTime
+ highResTime :: t -> POSIXTime
+
+instance MultiResTime EpochTime where
+ lowResTime = id
+ highResTime = realToFrac
+
+instance MultiResTime POSIXTime where
+ lowResTime = fromInteger . floor
+ highResTime = id
+
+instance MultiResTime MTime where
+ lowResTime (MTimeLowRes t) = t
+ lowResTime (MTimeHighRes t) = lowResTime t
+ highResTime (MTimeLowRes t) = highResTime t
+ highResTime (MTimeHighRes t) = t
+
+showInodeCache :: InodeCache -> String
+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeHighRes mtime))) =
+ let (t, d) = separate (== '.') (takeWhile (/= 's') (show mtime))
+ in unwords
+ [ show inode
+ , show size
+ , t
+ , d
+ ]
+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeLowRes mtime))) =
+ unwords
+ [ show inode
+ , show size
+ , show mtime
+ ]
+
+readInodeCache :: String -> Maybe InodeCache
+readInodeCache s = case words s of
+ (inode:size:mtime:[]) -> do
+ i <- readish inode
+ sz <- readish size
+ t <- readish mtime
+ return $ InodeCache $ InodeCachePrim i sz (MTimeLowRes t)
+ (inode:size:mtime:mtimedecimal:_) -> do
+ i <- readish inode
+ sz <- readish size
+ t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal
+ return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)
+ _ -> Nothing
+
+genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
+genInodeCache f delta = catchDefaultIO Nothing $
+ toInodeCache delta f =<< R.getSymbolicLinkStatus f
+
+toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache)
+toInodeCache d f s = toInodeCache' d f s (fileID s)
+
+toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache)
+toInodeCache' (TSDelta getdelta) f s inode
+ | isRegularFile s = do
+ delta <- getdelta
+ sz <- getFileSize' f s
+#ifdef mingw32_HOST_OS
+ mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f)
+#else
+ let mtime = Posix.modificationTimeHiRes s
+#endif
+ return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta))
+ | otherwise = pure Nothing
+
+{- Some filesystem get new random inodes each time they are mounted.
+ - To detect this and other problems, a sentinal file can be created.
+ - Its InodeCache at the time of its creation is written to the cache file,
+ - so changes can later be detected. -}
+data SentinalFile = SentinalFile
+ { sentinalFile :: RawFilePath
+ , sentinalCacheFile :: RawFilePath
+ }
+ deriving (Show)
+
+{- On Windows, the mtime of a file appears to change when the time zone is
+ - changed. To deal with this, a TSDelta can be used; the delta is added to
+ - the mtime when generating an InodeCache. The current delta can be found
+ - by looking at the SentinalFile. Effectively, this makes all InodeCaches
+ - use the same time zone that was in use when the sential file was
+ - originally written. -}
+newtype TSDelta = TSDelta (IO EpochTime)
+
+noTSDelta :: TSDelta
+noTSDelta = TSDelta (pure 0)
+
+writeSentinalFile :: SentinalFile -> IO ()
+writeSentinalFile s = do
+ writeFile (fromRawFilePath (sentinalFile s)) ""
+ maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache)
+ =<< genInodeCache (sentinalFile s) noTSDelta
+
+data SentinalStatus = SentinalStatus
+ { sentinalInodesChanged :: Bool
+ , sentinalTSDelta :: TSDelta
+ }
+
+{- Checks if the InodeCache of the sentinal file is the same
+ - as it was when it was originally created.
+ -
+ - On Windows, time stamp differences are ignored, since they change
+ - with the timezone.
+ -
+ - When the sential file does not exist, InodeCaches cannot reliably be
+ - compared, so the assumption is that there is has been a change.
+ -}
+checkSentinalFile :: SentinalFile -> IO SentinalStatus
+checkSentinalFile s = do
+ mold <- loadoldcache
+ case mold of
+ Nothing -> return dummy
+ (Just old) -> do
+ mnew <- gennewcache
+ case mnew of
+ Nothing -> return dummy
+ Just new -> return $ calc old new
+ where
+ loadoldcache = catchDefaultIO Nothing $
+ readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s))
+ gennewcache = genInodeCache (sentinalFile s) noTSDelta
+ calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) =
+ SentinalStatus (not unchanged) tsdelta
+ where
+#ifdef mingw32_HOST_OS
+ -- Since mtime can appear to change when the time zone is
+ -- changed in windows, we cannot look at the mtime for the
+ -- sentinal file.
+ unchanged = oldinode == newinode && oldsize == newsize && (newmtime == newmtime)
+ tsdelta = TSDelta $ do
+ -- Run when generating an InodeCache,
+ -- to get the current delta.
+ mnew <- gennewcache
+ return $ case mnew of
+ Just (InodeCache (InodeCachePrim _ _ currmtime)) ->
+ lowResTime oldmtime - lowResTime currmtime
+ Nothing -> 0
+#else
+ unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime
+ tsdelta = noTSDelta
+#endif
+ dummy = SentinalStatus True noTSDelta
+
+sentinalFileExists :: SentinalFile -> IO Bool
+sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s]
+
+instance Arbitrary InodeCache where
+ arbitrary =
+ let prim = InodeCachePrim
+ <$> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ in InodeCache <$> prim
+
+instance Arbitrary MTime where
+ arbitrary = frequency
+ -- timestamp is not usually negative
+ [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary))
+ , (50, MTimeHighRes <$> arbitrary)
+ ]
+
+prop_read_show_inodecache :: InodeCache -> Bool
+prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of
+ Nothing -> False
+ Just c' -> compareStrong c c'
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index ec16e33..a8a7111 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,6 +1,6 @@
{- Metered IO and actions
-
- - Copyright 2012-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -9,8 +9,10 @@
module Utility.Metered (
MeterUpdate,
+ MeterState(..),
nullMeterUpdate,
combineMeterUpdate,
+ TotalSize(..),
BytesProcessed(..),
toBytesProcessed,
fromBytesProcessed,
@@ -29,10 +31,13 @@ module Utility.Metered (
ProgressParser,
commandMeter,
commandMeter',
+ commandMeterExitCode,
+ commandMeterExitCode',
demeterCommand,
demeterCommandEnv,
avoidProgress,
rateLimitMeterUpdate,
+ bwLimitMeterUpdate,
Meter,
mkMeter,
setMeterTotalSize,
@@ -46,6 +51,9 @@ import Common
import Utility.Percentage
import Utility.DataUnits
import Utility.HumanTime
+import Utility.SimpleProtocol as Proto
+import Utility.ThreadScheduler
+import Utility.SafeOutput
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
@@ -73,7 +81,7 @@ combineMeterUpdate a b = \n -> a n >> b n
{- Total number of bytes processed so far. -}
newtype BytesProcessed = BytesProcessed Integer
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Read)
class AsBytesProcessed a where
toBytesProcessed :: a -> BytesProcessed
@@ -113,23 +121,24 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
hGetContentsMetered h meterupdate >>= a
-{- Writes a ByteString to a Handle, updating a meter as it's written. -}
-meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
-meteredWrite meterupdate h = void . meteredWrite' meterupdate h
+{- Calls the action repeatedly with chunks from the lazy ByteString.
+ - Updates the meter after each chunk is processed. -}
+meteredWrite :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO ()
+meteredWrite meterupdate a = void . meteredWrite' meterupdate a
-meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed
-meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks
+meteredWrite' :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO BytesProcessed
+meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks
where
go sofar [] = return sofar
go sofar (c:cs) = do
- S.hPut h c
+ a c
let !sofar' = addBytesProcessed sofar $ S.length c
meterupdate sofar'
go sofar' cs
meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->
- meteredWrite meterupdate h b
+ meteredWrite meterupdate (S.hPut h) b
{- Applies an offset to a MeterUpdate. This can be useful when
- performing a sequence of actions, such as multiple meteredWriteFiles,
@@ -165,8 +174,9 @@ hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed
c <- S.hGet h (nextchunksize (fromBytesProcessed sofar))
if S.null c
then do
- hClose h
- return $ L.empty
+ when (wantsize /= Just 0) $
+ hClose h
+ return L.empty
else do
let !sofar' = addBytesProcessed sofar (S.length c)
meterupdate sofar'
@@ -218,7 +228,8 @@ watchFileSize f p a = bracket
p sz
watcher sz
getsz = catchDefaultIO zeroBytesProcessed $
- toBytesProcessed <$> getFileSize f
+ toBytesProcessed <$> getFileSize f'
+ f' = toRawFilePath f
data OutputHandler = OutputHandler
{ quietMode :: Bool
@@ -226,31 +237,45 @@ data OutputHandler = OutputHandler
}
{- 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.
+ - Maybe the number of bytes done so far, optionally a total size,
+ - 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)
+type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String)
+
+newtype TotalSize = TotalSize Integer
+ deriving (Show, Eq)
{- Runs a command and runs a ProgressParser on its output, in order
- to update a meter.
+ -
+ - If the Meter is provided, the ProgressParser can report the total size,
+ - which allows creating a Meter before the size is known.
-}
-commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
-commandMeter progressparser oh meterupdate cmd params = do
- ret <- commandMeter' progressparser oh meterupdate cmd params
+commandMeter :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
+commandMeter progressparser oh meter meterupdate cmd params =
+ commandMeter' progressparser oh meter meterupdate cmd params id
+
+commandMeter' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool
+commandMeter' progressparser oh meter meterupdate cmd params mkprocess = do
+ ret <- commandMeterExitCode' progressparser oh meter meterupdate cmd params mkprocess
return $ case ret of
Just ExitSuccess -> True
_ -> False
-commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)
-commandMeter' progressparser oh meterupdate cmd params =
- outputFilter cmd params Nothing
- (feedprogress zeroBytesProcessed [])
+commandMeterExitCode :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)
+commandMeterExitCode progressparser oh meter meterupdate cmd params =
+ commandMeterExitCode' progressparser oh meter meterupdate cmd params id
+
+commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode)
+commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess =
+ outputFilter cmd params mkprocess Nothing
+ (const $ feedprogress mmeter zeroBytesProcessed [])
handlestderr
where
- feedprogress prev buf h = do
+ feedprogress sendtotalsize prev buf h = do
b <- S.hGetSome h 80
if S.null b
then return ()
@@ -259,17 +284,24 @@ commandMeter' progressparser oh meterupdate cmd params =
S.hPut stdout b
hFlush stdout
let s = decodeBS b
- let (mbytes, buf') = progressparser (buf++s)
+ let (mbytes, mtotalsize, buf') = progressparser (buf++s)
+ sendtotalsize' <- case (sendtotalsize, mtotalsize) of
+ (Just meter, Just t) -> do
+ setMeterTotalSize meter t
+ return Nothing
+ _ -> return sendtotalsize
case mbytes of
- Nothing -> feedprogress prev buf' h
+ Nothing -> feedprogress sendtotalsize' prev buf' h
(Just bytes) -> do
when (bytes /= prev) $
meterupdate bytes
- feedprogress bytes buf' h
+ feedprogress sendtotalsize' bytes buf' h
- handlestderr h = unlessM (hIsEOF h) $ do
- stderrHandler oh =<< hGetLine h
- handlestderr h
+ handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case
+ Just l -> do
+ stderrHandler oh l
+ handlestderr ph h
+ Nothing -> return ()
{- Runs a command, that may display one or more progress meters on
- either stdout or stderr, and prevents the meters from being displayed.
@@ -281,46 +313,54 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
demeterCommandEnv oh cmd params environ = do
- ret <- outputFilter cmd params environ
- (\outh -> avoidProgress True outh stdouthandler)
- (\errh -> avoidProgress True errh $ stderrHandler oh)
+ ret <- outputFilter cmd params id environ
+ (\ph outh -> avoidProgress True ph outh stdouthandler)
+ (\ph errh -> avoidProgress True ph errh $ stderrHandler oh)
return $ case ret of
Just ExitSuccess -> True
_ -> False
where
stdouthandler l =
unless (quietMode oh) $
- putStrLn l
+ putStrLn (safeOutput 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
+avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO ()
+avoidProgress doavoid ph h emitter = hGetLineUntilExitOrEOF ph h >>= \case
+ Just s -> do
+ unless (doavoid && '\r' `elem` s) $
+ emitter s
+ avoidProgress doavoid ph h emitter
+ Nothing -> return ()
outputFilter
:: FilePath
-> [CommandParam]
+ -> (CreateProcess -> CreateProcess)
-> Maybe [(String, String)]
- -> (Handle -> IO ())
- -> (Handle -> IO ())
+ -> (ProcessHandle -> Handle -> IO ())
+ -> (ProcessHandle -> Handle -> IO ())
-> IO (Maybe ExitCode)
-outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do
- (_, Just outh, Just errh, pid) <- createProcess p
- { std_out = CreatePipe
+outputFilter cmd params mkprocess environ outfilter errfilter =
+ catchMaybeIO $ withCreateProcess p go
+ where
+ go _ (Just outh) (Just errh) ph = do
+ outt <- async $ tryIO (outfilter ph outh) >> hClose outh
+ errt <- async $ tryIO (errfilter ph errh) >> hClose errh
+ ret <- waitForProcess ph
+ wait outt
+ wait errt
+ return ret
+ go _ _ _ _ = error "internal"
+
+ p = mkprocess (proc cmd (toCommand params))
+ { env = environ
+ , std_out = CreatePipe
, std_err = CreatePipe
}
- void $ async $ tryIO (outfilter outh) >> hClose outh
- void $ async $ tryIO (errfilter errh) >> hClose errh
- waitForProcess pid
- where
- p = (proc cmd (toCommand params))
- { env = environ }
-- | Limit a meter to only update once per unit of time.
--
@@ -333,7 +373,7 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do
return $ mu lastupdate
where
mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case
- Just t | i >= t -> meterupdate n
+ Just (TotalSize t) | i >= t -> meterupdate n
_ -> do
now <- getPOSIXTime
prev <- takeMVar lastupdate
@@ -343,46 +383,95 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do
meterupdate n
else putMVar lastupdate prev
-data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter
+-- | Bandwidth limiting by inserting a delay at the point that a meter is
+-- updated.
+--
+-- This will only work when the actions that use bandwidth are run in the
+-- same process and thread as the call to the MeterUpdate.
+--
+-- For example, if the desired bandwidth is 100kb/s, and over the past
+-- 1/10th of a second, 30kb was sent, then the current bandwidth is
+-- 300kb/s, 3x as fast as desired. So, after getting the next chunk,
+-- pause for twice as long as it took to get it.
+bwLimitMeterUpdate :: ByteSize -> Duration -> MeterUpdate -> IO MeterUpdate
+bwLimitMeterUpdate bwlimit duration meterupdate
+ | bwlimit <= 0 = return meterupdate
+ | otherwise = do
+ nowtime <- getPOSIXTime
+ mv <- newMVar (nowtime, Nothing)
+ return (mu mv)
+ where
+ mu mv n@(BytesProcessed i) = do
+ endtime <- getPOSIXTime
+ (starttime, mprevi) <- takeMVar mv
+
+ case mprevi of
+ Just previ -> do
+ let runtime = endtime - starttime
+ let currbw = fromIntegral (i - previ) / runtime
+ let pausescale = if currbw > bwlimit'
+ then (currbw / bwlimit') - 1
+ else 0
+ unboundDelay (floor (runtime * pausescale * msecs))
+ Nothing -> return ()
+
+ meterupdate n
-type MeterState = (BytesProcessed, POSIXTime)
+ nowtime <- getPOSIXTime
+ putMVar mv (nowtime, Just i)
-type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO ()
+ bwlimit' = fromIntegral (bwlimit * durationSeconds duration)
+ msecs = fromIntegral oneSecond
-type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String
+data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter
+
+data MeterState = MeterState
+ { meterBytesProcessed :: BytesProcessed
+ , meterTimeStamp :: POSIXTime
+ } deriving (Show)
+
+type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO ()
+
+type RenderMeter = Maybe TotalSize -> MeterState -> MeterState -> String
-- | Make a meter. Pass the total size, if it's known.
-mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter
-mkMeter totalsize displaymeter = Meter
- <$> newMVar totalsize
- <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime)
- <*> newMVar ""
- <*> pure displaymeter
-
-setMeterTotalSize :: Meter -> Integer -> IO ()
+mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter
+mkMeter totalsize displaymeter = do
+ ts <- getPOSIXTime
+ Meter
+ <$> newMVar totalsize
+ <*> newMVar (MeterState zeroBytesProcessed ts)
+ <*> newMVar ""
+ <*> pure displaymeter
+
+setMeterTotalSize :: Meter -> TotalSize -> IO ()
setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just
-- | Updates the meter, displaying it if necessary.
updateMeter :: Meter -> MeterUpdate
updateMeter (Meter totalsizev sv bv displaymeter) new = do
now <- getPOSIXTime
- (old, before) <- swapMVar sv (new, now)
- when (old /= new) $ do
+ let curms = MeterState new now
+ oldms <- swapMVar sv curms
+ when (meterBytesProcessed oldms /= new) $ do
totalsize <- readMVar totalsizev
- displaymeter bv totalsize (old, before) (new, now)
+ displaymeter bv totalsize oldms curms
-- | Display meter to a Handle.
displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter
displayMeterHandle h rendermeter v msize old new = do
+ olds <- takeMVar v
let s = rendermeter msize old new
- olds <- swapMVar v s
+ let padding = replicate (length olds - length s) ' '
+ let s' = s <> padding
+ putMVar v s'
-- Avoid writing when the rendered meter has not changed.
- when (olds /= s) $ do
- let padding = replicate (length olds - length s) ' '
- hPutStr h ('\r':s ++ padding)
+ when (olds /= s') $ do
+ hPutStr h ('\r':s')
hFlush h
--- | Clear meter displayed by displayMeterHandle.
+-- | Clear meter displayed by displayMeterHandle. May be called before
+-- outputting something else, followed by more calls to displayMeterHandle.
clearMeterHandle :: Meter -> Handle -> IO ()
clearMeterHandle (Meter _ _ v _) h = do
olds <- readMVar v
@@ -394,7 +483,7 @@ clearMeterHandle (Meter _ _ v _) h = do
-- or when total size is not known:
-- 1.3 MiB 300 KiB/s
bandwidthMeter :: RenderMeter
-bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) =
+bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState (BytesProcessed new) now) =
unwords $ catMaybes
[ Just percentamount
-- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s"
@@ -403,22 +492,26 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now)
, estimatedcompletion
]
where
- amount = roughSize' memoryUnits True 2 new
+ amount = roughSize' committeeUnits True 2 new
percentamount = case mtotalsize of
- Just totalsize ->
+ Just (TotalSize totalsize) ->
let p = showPercentage 0 $
percentage totalsize (min new totalsize)
in p ++ replicate (6 - length p) ' ' ++ amount
Nothing -> amount
- rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s"
+ rate = roughSize' committeeUnits True 0 bytespersecond ++ "/s"
bytespersecond
| duration == 0 = fromIntegral transferred
| otherwise = floor $ fromIntegral transferred / duration
transferred = max 0 (new - old)
duration = max 0 (now - before)
estimatedcompletion = case mtotalsize of
- Just totalsize
+ Just (TotalSize totalsize)
| bytespersecond > 0 ->
Just $ fromDuration $ Duration $
(totalsize - new) `div` bytespersecond
_ -> Nothing
+
+instance Proto.Serializable BytesProcessed where
+ serialize (BytesProcessed n) = show n
+ deserialize = BytesProcessed <$$> readish
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 2f1766e..3cf5275 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -11,6 +11,8 @@ module Utility.Misc (
hGetContentsStrict,
readFileStrict,
separate,
+ separate',
+ separateEnd',
firstLine,
firstLine',
segment,
@@ -54,6 +56,20 @@ separate c l = unbreak $ break c l
| null b = r
| otherwise = (a, tail b)
+separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
+separate' c l = unbreak $ S.break c l
+ where
+ unbreak r@(a, b)
+ | S.null b = r
+ | otherwise = (a, S.tail b)
+
+separateEnd' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
+separateEnd' c l = unbreak $ S.breakEnd c l
+ where
+ unbreak r@(a, b)
+ | S.null a = r
+ | otherwise = (S.init a, b)
+
{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
@@ -78,7 +94,7 @@ prop_segment_regressionTest :: Bool
prop_segment_regressionTest = all id
-- Even an empty list is a segment.
[ segment (== "--") [] == [[]]
- -- There are two segements in this list, even though the first is empty.
+ -- There are two segments in this list, even though the first is empty.
, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
]
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index abe06f3..6cd2c5e 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -12,6 +12,7 @@ module Utility.Monad (
getM,
anyM,
allM,
+ partitionM,
untilTrue,
ifM,
(<||>),
@@ -45,6 +46,13 @@ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM p (x:xs) = p x <&&> allM p xs
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = return ([], [])
+partitionM p (x:xs) = do
+ r <- p x
+ (as, bs) <- partitionM p xs
+ return $ if r then (x:as, bs) else (as, x:bs)
+
{- Runs an action on values from a list until it succeeds. -}
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM
diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs
new file mode 100644
index 0000000..6481b29
--- /dev/null
+++ b/Utility/MoveFile.hs
@@ -0,0 +1,79 @@
+{- moving files
+ -
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.MoveFile (
+ moveFile,
+) where
+
+import Control.Monad
+import System.IO.Error
+import Prelude
+
+#ifndef mingw32_HOST_OS
+import System.PosixCompat.Files (isDirectory)
+import Control.Monad.IfElse
+import Utility.SafeCommand
+#endif
+
+import Utility.SystemDirectory
+import Utility.Tmp
+import Utility.Exception
+import Utility.Monad
+import Utility.FileSystemEncoding
+import qualified Utility.RawFilePath as R
+
+{- Moves one filename to another.
+ - First tries a rename, but falls back to moving across devices if needed. -}
+moveFile :: RawFilePath -> RawFilePath -> IO ()
+moveFile src dest = tryIO (R.rename src dest) >>= onrename
+ where
+ onrename (Right _) = noop
+ onrename (Left e)
+ | isPermissionError e = rethrow
+ | isDoesNotExistError e = rethrow
+ | otherwise = viaTmp mv (fromRawFilePath 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 (fromRawFilePath src)
+ , Param tmp
+ ]
+ let e' = e
+#else
+ r <- tryIO $ copyFile (fromRawFilePath 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
+ throwM e'
+
+#ifndef mingw32_HOST_OS
+ isdir f = do
+ r <- tryIO $ R.getSymbolicLinkStatus f
+ case r of
+ (Left _) -> return False
+ (Right s) -> return $ isDirectory s
+#endif
diff --git a/Utility/Path.hs b/Utility/Path.hs
index ecc752c..64ef076 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,63 +1,63 @@
{- path manipulation
-
- - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path (
simplifyPath,
- absPathFrom,
parentDir,
upFrom,
dirContains,
- absPath,
- relPathCwdToFile,
- relPathDirToFile,
- relPathDirToFileAbs,
segmentPaths,
+ segmentPaths',
runSegmentPaths,
- relHome,
- inPath,
- searchPath,
+ runSegmentPaths',
dotfile,
- sanitizeFilePath,
splitShortExtensions,
-
- prop_upFrom_basics,
- prop_relPathDirToFile_basics,
- prop_relPathDirToFile_regressionTest,
+ splitShortExtensions',
+ relPathDirToFileAbs,
+ inSearchPath,
+ searchPath,
+ searchPathContents,
) where
-import System.FilePath
+import System.FilePath.ByteString
+import qualified System.FilePath as P
+import qualified Data.ByteString as B
import Data.List
import Data.Maybe
-import Data.Char
+import Control.Monad
import Control.Applicative
import Prelude
import Utility.Monad
-import Utility.UserInfo
-import Utility.Directory
-import Utility.Split
+import Utility.SystemDirectory
+import Utility.Exception
+
+#ifdef mingw32_HOST_OS
+import Data.Char
import Utility.FileSystemEncoding
+#endif
{- 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
+ - the input RawFilePaths. This is done because some programs in Windows
- demand a particular path separator -- and which one actually varies!
-
- This does not guarantee that two paths that refer to the same location,
- and are both relative to the same location (or both absolute) will
- - yeild the same result. Run both through normalise from System.FilePath
+ - yield the same result. Run both through normalise from System.RawFilePath
- to ensure that.
-}
-simplifyPath :: FilePath -> FilePath
+simplifyPath :: RawFilePath -> RawFilePath
simplifyPath path = dropTrailingPathSeparator $
joinDrive drive $ joinPath $ norm [] $ splitPath path'
where
@@ -72,88 +72,143 @@ simplifyPath path = dropTrailingPathSeparator $
where
p' = dropTrailingPathSeparator p
-{- Makes a path absolute.
- -
- - The first parameter is a base directory (ie, the cwd) to use if the path
- - is not already absolute, and should itsef be absolute.
- -
- - Does not attempt to deal with edge cases or ensure security with
- - untrusted inputs.
- -}
-absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom dir path = simplifyPath (combine dir path)
-
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
-parentDir :: FilePath -> FilePath
+parentDir :: RawFilePath -> RawFilePath
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
+- parent (ie for "/" or "." or "foo") -}
+upFrom :: RawFilePath -> Maybe RawFilePath
upFrom dir
| length dirs < 2 = Nothing
- | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs
+ | otherwise = Just $ joinDrive drive $
+ B.intercalate (B.singleton pathSeparator) $ init dirs
where
-- on Unix, the drive will be "/" when the dir is absolute,
-- otherwise ""
(drive, path) = splitDrive dir
- s = [pathSeparator]
- dirs = filter (not . null) $ split s path
-
-prop_upFrom_basics :: FilePath -> Bool
-prop_upFrom_basics dir
- | null dir = True
- | dir == "/" = p == Nothing
- | otherwise = p /= Just dir
- where
- p = upFrom dir
+ dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
-{- Checks if the first FilePath is, or could be said to contain the second.
+{- Checks if the first RawFilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- - are all equivilant.
+ - are all equivalent.
-}
-dirContains :: FilePath -> FilePath -> Bool
+dirContains :: RawFilePath -> RawFilePath -> Bool
dirContains a b = a == b
|| a' == b'
- || (addTrailingPathSeparator a') `isPrefixOf` b'
- || a' == "." && normalise ("." </> b') == b'
+ || (a'' `B.isPrefixOf` b' && avoiddotdotb)
+ || a' == "." && normalise ("." </> b') == b' && nodotdot b'
+ || dotdotcontains
where
a' = norm a
+ a'' = addTrailingPathSeparator a'
b' = norm b
norm = normalise . simplifyPath
-{- Converts a filename into an absolute path.
- -
- - Unlike Directory.canonicalizePath, this does not require the path
- - already exists. -}
-absPath :: FilePath -> IO FilePath
-absPath file = do
- cwd <- getCurrentDirectory
- return $ absPathFrom cwd file
+ {- This handles the case where a is ".." and b is "../..",
+ - which is not inside a. Similarly, "../.." does not contain
+ - "../../../". Due to the use of norm, cases like
+ - "../../foo/../../" get converted to eg "../../.." and
+ - so do not need to be handled specially here.
+ -
+ - When this is called, we already know that
+ - a'' is a prefix of b', so all that needs to be done is drop
+ - that prefix, and check if the next path component is ".."
+ -}
+ avoiddotdotb = nodotdot $ B.drop (B.length a'') b'
-{- Constructs a relative path from the CWD to a file.
+ nodotdot p = all (not . isdotdot) (splitPath p)
+
+ isdotdot s = dropTrailingPathSeparator s == ".."
+
+ {- This handles the case where a is ".." or "../.." etc,
+ - and b is "foo" or "../foo" etc. The rule is that when
+ - a is entirely ".." components, b is under it when it starts
+ - with fewer ".." components.
+ -
+ - Due to the use of norm, cases like "../../foo/../../" get
+ - converted to eg "../../../" and so do not need to be handled
+ - specially here.
+ -}
+ dotdotcontains
+ | isAbsolute b' = False
+ | otherwise =
+ let aps = splitPath a'
+ bps = splitPath b'
+ in if all isdotdot aps
+ then length (takeWhile isdotdot bps) < length aps
+ else False
+
+{- Given an original list of paths, and an expanded list derived from it,
+ - 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.
-
- - For example, assuming CWD is /tmp/foo/bar:
- - relPathCwdToFile "/tmp/foo" == ".."
- - relPathCwdToFile "/tmp/foo/bar" == ""
+ - 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.
-}
-relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = do
- c <- getCurrentDirectory
- relPathDirToFile c f
+segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
+segmentPaths = segmentPaths' (\_ r -> r)
-{- Constructs a relative path from a directory to a file. -}
-relPathDirToFile :: FilePath -> FilePath -> IO FilePath
-relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
+segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]]
+segmentPaths' f _ [] new = [map (f Nothing) new]
+segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation
+segmentPaths' f c (i:is) new =
+ map (f (Just i)) found : segmentPaths' f c is rest
+ where
+ (found, rest) = if length is < 100
+ then partition ini new
+ else break (not . ini) new
+ ini p = i `dirContains` c p
-{- This requires the first path to be absolute, and the
- - second path cannot contain ../ or ./
+{- 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
+ - the case of git file list commands, that assumption tends to hold.
+ -}
+runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
+runSegmentPaths c a paths = segmentPaths c paths <$> a paths
+
+runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]]
+runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths
+
+{- Checks if a filename is a unix dotfile. All files inside dotdirs
+ - count as dotfiles. -}
+dotfile :: RawFilePath -> Bool
+dotfile file
+ | f == "." = False
+ | f == ".." = False
+ | f == "" = False
+ | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file)
+ where
+ f = takeFileName file
+
+{- Similar to splitExtensions, but knows that some things in RawFilePaths
+ - after a dot are too long to be extensions. -}
+splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString])
+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
+splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString])
+splitShortExtensions' maxextension = go []
+ where
+ go c f
+ | len > 0 && len <= maxextension && not (B.null base) =
+ go (ext:c) base
+ | otherwise = (f, c)
+ where
+ (base, ext) = splitExtension f
+ len = B.length ext
+
+{- This requires both paths to be absolute and normalized.
-
- On Windows, if the paths are on different drives,
- a relative path is not possible and the path is simply
- returned as-is.
-}
-relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
+relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath
relPathDirToFileAbs from to
#ifdef mingw32_HOST_OS
| normdrive from /= normdrive to = to
@@ -169,72 +224,21 @@ relPathDirToFileAbs from to
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
#ifdef mingw32_HOST_OS
- normdrive = map toLower . takeWhile (/= ':') . takeDrive
+ normdrive = map toLower
+ -- Get just the drive letter, removing any leading
+ -- path separator, which takeDrive leaves on the drive
+ -- letter.
+ . dropWhileEnd (isPathSeparator . fromIntegral . ord)
+ . fromRawFilePath
+ . takeDrive
#endif
-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 = relPathDirToFileAbs from to
-
-prop_relPathDirToFile_regressionTest :: Bool
-prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- where
- {- Two paths have the same directory component at the same
- - location, but it's not really the same directory.
- - Code used to get this wrong. -}
- same_dir_shortcurcuits_at_difference =
- 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,
- - 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 :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
-segmentPaths [] new = [new]
-segmentPaths [_] new = [new] -- optimisation
-segmentPaths (l:ls) new = found : segmentPaths ls rest
- where
- (found, rest) = if length ls < 100
- then partition inl new
- else break (not . inl) new
- inl f = fromRawFilePath l `dirContains` fromRawFilePath f
-
-{- 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
- - the case of git file list commands, that assumption tends to hold.
- -}
-runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
-runSegmentPaths a paths = segmentPaths paths <$> a paths
-
-{- Converts paths in the home directory to use ~/ -}
-relHome :: FilePath -> IO String
-relHome path = do
- home <- myHomeDir
- return $ if dirContains home path
- then "~/" ++ relPathDirToFileAbs home path
- else path
-
{- Checks if a command is available in PATH.
-
- The command may be fully-qualified, in which case, this succeeds as
- long as it exists. -}
-inPath :: String -> IO Bool
-inPath command = isJust <$> searchPath command
+inSearchPath :: String -> IO Bool
+inSearchPath command = isJust <$> searchPath command
{- Finds a command in PATH and returns the full path to it.
-
@@ -245,10 +249,10 @@ inPath command = isJust <$> searchPath command
-}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
- | isAbsolute command = check command
- | otherwise = getSearchPath >>= getM indir
+ | P.isAbsolute command = check command
+ | otherwise = P.getSearchPath >>= getM indir
where
- indir d = check $ d </> command
+ indir d = check $ d P.</> command
check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
[f, f ++ ".exe"]
@@ -256,44 +260,16 @@ searchPath command
[f]
#endif
-{- Checks if a filename is a unix dotfile. All files inside dotdirs
- - count as dotfiles. -}
-dotfile :: FilePath -> Bool
-dotfile file
- | f == "." = False
- | f == ".." = False
- | f == "" = False
- | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
- where
- f = takeFileName file
-
-{- Given a string that we'd like to use as the basis for FilePath, but that
- - was provided by a third party and is not to be trusted, returns the closest
- - sane FilePath.
+{- Finds commands in PATH that match a predicate. Note that the predicate
+ - matches on the basename of the command, but the full path to it is
+ - returned.
-
- - All spaces and punctuation and other wacky stuff are replaced
- - with '_', except for '.'
- - "../" will thus turn into ".._", which is safe.
+ - Note that this will find commands in PATH that are not executable.
-}
-sanitizeFilePath :: String -> FilePath
-sanitizeFilePath = map sanitize
- where
- sanitize c
- | c == '.' = c
- | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
- | otherwise = c
-
-{- Similar to splitExtensions, but knows that some things in FilePaths
- - after a dot are too long to be extensions. -}
-splitShortExtensions :: FilePath -> (FilePath, [String])
-splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
-splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
-splitShortExtensions' maxextension = go []
+searchPathContents :: (FilePath -> Bool) -> IO [FilePath]
+searchPathContents p =
+ filterM doesFileExist
+ =<< (concat <$> (P.getSearchPath >>= mapM go))
where
- go c f
- | len > 0 && len <= maxextension && not (null base) =
- go (ext:c) base
- | otherwise = (f, c)
- where
- (base, ext) = splitExtension f
- len = length ext
+ go d = map (d P.</>) . filter p
+ <$> catchDefaultIO [] (getDirectoryContents d)
diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs
new file mode 100644
index 0000000..4007fbb
--- /dev/null
+++ b/Utility/Path/AbsRel.hs
@@ -0,0 +1,99 @@
+{- absolute and relative path manipulation
+ -
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Path.AbsRel (
+ absPathFrom,
+ absPath,
+ relPathCwdToFile,
+ relPathDirToFile,
+ relPathDirToFileAbs,
+ relHome,
+) where
+
+import System.FilePath.ByteString
+import qualified Data.ByteString as B
+#ifdef mingw32_HOST_OS
+import System.Directory (getCurrentDirectory)
+#else
+import System.Posix.Directory.ByteString (getWorkingDirectory)
+#endif
+import Control.Applicative
+import Prelude
+
+import Utility.Path
+import Utility.UserInfo
+import Utility.FileSystemEncoding
+
+{- Makes a path absolute.
+ -
+ - Also simplifies it using simplifyPath.
+ -
+ - The first parameter is a base directory (ie, the cwd) to use if the path
+ - is not already absolute, and should itself be absolute.
+ -
+ - Does not attempt to deal with edge cases or ensure security with
+ - untrusted inputs.
+ -}
+absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath
+absPathFrom dir path = simplifyPath (combine dir path)
+
+{- Converts a filename into an absolute path.
+ -
+ - Also simplifies it using simplifyPath.
+ -
+ - Unlike Directory.canonicalizePath, this does not require the path
+ - already exists. -}
+absPath :: RawFilePath -> IO RawFilePath
+absPath file
+ -- Avoid unncessarily getting the current directory when the path
+ -- is already absolute. absPathFrom uses simplifyPath
+ -- so also used here for consistency.
+ | isAbsolute file = return $ simplifyPath file
+ | otherwise = do
+#ifdef mingw32_HOST_OS
+ cwd <- toRawFilePath <$> getCurrentDirectory
+#else
+ cwd <- getWorkingDirectory
+#endif
+ return $ absPathFrom cwd file
+
+{- Constructs the minimal relative path from the CWD to a file.
+ -
+ - For example, assuming CWD is /tmp/foo/bar:
+ - relPathCwdToFile "/tmp/foo" == ".."
+ - relPathCwdToFile "/tmp/foo/bar" == ""
+ - relPathCwdToFile "../bar/baz" == "baz"
+ -}
+relPathCwdToFile :: RawFilePath -> IO RawFilePath
+relPathCwdToFile f
+ -- Optimisation: Avoid doing any IO when the path is relative
+ -- and does not contain any ".." component.
+ | isRelative f && not (".." `B.isInfixOf` f) = return f
+ | otherwise = do
+#ifdef mingw32_HOST_OS
+ c <- toRawFilePath <$> getCurrentDirectory
+#else
+ c <- getWorkingDirectory
+#endif
+ relPathDirToFile c f
+
+{- Constructs a minimal relative path from a directory to a file. -}
+relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
+
+{- Converts paths in the home directory to use ~/ -}
+relHome :: FilePath -> IO String
+relHome path = do
+ let path' = toRawFilePath path
+ home <- toRawFilePath <$> myHomeDir
+ return $ if dirContains home path'
+ then fromRawFilePath ("~/" <> relPathDirToFileAbs home path')
+ else path
diff --git a/Utility/Process.hs b/Utility/Process.hs
index af3a5f4..07f035d 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -1,17 +1,17 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP, Rank2Types #-}
+{-# LANGUAGE CPP, Rank2Types, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Process (
module X,
- CreateProcess(..),
StdHandle(..),
readProcess,
readProcess',
@@ -20,41 +20,33 @@ module Utility.Process (
forceSuccessProcess,
forceSuccessProcess',
checkSuccessProcess,
- ignoreFailureProcess,
- createProcessSuccess,
- createProcessChecked,
- createBackgroundProcess,
- withHandle,
- withIOHandles,
- withOEHandles,
withNullHandle,
- withQuietOutput,
- feedWithQuietOutput,
createProcess,
+ withCreateProcess,
waitForProcess,
+ cleanupProcess,
+ hGetLineUntilExitOrEOF,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
stderrHandle,
- ioHandles,
processHandle,
+ showCmd,
devNull,
) where
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.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf)
import Utility.Misc
import Utility.Exception
+import Utility.Monad
+import Utility.Debug
import System.Exit
import System.IO
-import System.Log.Logger
-import Control.Concurrent
-import qualified Control.Exception as E
-import Control.Monad
-
-type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+import Control.Monad.IO.Class
+import Control.Concurrent.Async
+import qualified Data.ByteString as S
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
@@ -62,21 +54,22 @@ data StdHandle = StdinHandle | StdoutHandle | StderrHandle
-- | 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
+readProcess cmd args = readProcess' (proc cmd args)
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
-readProcessEnv cmd args environ = readProcess' p
- where
- p = (proc cmd args)
- { std_out = CreatePipe
- , env = environ
- }
+readProcessEnv cmd args environ =
+ readProcess' $ (proc cmd args) { env = environ }
readProcess' :: CreateProcess -> IO String
-readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
- output <- hGetContentsStrict h
- hClose h
- return output
+readProcess' p = withCreateProcess p' go
+ where
+ p' = p { std_out = CreatePipe }
+ go _ (Just h) _ pid = do
+ output <- hGetContentsStrict h
+ hClose h
+ forceSuccessProcess p' pid
+ return output
+ go _ _ _ _ = error "internal"
-- | Runs an action to write to a process on its stdin,
-- returns its output, and also allows specifying the environment.
@@ -85,32 +78,8 @@ writeReadProcessEnv
-> [String]
-> Maybe [(String, String)]
-> (Maybe (Handle -> IO ()))
- -> (Maybe (Handle -> IO ()))
- -> IO String
-writeReadProcessEnv cmd args environ writestdin adjusthandle = do
- (Just inh, Just outh, _, pid) <- createProcess p
-
- maybe (return ()) (\a -> a inh) adjusthandle
- maybe (return ()) (\a -> a outh) adjusthandle
-
- -- fork off a thread to start consuming the output
- output <- hGetContents outh
- outMVar <- newEmptyMVar
- _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
-
- -- now write and flush any input
- maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
- hClose inh -- done with stdin
-
- -- wait on the output
- takeMVar outMVar
- hClose outh
-
- -- wait on the process
- forceSuccessProcess p pid
-
- return output
-
+ -> IO S.ByteString
+writeReadProcessEnv cmd args environ writestdin = withCreateProcess p go
where
p = (proc cmd args)
{ std_in = CreatePipe
@@ -118,6 +87,18 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
, std_err = Inherit
, env = environ
}
+
+ go (Just inh) (Just outh) _ pid = do
+ let reader = hClose outh `after` S.hGetContents outh
+ let writer = do
+ maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
+ hClose inh
+ (output, ()) <- concurrently reader writer
+
+ forceSuccessProcess p pid
+
+ return output
+ go _ _ _ _ = error "internal"
-- | Waits for a ProcessHandle, and throws an IOError if the process
-- did not exit successfully.
@@ -130,117 +111,15 @@ forceSuccessProcess' p (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. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
code <- waitForProcess pid
return $ code == ExitSuccess
-ignoreFailureProcess :: ProcessHandle -> IO Bool
-ignoreFailureProcess pid = do
- void $ waitForProcess pid
- return True
-
--- | 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.
-createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
-createProcessChecked checker p a = do
- t@(_, _, _, pid) <- createProcess p
- r <- tryNonAsync $ a t
- _ <- checker pid
- either E.throw return r
-
--- | 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 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
- -> CreateProcess
- -> (Handle -> IO a)
- -> IO a
-withHandle h creator p a = creator p' $ a . select
- where
- base = p
- { std_in = Inherit
- , std_out = Inherit
- , std_err = Inherit
- }
- (select, p') = case h of
- StdinHandle -> (stdinHandle, base { std_in = CreatePipe })
- StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })
- StderrHandle -> (stderrHandle, base { std_err = CreatePipe })
-
--- | Like withHandle, but passes (stdin, stdout) handles to the action.
-withIOHandles
- :: CreateProcessRunner
- -> CreateProcess
- -> ((Handle, Handle) -> IO a)
- -> IO a
-withIOHandles creator p a = creator p' $ a . ioHandles
- where
- p' = p
- { std_in = CreatePipe
- , std_out = CreatePipe
- , std_err = Inherit
- }
-
--- | Like withHandle, but passes (stdout, stderr) handles to the action.
-withOEHandles
- :: CreateProcessRunner
- -> CreateProcess
- -> ((Handle, Handle) -> IO a)
- -> IO a
-withOEHandles creator p a = creator p' $ a . oeHandles
- where
- p' = p
- { std_in = Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
-
-withNullHandle :: (Handle -> IO a) -> IO a
-withNullHandle = withFile devNull WriteMode
-
--- | Forces the CreateProcessRunner to run quietly;
--- both stdout and stderr are discarded.
-withQuietOutput
- :: CreateProcessRunner
- -> CreateProcess
- -> IO ()
-withQuietOutput creator p = withNullHandle $ \nullh -> do
- let p' = p
- { std_out = UseHandle nullh
- , std_err = UseHandle nullh
- }
- 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
+withNullHandle :: (MonadIO m, MonadMask m) => (Handle -> m a) -> m a
+withNullHandle = bracket
+ (liftIO $ openFile devNull WriteMode)
+ (liftIO . hClose)
devNull :: FilePath
#ifndef mingw32_HOST_OS
@@ -256,6 +135,7 @@ devNull = "\\\\.\\NUL"
-- 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
stdinHandle _ = error "expected stdinHandle"
@@ -265,12 +145,6 @@ stdoutHandle _ = error "expected stdoutHandle"
stderrHandle :: HandleExtractor
stderrHandle (_, _, Just h, _) = h
stderrHandle _ = error "expected stderrHandle"
-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
@@ -302,15 +176,26 @@ startInteractiveProcess cmd args environ = do
-- | Wrapper around 'System.Process.createProcess' that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
- debugProcess p
- Utility.Process.Shim.createProcess p
+ r@(_, _, _, h) <- Utility.Process.Shim.createProcess p
+ debugProcess p h
+ return r
+
+-- | Wrapper around 'System.Process.withCreateProcess' that does debug logging.
+withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a
+withCreateProcess p action = bracket (createProcess p) cleanupProcess
+ (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-- | Debugging trace for a CreateProcess.
-debugProcess :: CreateProcess -> IO ()
-debugProcess p = debugM "Utility.Process" $ unwords
- [ action ++ ":"
- , showCmd p
- ]
+debugProcess :: CreateProcess -> ProcessHandle -> IO ()
+debugProcess p h = do
+ pid <- getPid h
+ debug "Utility.Process" $ unwords $
+ [ describePid pid
+ , action ++ ":"
+ , showCmd p
+ ] ++ case cwd p of
+ Nothing -> []
+ Just c -> ["in", show c]
where
action
| piped (std_in p) && piped (std_out p) = "chat"
@@ -320,9 +205,121 @@ debugProcess p = debugM "Utility.Process" $ unwords
piped Inherit = False
piped _ = True
+describePid :: Maybe Utility.Process.Shim.Pid -> String
+describePid Nothing = "process"
+describePid (Just p) = "process [" ++ show p ++ "]"
+
-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.
waitForProcess :: ProcessHandle -> IO ExitCode
waitForProcess h = do
+ -- Have to get pid before waiting, which closes the ProcessHandle.
+ pid <- getPid h
r <- Utility.Process.Shim.waitForProcess h
- debugM "Utility.Process" ("process done " ++ show r)
+ debug "Utility.Process" (describePid pid ++ " done " ++ show r)
return r
+
+cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
+#if MIN_VERSION_process(1,6,4)
+cleanupProcess = Utility.Process.Shim.cleanupProcess
+#else
+cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
+ -- Unlike the real cleanupProcess, this does not wait
+ -- for the process to finish in the background, so if
+ -- the process ignores SIGTERM, this can block until the process
+ -- gets around the exiting.
+ terminateProcess pid
+ let void _ = return ()
+ maybe (return ()) (void . tryNonAsync . hClose) mb_stdin
+ maybe (return ()) hClose mb_stdout
+ maybe (return ()) hClose mb_stderr
+ void $ waitForProcess pid
+#endif
+
+{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of
+ - file is reached, or the handle is closed, or if the process has exited
+ - and there is nothing more buffered to read from the handle.
+ -
+ - This is useful to protect against situations where the process might
+ - have transferred the handle being read to another process, and so
+ - the handle could remain open after the process has exited. That is a rare
+ - situation, but can happen. Consider a the process that started up a
+ - daemon, and the daemon inherited stderr from it, rather than the more
+ - usual behavior of closing the file descriptor. Reading from stderr
+ - would block past the exit of the process.
+ -
+ - In that situation, this will detect when the process has exited,
+ - and avoid blocking forever. But will still return anything the process
+ - buffered to the handle before exiting.
+ -
+ - Note on newline mode: This ignores whatever newline mode is configured
+ - for the handle, because there is no way to query that. On Windows,
+ - it will remove any \r coming before the \n. On other platforms,
+ - it does not treat \r specially.
+ -}
+hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
+hGetLineUntilExitOrEOF ph h = go []
+ where
+ go buf = do
+ ready <- waitforinputorerror smalldelay
+ if ready
+ then getloop buf go
+ else getProcessExitCode ph >>= \case
+ -- Process still running, wait longer.
+ Nothing -> go buf
+ -- Process is done. It's possible
+ -- that it output something and exited
+ -- since the prior hWaitForInput,
+ -- so check one more time for any buffered
+ -- output.
+ Just _ -> finalcheck buf
+
+ finalcheck buf = do
+ ready <- waitforinputorerror 0
+ if ready
+ then getloop buf finalcheck
+ -- No remaining buffered input, though the handle
+ -- may not be EOF if something else is keeping it
+ -- open. Treated the same as EOF.
+ else eofwithnolineend buf
+
+ -- On exception, proceed as if there was input;
+ -- EOF and any encoding issues are dealt with
+ -- when reading from the handle.
+ waitforinputorerror t = hWaitForInput h t
+ `catchNonAsync` const (pure True)
+
+ getchar =
+ catcherr EOF $
+ -- If the handle is closed, reading from it is
+ -- an IllegalOperation.
+ catcherr IllegalOperation $
+ Just <$> hGetChar h
+ where
+ catcherr t = catchIOErrorType t (const (pure Nothing))
+
+ getloop buf cont =
+ getchar >>= \case
+ Just c
+ | c == '\n' -> return (Just (gotline buf))
+ | otherwise -> cont (c:buf)
+ Nothing -> eofwithnolineend buf
+
+#ifndef mingw32_HOST_OS
+ gotline buf = reverse buf
+#else
+ gotline ('\r':buf) = reverse buf
+ gotline buf = reverse buf
+#endif
+
+ eofwithnolineend buf = return $
+ if null buf
+ then Nothing -- no line read
+ else Just (reverse buf)
+
+ -- Tenth of a second delay. If the process exits with the FD being
+ -- held open, will wait up to twice this long before returning.
+ -- This delay could be made smaller. However, that is an unusual
+ -- case, and making it too small would cause lots of wakeups while
+ -- waiting for output. Bearing in mind that this could be run on
+ -- many processes at the same time.
+ smalldelay = 100 -- milliseconds
diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs
new file mode 100644
index 0000000..7bf94ff
--- /dev/null
+++ b/Utility/Process/Transcript.hs
@@ -0,0 +1,97 @@
+{- Process transcript
+ -
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.Transcript (
+ processTranscript,
+ processTranscript',
+ processTranscript'',
+) where
+
+import Utility.Process
+
+import System.IO
+import System.Exit
+import Control.Concurrent.Async
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import Control.Exception
+import qualified System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+import Prelude
+
+-- | Runs a process 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 = processTranscript' (proc cmd opts)
+
+-- | Also feeds the process some input.
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
+ (t, c) <- processTranscript'' cp input
+ return (t, c == ExitSuccess)
+
+processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
+processTranscript'' cp input = do
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+ let setup = do
+ (readf, writef) <- System.Posix.IO.createPipe
+ System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
+ System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
+ return (readh, writeh)
+ let cleanup (readh, writeh) = do
+ hClose readh
+ hClose writeh
+ bracket setup cleanup $ \(readh, writeh) -> do
+ let cp' = cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ }
+ withCreateProcess cp' $ \hin hout herr pid -> do
+ get <- asyncreader pid readh
+ writeinput input (hin, hout, herr, pid)
+ code <- waitForProcess pid
+ transcript <- wait get
+ return (transcript, code)
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+ let cp' = cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ withCreateProcess cp' $ \hin hout herr pid -> do
+ let p = (hin, hout, herr, pid)
+ getout <- asyncreader pid (stdoutHandle p)
+ geterr <- asyncreader pid (stderrHandle p)
+ writeinput input p
+ code <- waitForProcess pid
+ transcript <- (++) <$> wait getout <*> wait geterr
+ return (transcript, code)
+#endif
+ where
+ asyncreader pid h = async $ reader pid h []
+ reader pid h c = hGetLineUntilExitOrEOF pid h >>= \case
+ Nothing -> return (unlines (reverse c))
+ Just l -> reader pid h (l:c)
+ writeinput (Just s) p = do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ writeinput Nothing _ = return ()
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index b0a39f3..96e31d5 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -1,25 +1,62 @@
{- QuickCheck with additional instances
-
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Utility.QuickCheck
( module X
- , module Utility.QuickCheck
+ , TestableString
+ , fromTestableString
+ , TestableFilePath(..)
+ , nonNegative
+ , positive
) where
import Test.QuickCheck as X
import Data.Time.Clock.POSIX
import Data.Ratio
+import Data.Char
import System.Posix.Types
import Data.List.NonEmpty (NonEmpty(..))
import Prelude
+{- A String, but Arbitrary is limited to ascii.
+ -
+ - When in a non-utf8 locale, String does not normally contain any non-ascii
+ - characters, except for ones in surrogate plane. Converting a string that
+ - does contain other unicode characters to a ByteString using the
+ - filesystem encoding (see GHC.IO.Encoding) will throw an exception,
+ - so use this instead to avoid quickcheck tests breaking unncessarily.
+ -}
+newtype TestableString = TestableString
+ { fromTestableString :: String }
+ deriving (Show)
+
+instance Arbitrary TestableString where
+ arbitrary = TestableString . filter isAscii <$> arbitrary
+
+{- FilePath constrained to not be the empty string, not contain a NUL,
+ - and contain only ascii.
+ -
+ - No real-world filename can be empty or contain a NUL. So code can
+ - well be written that assumes that and using this avoids quickcheck
+ - tests breaking unncessarily.
+ -}
+newtype TestableFilePath = TestableFilePath
+ { fromTestableFilePath :: FilePath }
+ deriving (Show)
+
+instance Arbitrary TestableFilePath where
+ arbitrary = (TestableFilePath . fromTestableString <$> arbitrary)
+ `suchThat` (not . null . fromTestableFilePath)
+ `suchThat` (not . any (== '\NUL') . fromTestableFilePath)
+
{- Times before the epoch are excluded. Half with decimal and half without. -}
instance Arbitrary POSIXTime where
arbitrary = do
diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs
new file mode 100644
index 0000000..b39423d
--- /dev/null
+++ b/Utility/RawFilePath.hs
@@ -0,0 +1,125 @@
+{- Portability shim for basic operations on RawFilePaths.
+ -
+ - On unix, this makes syscalls using RawFilesPaths as efficiently as
+ - possible.
+ -
+ - On Windows, filenames are in unicode, so RawFilePaths have to be
+ - decoded. So this library will work, but less efficiently than using
+ - FilePath would. However, this library also takes care to support long
+ - filenames on Windows, by either using other libraries that do, or by
+ - doing UNC-style conversion itself.
+ -
+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.RawFilePath (
+ RawFilePath,
+ readSymbolicLink,
+ createSymbolicLink,
+ createLink,
+ removeLink,
+ getFileStatus,
+ getSymbolicLinkStatus,
+ doesPathExist,
+ getCurrentDirectory,
+ createDirectory,
+ setFileMode,
+ setOwnerAndGroup,
+ rename,
+ createNamedPipe,
+ fileAccess,
+) where
+
+#ifndef mingw32_HOST_OS
+import Utility.FileSystemEncoding (RawFilePath)
+import System.Posix.Files.ByteString
+import qualified System.Posix.Directory.ByteString as D
+
+-- | Checks if a file or directory exists. Note that a dangling symlink
+-- will be false.
+doesPathExist :: RawFilePath -> IO Bool
+doesPathExist = fileExist
+
+getCurrentDirectory :: IO RawFilePath
+getCurrentDirectory = D.getWorkingDirectory
+
+createDirectory :: RawFilePath -> IO ()
+createDirectory p = D.createDirectory p 0o777
+
+#else
+import System.PosixCompat (FileStatus, FileMode)
+-- System.PosixCompat does not handle UNC-style conversion itself,
+-- so all uses of it library have to be pre-converted below. See
+-- https://github.com/jacobstanley/unix-compat/issues/56
+import qualified System.PosixCompat as P
+import qualified System.Directory as D
+import Utility.FileSystemEncoding
+import Utility.Path.Windows
+
+readSymbolicLink :: RawFilePath -> IO RawFilePath
+readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f)
+
+createSymbolicLink :: RawFilePath -> RawFilePath -> IO ()
+createSymbolicLink a b = do
+ a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a
+ b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b
+ P.createSymbolicLink a' b'
+
+createLink :: RawFilePath -> RawFilePath -> IO ()
+createLink a b = do
+ a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a
+ b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b
+ P.createLink a' b'
+
+{- On windows, removeLink is not available, so only remove files,
+ - not symbolic links. -}
+removeLink :: RawFilePath -> IO ()
+removeLink = D.removeFile . fromRawFilePath
+
+getFileStatus :: RawFilePath -> IO FileStatus
+getFileStatus p = P.getFileStatus . fromRawFilePath
+ =<< convertToWindowsNativeNamespace p
+
+getSymbolicLinkStatus :: RawFilePath -> IO FileStatus
+getSymbolicLinkStatus p = P.getSymbolicLinkStatus . fromRawFilePath
+ =<< convertToWindowsNativeNamespace p
+
+doesPathExist :: RawFilePath -> IO Bool
+doesPathExist = D.doesPathExist . fromRawFilePath
+
+getCurrentDirectory :: IO RawFilePath
+getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory
+
+createDirectory :: RawFilePath -> IO ()
+createDirectory = D.createDirectory . fromRawFilePath
+
+setFileMode :: RawFilePath -> FileMode -> IO ()
+setFileMode p m = do
+ p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p
+ P.setFileMode p' m
+
+{- Using renamePath rather than the rename provided in unix-compat
+ - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-}
+rename :: RawFilePath -> RawFilePath -> IO ()
+rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b)
+
+setOwnerAndGroup :: RawFilePath -> P.UserID -> P.GroupID -> IO ()
+setOwnerAndGroup p u g = do
+ p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p
+ P.setOwnerAndGroup p' u g
+
+createNamedPipe :: RawFilePath -> FileMode -> IO ()
+createNamedPipe p m = do
+ p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p
+ P.createNamedPipe p' m
+
+fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool
+fileAccess p a b c = do
+ p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p
+ P.fileAccess p' a b c
+#endif
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index c6881b7..e377eb9 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -114,7 +114,7 @@ rsyncUrlIsPath s
-}
rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool
rsyncProgress oh meter ps =
- commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case
+ commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case
Just ExitSuccess -> return True
Just (ExitFailure exitcode) -> do
when (exitcode /= 1) $
@@ -136,10 +136,10 @@ rsyncProgress oh meter ps =
parseRsyncProgress :: ProgressParser
parseRsyncProgress = go [] . reverse . progresschunks
where
- go remainder [] = (Nothing, remainder)
+ go remainder [] = (Nothing, Nothing, remainder)
go remainder (x:xs) = case parsebytes (findbytesstart x) of
Nothing -> go (delim:x++remainder) xs
- Just b -> (Just (toBytesProcessed b), remainder)
+ Just b -> (Just (toBytesProcessed b), Nothing, remainder)
delim = '\r'
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index 19d5f20..6f9419c 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -16,18 +16,13 @@ module Utility.SafeCommand (
safeSystem,
safeSystem',
safeSystemEnv,
- shellWrap,
- shellEscape,
- shellUnEscape,
segmentXargsOrdered,
segmentXargsUnordered,
- prop_isomorphic_shellEscape,
- prop_isomorphic_shellEscape_multiword,
) where
-import System.Exit
import Utility.Process
-import Utility.Split
+
+import System.Exit
import System.FilePath
import Data.Char
import Data.List
@@ -61,6 +56,8 @@ toCommand' (File s) = s
-- | Run a system command, and returns True or False if it succeeded or failed.
--
+-- (Throws an exception if the command is not found.)
+--
-- 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
@@ -81,9 +78,9 @@ safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystem' command params id
safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode
-safeSystem' command params mkprocess = do
- (_, _, _, pid) <- createProcess p
- waitForProcess pid
+safeSystem' command params mkprocess =
+ withCreateProcess p $ \_ _ _ pid ->
+ waitForProcess pid
where
p = mkprocess $ proc command (toCommand params)
@@ -91,44 +88,6 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex
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.
-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.
-shellEscape :: String -> String
-shellEscape f = "'" ++ escaped ++ "'"
- where
- -- replace ' with '"'"'
- escaped = intercalate "'\"'\"'" $ splitc '\'' f
-
--- | Unescapes a set of shellEscaped words or filenames.
-shellUnEscape :: String -> [String]
-shellUnEscape [] = []
-shellUnEscape s = word : shellUnEscape rest
- where
- (word, rest) = findword "" s
- findword w [] = (w, "")
- findword w (c:cs)
- | c == ' ' = (w, cs)
- | c == '\'' = inquote c w cs
- | c == '"' = inquote c w cs
- | otherwise = findword (w++[c]) cs
- inquote _ w [] = (w, "")
- inquote q w (c:cs)
- | c == q = findword w cs
- | otherwise = inquote q (w++[c]) cs
-
--- | 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]]
diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs
new file mode 100644
index 0000000..d781386
--- /dev/null
+++ b/Utility/SafeOutput.hs
@@ -0,0 +1,36 @@
+{- Safe output to the terminal of possibly attacker-controlled strings,
+ - avoiding displaying control characters.
+ -
+ - Copyright 2023 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.SafeOutput (
+ safeOutput,
+ safeOutputChar,
+) where
+
+import Data.Char
+import qualified Data.ByteString as S
+
+class SafeOutputtable t where
+ safeOutput :: t -> t
+
+instance SafeOutputtable String where
+ safeOutput = filter safeOutputChar
+
+instance SafeOutputtable S.ByteString where
+ safeOutput = S.filter (safeOutputChar . chr . fromIntegral)
+
+safeOutputChar :: Char -> Bool
+safeOutputChar c
+ | not (isControl c) = True
+ | c == '\n' = True
+ | c == '\t' = True
+ | c == '\DEL' = False
+ | ord c > 31 = True
+ | otherwise = False
diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs
new file mode 100644
index 0000000..acd2439
--- /dev/null
+++ b/Utility/SimpleProtocol.hs
@@ -0,0 +1,151 @@
+{- Simple line-based protocols.
+ -
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utility.SimpleProtocol (
+ Sendable(..),
+ Receivable(..),
+ parseMessage,
+ Serializable(..),
+ Parser,
+ parseFail,
+ parse0,
+ parse1,
+ parse2,
+ parse3,
+ parse4,
+ parse5,
+ dupIoHandles,
+ getProtocolLine,
+) where
+
+import Data.Char
+import GHC.IO.Handle
+import Text.Read
+
+import Common
+
+-- Messages that can be sent.
+class Sendable m where
+ formatMessage :: m -> [String]
+
+-- Messages that can be received.
+class Receivable m where
+ -- Passed the first word of the message, returns
+ -- a Parser that can be be fed the rest of the message to generate
+ -- the value.
+ parseCommand :: String -> Parser m
+
+parseMessage :: (Receivable m) => String -> Maybe m
+parseMessage s = parseCommand command rest
+ where
+ (command, rest) = splitWord s
+
+class Serializable a where
+ serialize :: a -> String
+ deserialize :: String -> Maybe a
+
+instance Serializable [Char] where
+ serialize = id
+ deserialize = Just
+
+instance Serializable Integer where
+ serialize = show
+ deserialize = readMaybe
+
+instance Serializable ExitCode where
+ serialize ExitSuccess = "0"
+ serialize (ExitFailure n) = show n
+ deserialize "0" = Just ExitSuccess
+ deserialize s = ExitFailure <$> readMaybe s
+
+{- Parsing the parameters of messages. Using the right parseN ensures
+ - that the string is split into exactly the requested number of words,
+ - which allows the last parameter of a message to contain arbitrary
+ - whitespace, etc, without needing any special quoting.
+ -}
+type Parser a = String -> Maybe a
+
+parseFail :: Parser a
+parseFail _ = Nothing
+
+parse0 :: a -> Parser a
+parse0 mk "" = Just mk
+parse0 _ _ = Nothing
+
+parse1 :: Serializable p1 => (p1 -> a) -> Parser a
+parse1 mk p1 = mk <$> deserialize p1
+
+parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a
+parse2 mk s = mk <$> deserialize p1 <*> deserialize p2
+ where
+ (p1, p2) = splitWord s
+
+parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a
+parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
+ where
+ (p1, rest) = splitWord s
+ (p2, p3) = splitWord rest
+
+parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a
+parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4
+ where
+ (p1, rest) = splitWord s
+ (p2, rest') = splitWord rest
+ (p3, p4) = splitWord rest'
+
+parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a
+parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5
+ where
+ (p1, rest) = splitWord s
+ (p2, rest') = splitWord rest
+ (p3, rest'') = splitWord rest'
+ (p4, p5) = splitWord rest''
+
+splitWord :: String -> (String, String)
+splitWord = separate isSpace
+
+{- When a program speaks a simple protocol over stdio, any other output
+ - to stdout (or anything that attempts to read from stdin)
+ - will mess up the protocol. To avoid that, close stdin,
+ - and duplicate stderr to stdout. Return two new handles
+ - that are duplicates of the original (stdin, stdout). -}
+dupIoHandles :: IO (Handle, Handle)
+dupIoHandles = do
+ readh <- hDuplicate stdin
+ writeh <- hDuplicate stdout
+ nullh <- openFile devNull ReadMode
+ nullh `hDuplicateTo` stdin
+ stderr `hDuplicateTo` stdout
+ return (readh, writeh)
+
+{- Reads a line, but to avoid super-long lines eating memory, returns
+ - Nothing if 32 kb have been read without seeing a '\n'
+ -
+ - If there is a '\r' before the '\n', it is removed, to support
+ - systems using "\r\n" at ends of lines
+ -
+ - This implementation is not super efficient, but as long as the Handle
+ - supports buffering, it avoids reading a character at a time at the
+ - syscall level.
+ -
+ - Throws isEOFError when no more input is available.
+ -}
+getProtocolLine :: Handle -> IO (Maybe String)
+getProtocolLine h = go (32768 :: Int) []
+ where
+ go 0 _ = return Nothing
+ go n l = do
+ c <- hGetChar h
+ if c == '\n'
+ then return $ Just $ reverse $
+ case l of
+ ('\r':rest) -> rest
+ _ -> l
+ else go (n-1) (c:l)
diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs
index b9040fe..a7d60f9 100644
--- a/Utility/SystemDirectory.hs
+++ b/Utility/SystemDirectory.hs
@@ -1,4 +1,4 @@
-{- System.Directory without its conflicting isSymbolicLink
+{- System.Directory without its conflicting isSymbolicLink and getFileSize.
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index ef69ead..9ab94d9 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -15,6 +15,7 @@ module Utility.ThreadScheduler (
threadDelaySeconds,
waitForTermination,
oneSecond,
+ unboundDelay,
) where
import Control.Monad
diff --git a/Utility/TimeStamp.hs b/Utility/TimeStamp.hs
new file mode 100644
index 0000000..b740d7b
--- /dev/null
+++ b/Utility/TimeStamp.hs
@@ -0,0 +1,58 @@
+{- timestamp parsing and formatting
+ -
+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.TimeStamp (
+ parserPOSIXTime,
+ parsePOSIXTime,
+ formatPOSIXTime,
+) where
+
+import Utility.Data
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import Data.Ratio
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Attoparsec.ByteString as A
+import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8)
+
+{- Parses how POSIXTime shows itself: "1431286201.113452s"
+ - (The "s" is included for historical reasons and is optional.)
+ - Also handles the format with no decimal seconds. -}
+parserPOSIXTime :: A.Parser POSIXTime
+parserPOSIXTime = mkPOSIXTime
+ <$> signed decimal
+ <*> (declen <|> pure (0, 0))
+ <* optional (char 's')
+ where
+ declen :: A.Parser (Integer, Int)
+ declen = do
+ _ <- char '.'
+ b <- A.takeWhile isDigit_w8
+ let len = B.length b
+ d <- either fail pure $
+ A.parseOnly (decimal <* A.endOfInput) b
+ return (d, len)
+
+parsePOSIXTime :: String -> Maybe POSIXTime
+parsePOSIXTime s = eitherToMaybe $
+ A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s)
+
+{- This implementation allows for higher precision in a POSIXTime than
+ - supported by the system's Double, and avoids the complications of
+ - floating point. -}
+mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime
+mkPOSIXTime n (d, dlen)
+ | n < 0 = fromIntegral n - fromRational r
+ | otherwise = fromIntegral n + fromRational r
+ where
+ r = d % (10 ^ dlen)
+
+formatPOSIXTime :: String -> POSIXTime -> String
+formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 6ee592b..efb15bd 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,6 +1,6 @@
{- Temporary files.
-
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -14,22 +14,42 @@ module Utility.Tmp (
withTmpFile,
withTmpFileIn,
relatedTemplate,
+ openTmpFileIn,
) where
import System.IO
import System.FilePath
import System.Directory
import Control.Monad.IO.Class
-import System.PosixCompat.Files
+import System.IO.Error
import Utility.Exception
import Utility.FileSystemEncoding
+import Utility.FileMode
+import qualified Utility.RawFilePath as R
type Template = String
+{- This is the same as openTempFile, except when there is an
+ - error, it displays the template as well as the directory,
+ - to help identify what call was responsible.
+ -}
+openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle)
+openTmpFileIn dir template = openTempFile dir template
+ `catchIO` decoraterrror
+ where
+ decoraterrror e = throwM $
+ let loc = ioeGetLocation e ++ " template " ++ template
+ in annotateIOError e loc Nothing Nothing
+
{- 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. -}
+ - directory as the final file to avoid cross-device renames.
+ -
+ - While this uses a temp file, the file will end up with the same
+ - mode as it would when using writeFile, unless the writer action changes
+ - it.
+ -}
viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m ()
viaTmp a file content = bracketIO setup cleanup use
where
@@ -37,14 +57,20 @@ viaTmp a file content = bracketIO setup cleanup use
template = relatedTemplate (base ++ ".tmp")
setup = do
createDirectoryIfMissing True dir
- openTempFile dir template
+ openTmpFileIn dir template
cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h
tryIO $ removeFile tmpfile
use (tmpfile, h) = do
+ let tmpfile' = toRawFilePath tmpfile
+ -- Make mode the same as if the file were created usually,
+ -- not as a temp file. (This may fail on some filesystems
+ -- that don't support file modes well, so ignore
+ -- exceptions.)
+ _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode
liftIO $ hClose h
a tmpfile content
- liftIO $ rename tmpfile file
+ liftIO $ R.rename tmpfile' (toRawFilePath 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. -}
@@ -54,11 +80,15 @@ withTmpFile template a = do
withTmpFileIn tmpdir template a
{- Runs an action with a tmp file located in the specified directory,
- - then removes the file. -}
+ - then removes the file.
+ -
+ - Note that the tmp file will have a file mode that only allows the
+ - current user to access it.
+ -}
withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
withTmpFileIn tmpdir template a = bracket create remove use
where
- create = liftIO $ openTempFile tmpdir template
+ create = liftIO $ openTmpFileIn tmpdir template
remove (name, h) = liftIO $ do
hClose h
catchBoolIO (removeFile name >> return True)
diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs
index c68ef86..904b65a 100644
--- a/Utility/Tmp/Dir.hs
+++ b/Utility/Tmp/Dir.hs
@@ -1,6 +1,6 @@
{- Temporary directories
-
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -63,8 +63,10 @@ removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
-- 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
+ _ <- tryIO $ go tmpdir
return ()
#else
- removeDirectoryRecursive tmpdir
+ go tmpdir
#endif
+ where
+ go = removeDirectoryRecursive
diff --git a/Utility/Url/Parse.hs b/Utility/Url/Parse.hs
new file mode 100644
index 0000000..7fc952b
--- /dev/null
+++ b/Utility/Url/Parse.hs
@@ -0,0 +1,63 @@
+{- Url parsing.
+ -
+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+
+module Utility.Url.Parse (
+ parseURIPortable,
+ parseURIRelaxed,
+) where
+
+import Network.URI
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Windows as PW
+#endif
+
+{- On unix this is the same as parseURI. But on Windows,
+ - it can parse urls such as file:///C:/path/to/file
+ - parseURI normally parses that as a path /C:/path/to/file
+ - and this simply removes the excess leading slash when there is a
+ - drive letter after it. -}
+parseURIPortable :: String -> Maybe URI
+#ifndef mingw32_HOST_OS
+parseURIPortable = parseURI
+#else
+parseURIPortable s
+ | "file:" `isPrefixOf` s = do
+ u <- parseURI s
+ return $ case PW.splitDirectories (uriPath u) of
+ (p:d:_) | all PW.isPathSeparator p && PW.isDrive d ->
+ u { uriPath = dropWhile PW.isPathSeparator (uriPath u) }
+ _ -> u
+ | otherwise = parseURI s
+#endif
+
+{- Allows for spaces and other stuff in urls, properly escaping them. -}
+parseURIRelaxed :: String -> Maybe URI
+parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $
+ parseURIPortable $ escapeURIString isAllowedInURI s
+
+{- Some characters like '[' are allowed in eg, the address of
+ - an uri, but cannot appear unescaped further along in the uri.
+ - This handles that, expensively, by successively escaping each character
+ - from the back of the url until the url parses.
+ -}
+parseURIRelaxed' :: String -> Maybe URI
+parseURIRelaxed' s = go [] (reverse s)
+ where
+ go back [] = parseURI back
+ go back (c:cs) = case parseURI (escapeURIString isAllowedInURI (reverse (c:cs)) ++ back) of
+ Just u -> Just u
+ Nothing -> go (escapeURIChar escapemore c ++ back) cs
+
+ escapemore '[' = False
+ escapemore ']' = False
+ escapemore c = isAllowedInURI c
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 17ce8db..827229d 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -19,31 +19,32 @@ import Utility.Exception
#ifndef mingw32_HOST_OS
import Utility.Data
import Control.Applicative
+import System.Posix.User
+#if MIN_VERSION_unix(2,8,0)
+import System.Posix.User.ByteString (UserEntry)
+#endif
#endif
-import System.PosixCompat
import Prelude
{- Current user's home directory.
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
-myHomeDir = either giveup return =<< myVal env homeDirectory
- where
+myHomeDir = either giveup return =<<
#ifndef mingw32_HOST_OS
- env = ["HOME"]
+ myVal ["HOME"] homeDirectory
#else
- env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
+ myVal ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
#endif
{- Current user's user name. -}
myUserName :: IO (Either String String)
-myUserName = myVal env userName
- where
+myUserName =
#ifndef mingw32_HOST_OS
- env = ["USER", "LOGNAME"]
+ myVal ["USER", "LOGNAME"] userName
#else
- env = ["USERNAME", "USER", "LOGNAME"]
+ myVal ["USERNAME", "USER", "LOGNAME"]
#endif
myUserGecos :: IO (Maybe String)
@@ -54,16 +55,20 @@ myUserGecos = return Nothing
myUserGecos = eitherToMaybe <$> myVal [] userGecos
#endif
+#ifndef mingw32_HOST_OS
myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)
myVal envvars extract = go envvars
where
go [] = either (const $ envnotset) (Right . extract) <$> get
go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
-#ifndef mingw32_HOST_OS
-- This may throw an exception if the system doesn't have a
-- passwd file etc; don't let it crash.
get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID
#else
- get = return envnotset
+myVal :: [String] -> IO (Either String String)
+myVal envvars = go envvars
+ where
+ go [] = return envnotset
+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
#endif
envnotset = Left ("environment not set: " ++ show envvars)
diff --git a/debian/changelog b/debian/changelog
index d51fac3..7cba8fa 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-repair (1.20230814-1) unstable; urgency=medium
+
+ * New upstream release (Closes: #1054816).
+
+ -- Sean Whitton <spwhitton@spwhitton.name> Tue, 19 Mar 2024 19:48:32 +0800
+
git-repair (1.20200102-2) unstable; urgency=medium
* Patch Utility/HumanTime.hs to update type constraint Monad -> MonadFail
diff --git a/doc/index.mdwn b/doc/index.mdwn
index 503c2c2..9ff06de 100644
--- a/doc/index.mdwn
+++ b/doc/index.mdwn
@@ -27,7 +27,7 @@ Then to install it:
## how it works
`git-repair` starts by deleting all corrupt objects, and
-retreiving all missing objects that it can from the remotes of the
+retrieving all missing objects that it can from the remotes of the
repository.
If that is not sufficient to fully recover the repository, it can also
diff --git a/doc/index/discussion.mdwn b/doc/index/discussion.mdwn
index dea2ec7..c656c35 100644
--- a/doc/index/discussion.mdwn
+++ b/doc/index/discussion.mdwn
@@ -1,12 +1,27 @@
-My experience with git repair:
+# Experience n°1
-git repair
-Running git fsck ...
-Stack space overflow: current size 8388608 bytes.
-Use `+RTS -Ksize -RTS' to increase it.
+ % git repair
+ Running git fsck ...
+ Stack space overflow: current size 8388608 bytes.
+ Use `+RTS -Ksize -RTS' to increase it.
-git repair +RTS -K32M -RTS
-git-repair: Most RTS options are disabled. Link with -rtsopts to enable them.
+ % git repair +RTS -K32M -RTS
+ git-repair: Most RTS options are disabled. Link with -rtsopts to enable them.
Whats up guys? Are we playing catch 22 here?
+# Experience n°2
+
+I've been running
+
+ LANG=C TMPDIR=/mnt/1/tmp TMP=/mnt/1/tmp git-repair --force
+
+on a BUP repository for more than a wekk. The output so far looks like:
+
+ Initialized empty Git repository in /mnt/1/tmp/tmprepo8ymhUQ/.git/
+ fatal: /mnt/1/monnier-broken.bup: '/mnt/1/monnier-broken.bup' is outside repository at '/mnt/1/monnier-broken.bup'
+ Initialized empty Git repository in /mnt/1/tmp/tmprepoz8b3XR/.git/
+ fatal: /mnt/1/monnier-broken.bup: '/mnt/1/monnier-broken.bup' is outside repository at '/mnt/1/monnier-broken.bup'
+ [...]
+
+where those two lines repeat every few hours. Should I assume it's stuck in some kind of inf-loop, or will it actually end at some point?
diff --git a/doc/news/version_1.20141027.mdwn b/doc/news/version_1.20141027.mdwn
deleted file mode 100644
index b65c652..0000000
--- a/doc/news/version_1.20141027.mdwn
+++ /dev/null
@@ -1 +0,0 @@
-git-repair 1.20140613 released
diff --git a/doc/news/version_1.20151215.mdwn b/doc/news/version_1.20151215.mdwn
deleted file mode 100644
index 79b16f1..0000000
--- a/doc/news/version_1.20151215.mdwn
+++ /dev/null
@@ -1,5 +0,0 @@
-git-repair 1.20151215 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Fix insecure temporary permissions and potential denial of
- service attack when creating temp dirs. Closes: #[807341](http://bugs.debian.org/807341)
- * Merge from git-annex."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20161111.mdwn b/doc/news/version_1.20161111.mdwn
deleted file mode 100644
index baba58b..0000000
--- a/doc/news/version_1.20161111.mdwn
+++ /dev/null
@@ -1,10 +0,0 @@
-git-repair 1.20161111 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * git-repair.cabal: Add Setup-Depends.
- * Updated cabal file explictly lists source files. The tarball
- on hackage will include only the files needed for cabal install;
- it is NOT the full git-repair source tree.
- * debian/changelog: Converted to symlinks to CHANGELOG.
- * Merge from git-annex.
- * Makefile: Support building with stack as well as cabal.
- * Makefile: The CABAL variable has been renamed to BUILDER."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20161118.mdwn b/doc/news/version_1.20161118.mdwn
deleted file mode 100644
index c687f46..0000000
--- a/doc/news/version_1.20161118.mdwn
+++ /dev/null
@@ -1,3 +0,0 @@
-git-repair 1.20161118 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Fix build with recent versions of cabal and ghc."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20170626.mdwn b/doc/news/version_1.20170626.mdwn
deleted file mode 100644
index 9e9830a..0000000
--- a/doc/news/version_1.20170626.mdwn
+++ /dev/null
@@ -1,5 +0,0 @@
-git-repair 1.20170626 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Merge from git-annex.
- * Removes dependency on MissingH, adding a dependency on split instead.
- * Fixes build with directory-1.3."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20200504.mdwn b/doc/news/version_1.20200504.mdwn
new file mode 100644
index 0000000..545cd64
--- /dev/null
+++ b/doc/news/version_1.20200504.mdwn
@@ -0,0 +1,5 @@
+git-repair 1.20200504 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * Fix a few documentation typos.
+ * Improve fetching from a remote with an url in host:path format.
+ * Merge from git-annex."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20210111.mdwn b/doc/news/version_1.20210111.mdwn
new file mode 100644
index 0000000..d32b1c8
--- /dev/null
+++ b/doc/news/version_1.20210111.mdwn
@@ -0,0 +1,5 @@
+git-repair 1.20210111 released with [[!toggle text="these changes"]]
+[[!toggleable text=""" * Improve output to not give the impression it's stalled running fsck
+ when it's found a problem and is working to repair it.
+ * Merge from git-annex.
+ * Makefile: Support building with cabal 3.0."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20210629.mdwn b/doc/news/version_1.20210629.mdwn
new file mode 100644
index 0000000..9f00951
--- /dev/null
+++ b/doc/news/version_1.20210629.mdwn
@@ -0,0 +1,5 @@
+git-repair 1.20210629 released with [[!toggle text="these changes"]]
+[[!toggleable text=""" * Fixed bug that interrupting the program while it was fixing repository
+ corruption would lose objects that were contained in pack files.
+ * Fix reversion in version 1.20200504 that prevented fetching
+ missing objects from remotes."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20220404.mdwn b/doc/news/version_1.20220404.mdwn
new file mode 100644
index 0000000..448e807
--- /dev/null
+++ b/doc/news/version_1.20220404.mdwn
@@ -0,0 +1,3 @@
+git-repair 1.20220404 released with [[!toggle text="these changes"]]
+[[!toggleable text=""" * Avoid treating refs that are not commit objects as evidence of
+ repository corruption."""]] \ No newline at end of file
diff --git a/doc/news/version_1.20230814.mdwn b/doc/news/version_1.20230814.mdwn
new file mode 100644
index 0000000..e496f83
--- /dev/null
+++ b/doc/news/version_1.20230814.mdwn
@@ -0,0 +1,3 @@
+git-repair 1.20230814 released with [[!toggle text="these changes"]]
+[[!toggleable text=""" * Merge from git-annex.
+ * Support building with unix-compat 0.7"""]] \ No newline at end of file
diff --git a/git-repair.1 b/git-repair.1
index 7780095..8b72d1f 100644
--- a/git-repair.1
+++ b/git-repair.1
@@ -9,7 +9,7 @@ git\-repair [\-\-force]
This can fix a corrupt or broken git repository, which git fsck would
only complain has problems.
.PP
-It does by deleting all corrupt objects, and retreiving all missing
+It does by deleting all corrupt objects, and retrieving all missing
objects that it can from the remotes of the repository.
.PP
If that is not sufficient to fully recover the repository, it can also
diff --git a/git-repair.cabal b/git-repair.cabal
index f273cb3..7cf0aad 100644
--- a/git-repair.cabal
+++ b/git-repair.cabal
@@ -1,16 +1,16 @@
Name: git-repair
-Version: 1.20200102
-Cabal-Version: >= 1.8
+Version: 1.20230814
+Cabal-Version: >= 1.10
License: AGPL-3
Maintainer: Joey Hess <joey@kitenet.net>
Author: Joey Hess
Stability: Stable
-Copyright: 2013 Joey Hess
+Copyright: 2013-2022 Joey Hess
License-File: COPYRIGHT
Build-Type: Custom
Homepage: http://git-repair.branchable.com/
Category: Utility
-Synopsis: repairs a damanged git repisitory
+Synopsis: repairs a damaged git repository
Description:
git-repair can repair various forms of damage to git repositories.
.
@@ -28,8 +28,9 @@ Extra-Source-Files:
custom-setup
Setup-Depends: base (>= 4.11.1.0 && < 5.0),
hslogger, split, unix-compat, process, unix, filepath,
+ filepath-bytestring (>= 1.4.2.1.4), async,
exceptions, bytestring, directory, IfElse, data-default,
- mtl, Cabal
+ mtl, Cabal (< 4.0), time
source-repository head
type: git
@@ -37,15 +38,17 @@ source-repository head
Executable git-repair
Main-Is: git-repair.hs
- GHC-Options: -threaded -Wall -fno-warn-tabs
- Extensions: LambdaCase
+ GHC-Options: -threaded -Wall -fno-warn-tabs -Wincomplete-uni-patterns -O2
+ Default-Language: Haskell2010
+ Default-Extensions: LambdaCase
Build-Depends: split, hslogger, directory, filepath, containers, mtl,
unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers,
base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck,
utf8-string, async, optparse-applicative (>= 0.14.1),
data-default, deepseq, attoparsec,
network-uri (>= 2.6), network (>= 2.6),
- filepath-bytestring (>= 1.4.2.1.0)
+ filepath-bytestring (>= 1.4.2.1.4),
+ time
if (os(windows))
Build-Depends: setenv
@@ -56,7 +59,6 @@ Executable git-repair
BuildInfo
Build.Configure
Build.TestConfig
- Build.Version
Common
Git
Git.Branch
@@ -68,14 +70,15 @@ Executable git-repair
Git.CurrentRepo
Git.Destroyer
Git.DiffTreeItem
+ Git.Env
Git.FilePath
- Git.Filename
Git.Fsck
Git.HashObject
Git.Index
Git.LsFiles
Git.LsTree
Git.Objects
+ Git.Quote
Git.Ref
Git.RefLog
Git.Remote
@@ -89,9 +92,11 @@ Executable git-repair
Utility.Applicative
Utility.Batch
Utility.CoProcess
+ Utility.Debug
Utility.Data
Utility.DataUnits
Utility.Directory
+ Utility.Directory.Create
Utility.DottedVersion
Utility.Env
Utility.Env.Basic
@@ -103,21 +108,30 @@ Executable git-repair
Utility.Format
Utility.HumanNumber
Utility.HumanTime
+ Utility.InodeCache
Utility.Metered
Utility.Misc
Utility.Monad
+ Utility.MoveFile
Utility.PartialPrelude
Utility.Path
+ Utility.Path.AbsRel
Utility.Percentage
Utility.Process
Utility.Process.Shim
+ Utility.Process.Transcript
Utility.QuickCheck
+ Utility.RawFilePath
Utility.Rsync
Utility.SafeCommand
+ Utility.SafeOutput
+ Utility.SimpleProtocol
Utility.Split
Utility.SystemDirectory
Utility.ThreadScheduler
+ Utility.TimeStamp
Utility.Tmp
Utility.Tmp.Dir
Utility.Tuple
Utility.UserInfo
+ Utility.Url.Parse
diff --git a/git-repair.hs b/git-repair.hs
index ce4d16a..18721a9 100644
--- a/git-repair.hs
+++ b/git-repair.hs
@@ -93,14 +93,14 @@ runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do
]
unless cloned $
error $ "failed to clone this repo"
- g <- Git.Config.read =<< Git.Construct.fromPath cloneloc
+ g <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath cloneloc)
Git.Destroyer.applyDamage damage g
repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair
<$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g
case repairstatus of
Just True -> testResult repairstatus
. Just . not . Git.Fsck.foundBroken
- =<< Git.Fsck.findBroken False g
+ =<< Git.Fsck.findBroken False False g
_ -> testResult repairstatus Nothing
-- Pass test result and fsck result