From 962e279e17c1f3cf3be49ffdfb5e7310711a220c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:01:13 -0400 Subject: merge from git-annex --- CHANGELOG | 5 +- Git.hs | 13 ++++- Git/Branch.hs | 82 ++++++++++++++++++-------- Git/CatFile.hs | 130 +++++++++++++++++++++++++++++++++--------- Git/Command.hs | 6 +- Git/Construct.hs | 1 + Git/FilePath.hs | 17 ++++-- Git/Fsck.hs | 67 ++++++++++++++++------ Git/Index.hs | 21 ++++++- Git/LsTree.hs | 33 +++++++---- Git/Ref.hs | 18 +++--- Git/Repair.hs | 4 +- Git/Types.hs | 23 +++++++- Utility/CoProcess.hs | 22 +++---- Utility/Exception.hs | 18 +++++- Utility/FileMode.hs | 3 +- Utility/FileSize.hs | 6 +- Utility/FileSystemEncoding.hs | 8 +++ Utility/Format.hs | 8 +-- Utility/Metered.hs | 25 +++++++- Utility/Path.hs | 22 ++++--- Utility/PosixFiles.hs | 10 +++- Utility/Process.hs | 12 ++-- Utility/QuickCheck.hs | 10 +++- Utility/Rsync.hs | 6 +- Utility/Tmp.hs | 2 +- Utility/UserInfo.hs | 17 +++--- 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 Wed, 04 May 2016 12:16:33 -0400 + -- Joey Hess 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 + - Copyright 2011-2016 Joey Hess - - 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 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 + - Copyright 2011-2016 Joey Hess - - 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 = SP SP TAB -- 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 + - Copyright 2012-2106 Joey Hess - - 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 - @@ -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 -- cgit v1.2.3