summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2016-11-11 15:01:13 -0400
committerJoey Hess <joeyh@joeyh.name>2016-11-11 15:01:13 -0400
commit962e279e17c1f3cf3be49ffdfb5e7310711a220c (patch)
treed9953d9e57dea51c24ccaf4d7e64731010546f4f
parent7d7f93302c72cbe1a16598b0c90a49c10aaf3669 (diff)
downloadgit-repair-962e279e17c1f3cf3be49ffdfb5e7310711a220c.tar.gz
merge from git-annex
-rw-r--r--CHANGELOG5
-rw-r--r--Git.hs13
-rw-r--r--Git/Branch.hs82
-rw-r--r--Git/CatFile.hs130
-rw-r--r--Git/Command.hs6
-rw-r--r--Git/Construct.hs1
-rw-r--r--Git/FilePath.hs17
-rw-r--r--Git/Fsck.hs67
-rw-r--r--Git/Index.hs21
-rw-r--r--Git/LsTree.hs33
-rw-r--r--Git/Ref.hs18
-rw-r--r--Git/Repair.hs4
-rw-r--r--Git/Types.hs23
-rw-r--r--Utility/CoProcess.hs22
-rw-r--r--Utility/Exception.hs18
-rw-r--r--Utility/FileMode.hs3
-rw-r--r--Utility/FileSize.hs6
-rw-r--r--Utility/FileSystemEncoding.hs8
-rw-r--r--Utility/Format.hs8
-rw-r--r--Utility/Metered.hs25
-rw-r--r--Utility/Path.hs22
-rw-r--r--Utility/PosixFiles.hs10
-rw-r--r--Utility/Process.hs12
-rw-r--r--Utility/QuickCheck.hs10
-rw-r--r--Utility/Rsync.hs6
-rw-r--r--Utility/Tmp.hs2
-rw-r--r--Utility/UserInfo.hs17
27 files changed, 431 insertions, 158 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 94f0743..c57824c 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,12 +1,13 @@
-git-repair (1.20151216) UNRELEASED; urgency=medium
+git-repair (1.20161111) unstable; urgency=medium
* 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.
- -- Joey Hess <id@joeyh.name> Wed, 04 May 2016 12:16:33 -0400
+ -- Joey Hess <id@joeyh.name> Fri, 11 Nov 2016 14:56:14 -0400
git-repair (1.20151215) unstable; urgency=medium
diff --git a/Git.hs b/Git.hs
index 1bc789f..b350515 100644
--- a/Git.hs
+++ b/Git.hs
@@ -26,8 +26,10 @@ module Git (
repoDescribe,
repoLocation,
repoPath,
+ repoWorkTree,
localGitDir,
attributes,
+ attributesLocal,
hookPath,
assertLocal,
adjustPath,
@@ -72,6 +74,10 @@ repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
repoPath Repo { location = Unknown } = error "unknown repoPath"
+repoWorkTree :: Repo -> Maybe FilePath
+repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
+repoWorkTree _ = Nothing
+
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> FilePath
localGitDir Repo { location = Local { gitdir = d } } = d
@@ -125,8 +131,11 @@ assertLocal repo action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
- | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
- | otherwise = repoPath repo ++ "/.gitattributes"
+ | repoIsLocalBare repo = attributesLocal repo
+ | otherwise = repoPath repo </> ".gitattributes"
+
+attributesLocal :: Repo -> FilePath
+attributesLocal repo = localGitDir repo </> "info" </> "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}
diff --git a/Git/Branch.hs b/Git/Branch.hs
index a2225dc..875f20f 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -13,6 +13,7 @@ import Common
import Git
import Git.Sha
import Git.Command
+import qualified Git.Config
import qualified Git.Ref
import qualified Git.BuildVersion
@@ -23,7 +24,7 @@ import qualified Git.BuildVersion
- branch is not created yet. So, this also looks at show-ref HEAD
- to double-check.
-}
-current :: Repo -> IO (Maybe Git.Ref)
+current :: Repo -> IO (Maybe Branch)
current r = do
v <- currentUnsafe r
case v of
@@ -35,7 +36,7 @@ current r = do
)
{- The current branch, which may not really exist yet. -}
-currentUnsafe :: Repo -> IO (Maybe Git.Ref)
+currentUnsafe :: Repo -> IO (Maybe Branch)
currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where
@@ -48,15 +49,25 @@ currentUnsafe r = parse . firstLine
changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
- | otherwise = not . null <$> diffs
+ | otherwise = not . null
+ <$> changed' origbranch newbranch [Param "-n1"] repo
where
- diffs = pipeReadStrict
+
+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
+ where
+ ps =
[ Param "log"
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
- , Param "-n1"
, Param "--pretty=%H"
- ] repo
-
+ ] ++ extraps
+
+{- 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
+ <$> changed' origbranch newbranch extraps repo
+
{- Check if it's possible to fast-forward from the old
- ref to the new ref.
-
@@ -90,7 +101,7 @@ fastForward branch (first:rest) repo =
where
no_ff = return False
do_ff to = do
- update branch to repo
+ update' branch to repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@@ -104,27 +115,37 @@ fastForward branch (first:rest) repo =
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
-{- The user may have set commit.gpgsign, indending all their manual
+{- 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.
-}
data CommitMode = ManualCommit | AutomaticCommit
deriving (Eq)
+{- Prevent signing automatic commits. -}
applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
applyCommitMode commitmode ps
| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =
Param "--no-gpg-sign" : ps
| otherwise = ps
+{- Some versions of git commit-tree honor commit.gpgsign themselves,
+ - but others need -S to be passed to enable gpg signing of manual commits. -}
+applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]
+applyCommitModeForCommitTree commitmode ps r
+ | commitmode == ManualCommit =
+ case (Git.Config.getMaybe "commit.gpgsign" r) of
+ Just s | Git.Config.isTrue s == Just True ->
+ Param "-S":ps
+ _ -> ps'
+ | otherwise = ps'
+ where
+ ps' = applyCommitMode commitmode ps
+
{- Commit via the usual git command. -}
commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
commitCommand = commitCommand' runBool
-{- Commit will fail when the tree is clean. This suppresses that error. -}
-commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()
-commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps
-
commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
commitCommand' runner commitmode ps = runner $
Param "commit" : applyCommitMode commitmode ps
@@ -144,36 +165,51 @@ commit commitmode allowempty message branch parentrefs repo = do
pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree)
( do
- sha <- getSha "commit-tree" $
- pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
- update branch sha repo
+ sha <- commitTree commitmode message parentrefs tree repo
+ update' branch sha repo
return $ Just sha
, return Nothing
)
where
- ps = applyCommitMode commitmode $
- map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree
| allowempty = return True
| otherwise = case parentrefs of
[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
_ -> return True
- sendmsg = Just $ flip hPutStr message
commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
commitAlways commitmode message branch parentrefs repo = fromJust
<$> commit commitmode True message branch parentrefs repo
+commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
+commitTree commitmode message parentrefs tree repo =
+ getSha "commit-tree" $
+ pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps)
+ sendmsg repo
+ where
+ sendmsg = Just $ flip hPutStr message
+ ps = applyCommitModeForCommitTree commitmode parentparams repo
+ parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
+
{- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String
forcePush b = "+" ++ b
-{- Updates a branch (or other ref) to a new Sha. -}
-update :: Branch -> Sha -> Repo -> IO ()
-update branch sha = run
+{- Updates a branch (or other ref) to a new Sha or branch Ref. -}
+update :: String -> Branch -> Ref -> Repo -> IO ()
+update message branch r = run
+ [ Param "update-ref"
+ , Param "-m"
+ , Param message
+ , Param $ fromRef branch
+ , Param $ fromRef r
+ ]
+
+update' :: Branch -> Ref -> Repo -> IO ()
+update' branch r = run
[ Param "update-ref"
, Param $ fromRef branch
- , Param $ fromRef sha
+ , Param $ fromRef r
]
{- Checks out a branch, creating it if necessary. -}
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index c63a064..061349f 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,6 +1,6 @@
{- git cat-file interface
-
- - Copyright 2011, 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -13,13 +13,19 @@ module Git.CatFile (
catFile,
catFileDetails,
catTree,
+ catCommit,
catObject,
catObjectDetails,
+ catObjectMetaData,
) 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 Data.String
+import Data.Char
import Data.Tuple.Utils
import Numeric
import System.Posix.Types
@@ -32,21 +38,28 @@ import Git.Types
import Git.FilePath
import qualified Utility.CoProcess as CoProcess
-data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo
+data CatFileHandle = CatFileHandle
+ { catFileProcess :: CoProcess.CoProcessHandle
+ , checkFileProcess :: CoProcess.CoProcessHandle
+ }
catFileStart :: Repo -> IO CatFileHandle
catFileStart = catFileStart' True
catFileStart' :: Bool -> Repo -> IO CatFileHandle
-catFileStart' restartable repo = do
- coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable
+catFileStart' restartable repo = CatFileHandle
+ <$> startp "--batch"
+ <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"
+ where
+ startp p = gitCoProcessStart restartable
[ Param "cat-file"
- , Param "--batch"
+ , Param p
] repo
- return $ CatFileHandle coprocess repo
catFileStop :: CatFileHandle -> IO ()
-catFileStop (CatFileHandle p _) = CoProcess.stop p
+catFileStop h = do
+ CoProcess.stop (catFileProcess h)
+ CoProcess.stop (checkFileProcess h)
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
@@ -63,32 +76,52 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString
catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
-catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
+catObjectDetails h object = query (catFileProcess h) object $ \from -> do
+ header <- 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 DNE -> return Nothing
+ Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
where
- query = fromRef object
- send to = hPutStrLn to query
- receive from = do
- header <- hGetLine from
- case words header of
- [sha, objtype, size]
- | length sha == shaSize ->
- case (readObjectType objtype, reads size) of
- (Just t, [(bytes, "")]) -> readcontent t bytes from sha
- _ -> dne
- | otherwise -> dne
- _
- | header == fromRef object ++ " missing" -> dne
- | otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
- readcontent objtype bytes from sha = do
- content <- S.hGet from bytes
- eatchar '\n' from
- return $ Just (L.fromChunks [content], Ref sha, objtype)
- dne = return Nothing
eatchar expected from = do
c <- hGetChar from
when (c /= expected) $
error $ "missing " ++ (show expected) ++ " from git cat-file"
+{- Gets the size and type of an object, without reading its content. -}
+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType))
+catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do
+ resp <- hGetLine from
+ case parseResp object resp of
+ Just (ParsedResp _ size objtype) ->
+ return $ Just (size, objtype)
+ Just DNE -> return Nothing
+ Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)
+
+data ParsedResp = ParsedResp Sha Integer ObjectType | DNE
+
+query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a
+query hdl object receive = CoProcess.query hdl send receive
+ where
+ send to = hPutStrLn to (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 objtype, reads size) of
+ (Just t, [(bytes, "")]) ->
+ Just $ ParsedResp (Ref sha) bytes t
+ _ -> Nothing
+ | otherwise -> Nothing
+ _ -> Nothing
+
{- Gets a list of files and directories in a tree. (Not recursive.) -}
catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
catTree h treeref = go <$> catObjectDetails h treeref
@@ -104,10 +137,51 @@ catTree h treeref = go <$> catObjectDetails h treeref
(dropsha rest)
-- these 20 bytes after the NUL hold the file's sha
- -- TODO: convert from raw form to regular sha
dropsha = L.drop 21
parsemodefile b =
let (modestr, file) = separate (== ' ') (decodeBS b)
in (file, readmode modestr)
readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
+
+catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)
+catCommit h commitref = go <$> catObjectDetails h commitref
+ where
+ go (Just (b, _, CommitObject)) = parseCommit b
+ go _ = Nothing
+
+parseCommit :: L.ByteString -> Maybe Commit
+parseCommit b = Commit
+ <$> (extractSha . L8.unpack =<< field "tree")
+ <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))
+ <*> (parsemetadata <$> field "author")
+ <*> (parsemetadata <$> field "committer")
+ <*> Just (L8.unpack $ L.intercalate (L.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
+
+ -- 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
+ , commitEmail = whenset email
+ , commitDate = whenset $ L.drop 2 gt_sp_date
+ }
+ where
+ (name_sp, rest) = L.break (== lt) l
+ (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)
+ whenset v
+ | L.null v = Nothing
+ | otherwise = Just (L8.unpack v)
+
+ nl = fromIntegral (ord '\n')
+ sp = fromIntegral (ord ' ')
+ lt = fromIntegral (ord '<')
+ gt = fromIntegral (ord '>')
diff --git a/Git/Command.hs b/Git/Command.hs
index 02e3e5a..2060563 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -17,9 +17,11 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
- setdir : settree ++ gitGlobalOpts r ++ params
+ setdir ++ settree ++ gitGlobalOpts r ++ params
where
- setdir = Param $ "--git-dir=" ++ gitdir l
+ setdir
+ | gitEnvOverridesGitDir r = []
+ | otherwise = [Param $ "--git-dir=" ++ gitdir l]
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ t]
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 03dd29f..7655622 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -236,6 +236,7 @@ newFrom l = Repo
, remotes = []
, remoteName = Nothing
, gitEnv = Nothing
+ , gitEnvOverridesGitDir = False
, gitGlobalOpts = []
}
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index edc3c0f..ffa3331 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -14,8 +14,10 @@
module Git.FilePath (
TopFilePath,
- fromTopFilePath,
+ BranchFilePath(..),
+ descBranchFilePath,
getTopFilePath,
+ fromTopFilePath,
toTopFilePath,
asTopFilePath,
InternalGitPath,
@@ -31,11 +33,18 @@ import qualified System.FilePath.Posix
{- A FilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
- deriving (Show)
+ deriving (Show, Eq, Ord)
+
+{- A file in a branch or other treeish. -}
+data BranchFilePath = BranchFilePath Ref TopFilePath
+
+{- Git uses the branch:file form to refer to a BranchFilePath -}
+descBranchFilePath :: BranchFilePath -> String
+descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f
-{- Returns an absolute FilePath. -}
+{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
-fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)
+fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index f3e6db9..a716b56 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE BangPatterns #-}
+
module Git.Fsck (
FsckResults(..),
MissingObjects,
@@ -25,8 +27,6 @@ import qualified Git.Version
import qualified Data.Set as S
import Control.Concurrent.Async
-type MissingObjects = S.Set Sha
-
data FsckResults
= FsckFoundMissing
{ missingObjects :: MissingObjects
@@ -35,6 +35,25 @@ data FsckResults
| FsckFailed
deriving (Show)
+data FsckOutput
+ = FsckOutput MissingObjects Truncated
+ | NoFsckOutput
+ | AllDuplicateEntriesWarning
+
+type MissingObjects = S.Set Sha
+
+type Truncated = Bool
+
+instance Monoid FsckOutput where
+ mempty = NoFsckOutput
+ mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)
+ mappend (FsckOutput s t) _ = FsckOutput s t
+ mappend _ (FsckOutput s t) = FsckOutput s t
+ mappend NoFsckOutput NoFsckOutput = NoFsckOutput
+ mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+ mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
+ mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+
{- Runs fsck to find some of the broken objects in the repository.
- May not find all broken objects, if fsck fails on bad data in some of
- the broken objects it does find.
@@ -58,18 +77,24 @@ findBroken batchmode r = do
{ std_out = CreatePipe
, std_err = CreatePipe
}
- (bad1, bad2) <- concurrently
- (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))
- (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))
+ (o1, o2) <- concurrently
+ (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))
+ (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p))
fsckok <- checkSuccessProcess pid
- let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs
- let badobjs = S.union bad1 bad2
-
- if S.null badobjs && not fsckok
- then return FsckFailed
- else return $ FsckFoundMissing badobjs truncated
+ 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
where
maxobjs = 10000
+ noproblem = FsckFoundMissing S.empty False
foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
@@ -87,10 +112,18 @@ knownMissing (FsckFoundMissing s _) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects
-readMissingObjs maxobjs r supportsNoDangling h = do
- objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h
- findMissing objs r
+parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput
+parseFsckOutput maxobjs r supportsNoDangling h = do
+ ls <- lines <$> hGetContents h
+ if null ls
+ then return NoFsckOutput
+ else if all ("duplicateEntries" `isInfixOf`) ls
+ then return AllDuplicateEntriesWarning
+ else do
+ let shas = findShas supportsNoDangling ls
+ let !truncated = length shas > maxobjs
+ missingobjs <- findMissing (take maxobjs shas) r
+ return $ FsckOutput missingobjs truncated
isMissing :: Sha -> Repo -> IO Bool
isMissing s r = either (const True) (const False) <$> tryIO dump
@@ -100,8 +133,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
, Param (fromRef s)
] r
-findShas :: Bool -> String -> [Sha]
-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines
+findShas :: Bool -> [String] -> [Sha]
+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted
where
wanted l
| supportsNoDangling = True
diff --git a/Git/Index.hs b/Git/Index.hs
index 551fd98..85ea480 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -14,6 +14,20 @@ import Utility.Env
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
+{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path,
+ - or relative to the CWD.
+ -
+ - When relative, GIT_INDEX_FILE is interpreted by git as being
+ - relative to the top of the work tree of the git repository,
+ - not to the CWD. Worse, other environment variables (GIT_WORK_TREE)
+ - or git options (--work-tree) or configuration (core.worktree)
+ - can change what the relative path is interpreted relative to.
+ -
+ - So, an absolute path is the only safe option for this to return.
+ -}
+indexEnvVal :: FilePath -> IO String
+indexEnvVal = absPath
+
{- Forces git to use the specified index file.
-
- Returns an action that will reset back to the default
@@ -21,10 +35,11 @@ indexEnv = "GIT_INDEX_FILE"
-
- Warning: Not thread safe.
-}
-override :: FilePath -> IO (IO ())
-override index = do
+override :: FilePath -> Repo -> IO (IO ())
+override index _r = do
res <- getEnv var
- setEnv var index True
+ val <- indexEnvVal index
+ setEnv var val True
return $ reset res
where
var = "GIT_INDEX_FILE"
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 1ed6247..2060fa7 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,16 +1,19 @@
{- git ls-tree interface
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE BangPatterns #-}
+
module Git.LsTree (
TreeItem(..),
lsTree,
+ lsTree',
lsTreeParams,
lsTreeFiles,
- parseLsTree
+ parseLsTree,
) where
import Common
@@ -26,15 +29,19 @@ import System.Posix.Types
data TreeItem = TreeItem
{ mode :: FileMode
, typeobj :: String
- , sha :: String
+ , sha :: Ref
, file :: TopFilePath
} deriving Show
{- Lists the complete contents of a tree, recursing into sub-trees,
- with lazy output. -}
-lsTree :: Ref -> Repo -> IO [TreeItem]
-lsTree t repo = map parseLsTree
- <$> pipeNullSplitZombie (lsTreeParams t []) repo
+lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree = lsTree' []
+
+lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree' ps t repo = do
+ (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo
+ return (map parseLsTree l, cleanup)
lsTreeParams :: Ref -> [CommandParam] -> [CommandParam]
lsTreeParams r ps =
@@ -63,16 +70,18 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
- (The --long format is not currently supported.) -}
parseLsTree :: String -> TreeItem
parseLsTree l = TreeItem
- { mode = fst $ Prelude.head $ readOct m
+ { mode = smode
, typeobj = t
- , sha = s
- , file = asTopFilePath $ Git.Filename.decode f
+ , sha = Ref s
+ , file = sfile
}
where
-- l = <mode> SP <type> SP <sha> TAB <file>
-- All fields are fixed, so we can pull them out of
-- specific positions in the line.
(m, past_m) = splitAt 7 l
- (t, past_t) = splitAt 4 past_m
- (s, past_s) = splitAt shaSize $ Prelude.tail past_t
- f = Prelude.tail past_s
+ (!t, past_t) = splitAt 4 past_m
+ (!s, past_s) = splitAt shaSize $ Prelude.tail past_t
+ !f = Prelude.tail past_s
+ !smode = fst $ Prelude.head $ readOct m
+ !sfile = asTopFilePath $ Git.Filename.decode f
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6bc47d5..5b3b853 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -18,12 +18,20 @@ import Data.Char (chr)
headRef :: Ref
headRef = Ref "HEAD"
+headFile :: Repo -> FilePath
+headFile r = localGitDir r </> "HEAD"
+
+setHeadRef :: Ref -> Repo -> IO ()
+setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)
+
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
describe = fromRef . base
-{- Often git refs are fully qualified (eg: refs/heads/master).
- - Converts such a fully qualified ref into a base ref (eg: master). -}
+{- Often git refs are fully qualified
+ - (eg refs/heads/master or refs/remotes/origin/master).
+ - Converts such a fully qualified ref into a base ref
+ - (eg: master or origin/master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
where
@@ -31,12 +39,6 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
-{- Given a directory and any ref, takes the basename of the ref and puts
- - it under the directory. -}
-under :: String -> Ref -> Ref
-under dir r = Ref $ dir ++ "/" ++
- (reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
-
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
diff --git a/Git/Repair.hs b/Git/Repair.hs
index b441f13..fcfc036 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -342,8 +342,8 @@ verifyTree missing treesha r
| S.member treesha missing = return False
| otherwise = do
(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r
- let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls
- if any isNothing objshas || any (`S.member` missing) (catMaybes objshas)
+ let objshas = map (LsTree.sha . LsTree.parseLsTree) ls
+ if any (`S.member` missing) objshas
then do
void cleanup
return False
diff --git a/Git/Types.hs b/Git/Types.hs
index bb91a17..327c1d7 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -11,7 +11,6 @@ import Network.URI
import qualified Data.Map as M
import System.Posix.Types
import Utility.SafeCommand
-import Utility.URI ()
{- Support repositories on local disk, and repositories accessed via an URL.
-
@@ -40,6 +39,7 @@ data Repo = Repo
, remoteName :: Maybe RemoteName
-- alternate environment to use when running git commands
, gitEnv :: Maybe [(String, String)]
+ , gitEnvOverridesGitDir :: Bool
-- global options to pass to git when running git commands
, gitGlobalOpts :: [CommandParam]
} deriving (Show, Eq, Ord)
@@ -98,3 +98,24 @@ toBlobType 0o100644 = Just FileBlob
toBlobType 0o100755 = Just ExecutableBlob
toBlobType 0o120000 = Just SymlinkBlob
toBlobType _ = Nothing
+
+fromBlobType :: BlobType -> FileMode
+fromBlobType FileBlob = 0o100644
+fromBlobType ExecutableBlob = 0o100755
+fromBlobType SymlinkBlob = 0o120000
+
+data Commit = Commit
+ { commitTree :: Sha
+ , commitParent :: [Sha]
+ , commitAuthorMetaData :: CommitMetaData
+ , commitCommitterMetaData :: CommitMetaData
+ , commitMessage :: String
+ }
+ deriving (Show)
+
+data CommitMetaData = CommitMetaData
+ { commitName :: Maybe String
+ , commitEmail :: Maybe String
+ , commitDate :: Maybe String -- In raw git form, "epoch -tzoffset"
+ }
+ deriving (Show)
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 9854b47..94d5ac3 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -13,7 +13,6 @@ module Utility.CoProcess (
start,
stop,
query,
- rawMode
) where
import Common
@@ -44,7 +43,15 @@ start numrestarts cmd params environ = do
start' :: CoProcessSpec -> IO CoProcessState
start' s = do
(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
+ rawMode from
+ rawMode to
return $ CoProcessState pid to from s
+ where
+ rawMode h = do
+ fileEncoding h
+#ifdef mingw32_HOST_OS
+ hSetNewlineMode h noNewlineTranslation
+#endif
stop :: CoProcessHandle -> IO ()
stop ch = do
@@ -79,16 +86,3 @@ query ch send receive = do
{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
putMVar ch s'
query ch send receive
-
-rawMode :: CoProcessHandle -> IO CoProcessHandle
-rawMode ch = do
- s <- readMVar ch
- raw $ coProcessFrom s
- raw $ coProcessTo s
- return ch
- where
- raw h = do
- fileEncoding h
-#ifdef mingw32_HOST_OS
- hSetNewlineMode h noNewlineTranslation
-#endif
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 8b110ae..0ffc710 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
@@ -21,12 +21,18 @@ module Utility.Exception (
tryNonAsync,
tryWhenExists,
catchIOErrorType,
- IOErrorType(..)
+ IOErrorType(..),
+ catchPermissionDenied,
) where
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
+#ifdef MIN_VERSION_GLASGOW_HASKELL
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+import Control.Exception (SomeAsyncException)
+#endif
+#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
@@ -73,6 +79,11 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
+#ifdef MIN_VERSION_GLASGOW_HASKELL
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+ , M.Handler (\ (e :: SomeAsyncException) -> throwM e)
+#endif
+#endif
, M.Handler (\ (e :: SomeException) -> onerr e)
]
@@ -97,3 +108,6 @@ catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching
onlymatching e
| ioeGetErrorType e == errtype = onmatchingerr e
| otherwise = throwM e
+
+catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a
+catchPermissionDenied = catchIOErrorType PermissionDenied
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index efef5fa..bb3780c 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -18,9 +18,10 @@ import System.PosixCompat.Types
import Utility.PosixFiles
#ifndef mingw32_HOST_OS
import System.Posix.Files
+import Control.Monad.IO.Class (liftIO)
#endif
+import Control.Monad.IO.Class (MonadIO)
import Foreign (complement)
-import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Catch
import Utility.Exception
diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs
index 1055754..5f89cff 100644
--- a/Utility/FileSize.hs
+++ b/Utility/FileSize.hs
@@ -13,13 +13,15 @@ import Control.Exception (bracket)
import System.IO
#endif
+type FileSize = Integer
+
{- Gets the size of a file.
-
- This is better than using fileSize, because on Windows that returns a
- FileOffset which maxes out at 2 gb.
- See https://github.com/jystic/unix-compat/issues/16
-}
-getFileSize :: FilePath -> IO Integer
+getFileSize :: FilePath -> IO FileSize
#ifndef mingw32_HOST_OS
getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)
#else
@@ -27,7 +29,7 @@ getFileSize f = bracket (openFile f ReadMode) hClose hFileSize
#endif
{- Gets the size of the file, when its FileStatus is already known. -}
-getFileSize' :: FilePath -> FileStatus -> IO Integer
+getFileSize' :: FilePath -> 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 67341d3..eab9833 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -19,6 +19,7 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
+ setConsoleEncoding,
) where
import qualified GHC.Foreign as GHC
@@ -164,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString
else go (c:coll) (cnt - x') (L8.drop 1 bs)
_ -> coll
#endif
+
+{- This avoids ghc's output layer crashing on invalid encoded characters in
+ - filenames when printing them out. -}
+setConsoleEncoding :: IO ()
+setConsoleEncoding = do
+ fileEncoding stdout
+ fileEncoding stderr
diff --git a/Utility/Format.hs b/Utility/Format.hs
index 7844963..1ebf68d 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -103,7 +103,7 @@ empty _ = False
{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal
- encoded character, and \xNN is a hex encoded character.
-}
-decode_c :: FormatString -> FormatString
+decode_c :: FormatString -> String
decode_c [] = []
decode_c s = unescape ("", s)
where
@@ -141,14 +141,14 @@ decode_c s = unescape ("", s)
handle n = ("", n)
{- Inverse of decode_c. -}
-encode_c :: FormatString -> FormatString
+encode_c :: String -> FormatString
encode_c = encode_c' (const False)
{- Encodes more strictly, including whitespace. -}
-encode_c_strict :: FormatString -> FormatString
+encode_c_strict :: String -> FormatString
encode_c_strict = encode_c' isSpace
-encode_c' :: (Char -> Bool) -> FormatString -> FormatString
+encode_c' :: (Char -> Bool) -> String -> FormatString
encode_c' p = concatMap echar
where
e c = '\\' : [c]
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index da83fd8..440aa3f 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,6 +1,6 @@
{- Metered IO and actions
-
- - Copyright 2012-2105 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2106 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -21,6 +21,8 @@ import Data.Bits.Utils
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad.IO.Class (MonadIO)
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
{- An action that can be run repeatedly, updating it on the bytes processed.
-
@@ -259,3 +261,24 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do
where
p = (proc cmd (toCommand params))
{ env = environ }
+
+-- | Limit a meter to only update once per unit of time.
+--
+-- It's nice to display the final update to 100%, even if it comes soon
+-- after a previous update. To make that happen, a total size has to be
+-- provided.
+rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate
+rateLimitMeterUpdate delta totalsize meterupdate = do
+ lastupdate <- newMVar (toEnum 0 :: POSIXTime)
+ return $ mu lastupdate
+ where
+ mu lastupdate n@(BytesProcessed i) = case totalsize of
+ Just t | i >= t -> meterupdate n
+ _ -> do
+ now <- getPOSIXTime
+ prev <- takeMVar lastupdate
+ if now - prev >= delta
+ then do
+ putMVar lastupdate now
+ meterupdate n
+ else putMVar lastupdate prev
diff --git a/Utility/Path.hs b/Utility/Path.hs
index f3290d8..3ee5ff3 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -12,7 +12,6 @@ module Utility.Path where
import Data.String.Utils
import System.FilePath
-import System.Directory
import Data.List
import Data.Maybe
import Data.Char
@@ -29,6 +28,7 @@ import Utility.Exception
import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
+import Utility.Directory
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@@ -60,7 +60,7 @@ simplifyPath path = dropTrailingPathSeparator $
{- Makes a path absolute.
-
- The first parameter is a base directory (ie, the cwd) to use if the path
- - is not already absolute.
+ - is not already absolute, and should itsef be absolute.
-
- Does not attempt to deal with edge cases or ensure security with
- untrusted inputs.
@@ -252,15 +252,21 @@ dotfile file
where
f = takeFileName file
-{- Converts a DOS style path to a Cygwin style path. Only on Windows.
- - Any trailing '\' is preserved as a trailing '/' -}
-toCygPath :: FilePath -> FilePath
+{- Converts a DOS style path to a msys2 style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/'
+ -
+ - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
+ -
+ - The virtual filesystem contains:
+ - /c, /d, ... mount points for Windows drives
+ -}
+toMSYS2Path :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
-toCygPath = id
+toMSYS2Path = id
#else
-toCygPath p
+toMSYS2Path p
| null drive = recombine parts
- | otherwise = recombine $ "/cygdrive" : driveletter drive : parts
+ | otherwise = recombine $ "/" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
index 4550beb..37253da 100644
--- a/Utility/PosixFiles.hs
+++ b/Utility/PosixFiles.hs
@@ -1,6 +1,6 @@
{- POSIX files (and compatablity wrappers).
-
- - This is like System.PosixCompat.Files, except with a fixed rename.
+ - This is like System.PosixCompat.Files, but with a few fixes.
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
@@ -21,6 +21,7 @@ import System.PosixCompat.Files as X hiding (rename)
import System.Posix.Files (rename)
#else
import qualified System.Win32.File as Win32
+import qualified System.Win32.HardLink as Win32
#endif
{- System.PosixCompat.Files.rename on Windows calls renameFile,
@@ -32,3 +33,10 @@ import qualified System.Win32.File as Win32
rename :: FilePath -> FilePath -> IO ()
rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
#endif
+
+{- System.PosixCompat.Files.createLink throws an error, but windows
+ - does support hard links. -}
+#ifdef mingw32_HOST_OS
+createLink :: FilePath -> FilePath -> IO ()
+createLink = Win32.createHardLink
+#endif
diff --git a/Utility/Process.hs b/Utility/Process.hs
index c669996..ed02f49 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -18,6 +18,7 @@ module Utility.Process (
readProcessEnv,
writeReadProcessEnv,
forceSuccessProcess,
+ forceSuccessProcess',
checkSuccessProcess,
ignoreFailureProcess,
createProcessSuccess,
@@ -129,11 +130,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
-- | Waits for a ProcessHandle, and throws an IOError if the process
-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
-forceSuccessProcess p pid = do
- code <- waitForProcess pid
- case code of
- ExitSuccess -> return ()
- ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
+forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p
+
+forceSuccessProcess' :: CreateProcess -> ExitCode -> IO ()
+forceSuccessProcess' _ ExitSuccess = return ()
+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
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index cd408dd..0181ea9 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -6,7 +6,7 @@
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeSynonymInstances, CPP #-}
module Utility.QuickCheck
( module X
@@ -16,16 +16,20 @@ module Utility.QuickCheck
import Test.QuickCheck as X
import Data.Time.Clock.POSIX
import System.Posix.Types
+#if ! MIN_VERSION_QuickCheck(2,8,2)
import qualified Data.Map as M
import qualified Data.Set as S
+#endif
import Control.Applicative
import Prelude
-instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+#if ! MIN_VERSION_QuickCheck(2,8,2)
+instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where
arbitrary = M.fromList <$> arbitrary
-instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
+instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where
arbitrary = S.fromList <$> arbitrary
+#endif
{- Times before the epoch are excluded. -}
instance Arbitrary POSIXTime where
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 3aaf928..d3fe981 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -54,16 +54,16 @@ rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX"
rsync :: [CommandParam] -> IO Bool
rsync = boolSystem "rsync" . rsyncParamsFixup
-{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted
+{- On Windows, rsync is from msys2, and expects to get msys2 formatted
- paths to files. (It thinks that C:foo refers to a host named "C").
- Fix up the Params appropriately. -}
rsyncParamsFixup :: [CommandParam] -> [CommandParam]
#ifdef mingw32_HOST_OS
rsyncParamsFixup = map fixup
where
- fixup (File f) = File (toCygPath f)
+ fixup (File f) = File (toMSYS2Path f)
fixup (Param s)
- | rsyncUrlIsPath s = Param (toCygPath s)
+ | rsyncUrlIsPath s = Param (toMSYS2Path s)
fixup p = p
#else
rsyncParamsFixup = id
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 7610f6c..6a541cf 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -11,9 +11,9 @@
module Utility.Tmp where
import System.IO
-import System.Directory
import Control.Monad.IfElse
import System.FilePath
+import System.Directory
import Control.Monad.IO.Class
#ifndef mingw32_HOST_OS
import System.Posix.Temp (mkdtemp)
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 7e94caf..ec0b0d0 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -15,18 +15,17 @@ module Utility.UserInfo (
) where
import Utility.Env
+import Utility.Data
import System.PosixCompat
-#ifndef mingw32_HOST_OS
import Control.Applicative
-#endif
import Prelude
{- Current user's home directory.
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
-myHomeDir = myVal env homeDirectory
+myHomeDir = either error return =<< myVal env homeDirectory
where
#ifndef mingw32_HOST_OS
env = ["HOME"]
@@ -35,7 +34,7 @@ myHomeDir = myVal env homeDirectory
#endif
{- Current user's user name. -}
-myUserName :: IO String
+myUserName :: IO (Either String String)
myUserName = myVal env userName
where
#ifndef mingw32_HOST_OS
@@ -49,15 +48,15 @@ myUserGecos :: IO (Maybe String)
#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
myUserGecos = return Nothing
#else
-myUserGecos = Just <$> myVal [] userGecos
+myUserGecos = eitherToMaybe <$> myVal [] userGecos
#endif
-myVal :: [String] -> (UserEntry -> String) -> IO String
+myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)
myVal envvars extract = go envvars
where
#ifndef mingw32_HOST_OS
- go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
+ go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)
#else
- go [] = error $ "environment not set: " ++ show envvars
+ go [] = return $ Left ("environment not set: " ++ show envvars)
#endif
- go (v:vs) = maybe (go vs) return =<< getEnv v
+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v