diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +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 Mon, 11 Jan 2021 22:00:49 -0400 + git-repair (1.20200504) unstable; urgency=medium * Fix a few documentation typos. diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -25,7 +25,9 @@ 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 --- a/Git.hs +++ b/Git.hs @@ -3,11 +3,12 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git ( @@ -37,10 +38,12 @@ 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 @@ -130,14 +133,13 @@ | 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. -} @@ -159,13 +161,13 @@ 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' @@ -173,8 +175,7 @@ } } 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/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Git.CatFile ( CatFileHandle, @@ -19,6 +20,9 @@ catObject, catObjectDetails, catObjectMetaData, + catObjectStreamLsTree, + catObjectStream, + catObjectMetaDataStream, ) where import System.IO @@ -27,12 +31,15 @@ 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 as M +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 @@ -40,9 +47,10 @@ 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 @@ -57,7 +65,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" - <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> startp ("--batch-check=" ++ batchFormat) <*> pure repo where startp p = gitCoProcessStart restartable @@ -65,6 +73,9 @@ , Param p ] repo +batchFormat :: String +batchFormat = "%(objectname) %(objecttype) %(objectsize)" + catFileStop :: CatFileHandle -> IO () catFileStop h = do CoProcess.stop (catFileProcess h) @@ -72,12 +83,12 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString -catFile h branch file = catObject h $ Ref $ - fromRef' branch <> ":" <> 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 <> ":" <> 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. -} @@ -88,18 +99,12 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha objtype size) -> 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) 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 Nothing -> return Nothing @@ -113,6 +118,18 @@ (gitRepo 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) $ + error $ "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 h object = query (checkFileProcess h) object newlinefallback $ \from -> do @@ -180,14 +197,16 @@ , 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')) @@ -264,3 +283,123 @@ 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 + liftIO $ 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 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -43,15 +43,19 @@ {- 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 @@ -70,14 +74,18 @@ {- 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' reader params repo = assertLocal repo $ withCreateProcess p go where - p = gitCreateProcess params repo + p = (gitCreateProcess params repo) + { std_out = CreatePipe } + go _ (Just outh) _ pid = do + output <- reader 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. -} @@ -95,9 +103,16 @@ {- 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. -} @@ -118,16 +133,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 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -58,29 +58,37 @@ 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 ConfigNullList + git_config d = withCreateProcess p (git_config' p) where params = ["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) ConfigNullList - 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 -> ConfigStyle -> Handle -> IO Repo @@ -132,9 +140,9 @@ 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' } @@ -177,6 +185,10 @@ | 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 @@ -198,22 +210,30 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output and any standard output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) -fromPipe r cmd params st = try $ - withOEHandles createProcessSuccess p $ \(hout, herr) -> do - geterr <- async $ S.hGetContents herr - getval <- async $ S.hGetContents hout - val <- wait getval - err <- wait geterr - r' <- store val st r - return (r', val, err) + - 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, S.ByteString)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,10 +1,11 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git.Construct ( @@ -21,6 +22,7 @@ repoAbsPath, checkForRepo, newFrom, + adjustGitDirFile, ) where #ifndef mingw32_HOST_OS @@ -37,6 +39,9 @@ import qualified Git.Url as Url import Utility.UserInfo +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. -} fromCwd :: IO (Maybe Repo) @@ -45,40 +50,40 @@ 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 :: RawFilePath -> IO Repo fromPath dir = fromAbsPath =<< absPath 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 = hunt | otherwise = - error $ "internal error, " ++ dir ++ " is not absolute" + error $ "internal error, " ++ show dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown . toRawFilePath - canondir = dropTrailingPathSeparator dir + ret = pure . newFrom . LocalUnknown + canondir = P.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") + | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = + ifM (doesDirectoryExist $ fromRawFilePath dir ".git") ( ret dir - , ret (takeDirectory canondir) + , ret (P.takeDirectory canondir) ) - | otherwise = ifM (doesDirectoryExist dir) - ( ret dir + | 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") + then ret (dir <> ".git") else ret dir ) @@ -94,7 +99,8 @@ fromUrlStrict :: String -> IO Repo fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $ + unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -128,7 +134,8 @@ 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) + construct (k,v) = remoteNamedFromKey k $ + fromRemoteLocation (fromConfigValue v) repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -154,18 +161,18 @@ 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 @@ -198,7 +205,7 @@ checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ - check gitDirFile $ + check (checkGitDirFile (toRawFilePath dir)) $ check isBareRepo $ return Nothing where @@ -217,21 +224,39 @@ 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) - } - else Nothing - where - gitdirprefix = "gitdir: " gitSignature file = doesFileExist $ dir file + +-- 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 return Nothing + where + gitdirprefix = "gitdir: " + newFrom :: RepoLocation -> Repo newFrom l = Repo diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,10 +1,12 @@ {- The current git repository. - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CurrentRepo where import Common @@ -13,7 +15,11 @@ 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. - - Honors GIT_DIR and GIT_WORK_TREE. @@ -37,14 +43,14 @@ 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 Just d -> do - curr <- getCurrentDirectory + curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory d + setCurrentDirectory (fromRawFilePath d) return $ addworktree wt r where getpathenv s = do @@ -52,34 +58,35 @@ 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) - } + curr <- R.getCurrentDirectory + loc <- adjustGitDirFile $ Local + { gitdir = absd + , worktree = Just curr + } + r <- Git.Config.read $ newFrom loc return $ if 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 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -95,12 +95,12 @@ case d of Empty s -> withfile s $ \f -> withSaneMode f $ do - nukeFile f + removeWhenExistsWith removeLink 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 removeLink AppendGarbage s garbage -> withfile s $ \f -> withSaneMode f $ @@ -145,4 +145,5 @@ ] withSaneMode :: FilePath -> IO () -> IO () -withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode]) +withSaneMode f = withModifiedFileMode (toRawFilePath f) + (addModes [ownerWriteMode, ownerReadMode]) diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -58,8 +58,7 @@ {- 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 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -10,6 +10,7 @@ import Common import Utility.Format (decode_c, encode_c) +import Utility.QuickCheck import Data.Char import Data.Word @@ -35,21 +36,14 @@ 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'))) +-- 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_encode_decode_roundtrip :: TestableFilePath -> Bool +prop_encode_decode_roundtrip ts = + 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') + s = fromTestableFilePath ts diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -77,27 +77,31 @@ 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 @@ -117,9 +121,9 @@ 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 +133,10 @@ 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 diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -36,10 +36,10 @@ hashObjectStop = CoProcess.stop {- Injects a file into git, returning the Sha of the object. -} -hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile :: HashObjectHandle -> RawFilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = hPutStrLn to =<< absPath file + send to = S8.hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where @@ -60,7 +60,7 @@ 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 --- 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 Utility.Env import Utility.Env.Set +import qualified System.FilePath.ByteString as P + indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -26,8 +30,8 @@ - - 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 @@ - - 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 @@ 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 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,22 +1,24 @@ {- git ls-files interface - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( + Options(..), inRepo, + inRepoDetails, inRepoOrBranch, notInRepo, notInRepoIncludingEmptyDirectories, allFiles, deleted, modified, - modifiedOthers, staged, stagedNotDeleted, - stagedOthersDetails, + usualStageNum, + mergeConflictHeadStageNum, stagedDetails, typeChanged, typeChangedStaged, @@ -34,12 +36,15 @@ import Git.Sha import Utility.InodeCache import Utility.TimeStamp +import Utility.Attoparsec +import qualified Utility.RawFilePath as R -import Numeric -import Data.Char import System.Posix.Types 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. - @@ -63,101 +68,75 @@ | safeForLsFiles r = a | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r +data Options = ErrorUnmatch + +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 :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo = inRepo' [] +inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo = inRepo' [Param "--cached"] -inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo +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 b = inRepo' [Param $ "--with-tree=" ++ fromRef 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 = guardSafeForLsFiles 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 repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo - where - params = - 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 = guardSafeForLsFiles 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 = guardSafeForLsFiles 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 = guardSafeForLsFiles 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) @@ -175,36 +154,49 @@ 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) -{- 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"] +type StageNum = Int -{- Returns details about all files that are staged in the index. -} +{- Used when not in a merge conflict. -} +usualStageNum :: Int +usualStageNum = 0 + +{- 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 = guardSafeForLsFiles repo $ do +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 (map parseStagedDetails ls, cleanup) + return (mapMaybe parser ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: S.ByteString -> StagedDetails -parseStagedDetails s - | S.null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha sha, readmode mode) +parseStagedDetails :: S.ByteString -> Maybe StagedDetails +parseStagedDetails = eitherToMaybe . A.parseOnly parser where - (metadata, file) = separate' (== fromIntegral (ord '\t')) s - (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata - (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' - readmode = fst <$$> headMaybe . readOct . decodeBS' + 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. -} @@ -218,12 +210,12 @@ typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = guardSafeForLsFiles repo $ do - (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo + (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" diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,17 +1,17 @@ {- git ls-tree interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Git.LsTree ( TreeItem(..), LsTreeMode(..), lsTree, lsTree', + lsTreeStrict, + lsTreeStrict', lsTreeParams, lsTreeFiles, parseLsTree, @@ -30,6 +30,7 @@ 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,7 +39,7 @@ , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath - } deriving Show + } deriving (Show) data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive @@ -51,6 +52,13 @@ (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo return (rights (map parseLsTree l), cleanup) +lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict = lsTreeStrict' [] + +lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict + <$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo + lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = [ Param "ls-tree" @@ -82,6 +90,13 @@ parseLsTree b = case A.parse parserLsTree b of A.Done _ r -> Right r A.Fail _ _ err -> Left err + +parseLsTreeStrict :: S.ByteString -> Either String TreeItem +parseLsTreeStrict b = go (AS.parse parserLsTree 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 diff --git a/Git/Objects.hs b/Git/Objects.hs --- 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 -packDir :: Repo -> FilePath -packDir r = objectsDir r "pack" +objectsDir :: Repo -> RawFilePath +objectsDir r = localGitDir r P. "objects" -packIdxFile :: FilePath -> FilePath -packIdxFile = flip replaceExtension "idx" +packDir :: Repo -> RawFilePath +packDir r = objectsDir r P. "pack" +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 . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) - <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + <$> 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/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,7 @@ import Git.Command import Git.Sha import Git.Types +import Git.FilePath import Data.Char (chr, ord) import qualified Data.ByteString as S @@ -68,7 +69,11 @@ - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" <> f +fileRef f = Ref $ ":./" <> toInternalGitPath f + +{- 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 diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Repair ( runRepair, runRepairOf, @@ -35,13 +37,15 @@ 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,9 +55,9 @@ 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 @@ -77,10 +81,11 @@ putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do moveFile packfile (tmpdir takeFileName packfile) - nukeFile $ packIdxFile packfile + removeWhenExistsWith R.removeLink + (packIdxFile (toRawFilePath packfile)) forM_ packs $ \packfile -> do let tmp = tmpdir takeFileName packfile - allowRead tmp + allowRead (toRawFilePath tmp) -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> @@ -100,7 +105,7 @@ | 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 + tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -161,8 +166,8 @@ 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 @@ -240,18 +245,20 @@ 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 gitd = fromRawFilePath (localGitDir r) - let dest = gitd fromRef ref + 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) + unlessM (doesFileExist dest') $ + writeFile dest' (fromRef sha) packedRefsFile :: Repo -> FilePath packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" @@ -266,7 +273,7 @@ {- 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. @@ -379,9 +386,8 @@ 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) @@ -393,17 +399,16 @@ | 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 newtype GoodCommits = GoodCommits (S.Set Sha) @@ -442,14 +447,13 @@ 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" + headfile = localGitDir g P. "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha (encodeBS' s)) @@ -460,14 +464,19 @@ putStrLn "Running git fsck ..." fsckresult <- findBroken 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 @@ -571,7 +580,7 @@ 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 @@ -615,7 +624,7 @@ 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/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} module Git.Types where @@ -79,10 +79,16 @@ instance Show ConfigKey where show = fromConfigKey -fromConfigValue :: ConfigValue -> String -fromConfigValue (ConfigValue s) = decodeBS' s -fromConfigValue NoConfigValue = mempty +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 @@ -129,7 +135,12 @@ 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. -} @@ -138,6 +149,7 @@ readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule +readTreeItemType "040000" = Just TreeSubtree readTreeItemType _ = Nothing fmtTreeItemType :: TreeItemType -> S.ByteString @@ -145,12 +157,14 @@ 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 @@ -158,6 +172,7 @@ 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 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,8 +12,7 @@ pureStreamer, streamUpdateIndex, streamUpdateIndex', - startUpdateIndex, - stopUpdateIndex, + withUpdateIndex, lsTree, lsSubTree, updateIndexLine, @@ -32,7 +31,9 @@ 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 @@ {- 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. -} @@ -113,12 +118,12 @@ <> 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. -} @@ -131,16 +136,8 @@ 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 +refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex repo feeder = withCreateProcess p go where params = [ Param "update-index" @@ -149,3 +146,14 @@ , Param "-z" , Param "--stdin" ] + + p = (gitCreateProcess params repo) + { std_in = CreatePipe } + + go (Just h) _ _ pid = do + feeder $ \f -> + S.hPut h (S.snoc f 0) + hFlush h + hClose h + checkSuccessProcess pid + go _ _ _ _ = error "internal" diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -14,7 +14,7 @@ GitVersion, ) where -import Common +import Utility.Process import Utility.DottedVersion type GitVersion = DottedVersion diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced. - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Batch ( batch, BatchCommandMaker, + nonBatchCommandMaker, getBatchCommandMaker, toBatchCommand, batchCommand, @@ -22,7 +23,6 @@ import Control.Concurrent.Async import System.Posix.Process #endif -import qualified Control.Exception as E {- Runs an operation, at batch priority. - @@ -42,17 +42,18 @@ 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 @@ -75,11 +76,7 @@ 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 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/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,26 +16,16 @@ import Control.Monad import System.FilePath -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Control.Applicative -import Control.Monad.IO.Class -import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error import Data.Maybe import Prelude -#ifndef mingw32_HOST_OS -import Utility.SafeCommand -#endif - import Utility.SystemDirectory -import Utility.Path -import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative -import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -101,131 +91,9 @@ =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs -{- 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. - - - - 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 - -{- Like createDirectoryIfMissing True, but it will only create - - missing parent directories up to but not including the directory - - in 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. - - - - Either or both of the FilePaths can be relative, or absolute. - - They will be normalized as necessary. +{- Use with an action that removes something, which may or may not exist. - - - Note that, the second FilePath, if relative, is relative to the current - - working directory, not to the first FilePath. + - If an exception is thrown due to it not existing, it is ignored. -} -createDirectoryUnder :: FilePath -> FilePath -> IO () -createDirectoryUnder topdir dir = - createDirectoryUnder' topdir dir createDirectory - -createDirectoryUnder' - :: (MonadIO m, MonadCatch m) - => FilePath - -> FilePath - -> (FilePath -> m ()) - -> m () -createDirectoryUnder' topdir dir0 mkdir = do - p <- liftIO $ relPathDirToFile topdir dir0 - let dirs = splitDirectories p - -- Catch cases where the dir is not beneath the 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. - if headMaybe dirs == Just ".." || isAbsolute p - then liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ topdir) - -- If dir0 is the same as the topdir, don't try to create - -- it, but make sure it does exist. - else if null dirs - then liftIO $ unlessM (doesDirectoryExist topdir) $ - ioError $ customerror doesNotExistErrorType - "createDirectoryFrom: does not exist" - else createdirs $ - map (topdir ) (reverse (scanl1 () dirs)) - where - customerror t s = mkIOError t s Nothing (Just 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 dir) $ - ioError e - | otherwise -> liftIO $ ioError e +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 --- /dev/null +++ b/Utility/Directory/Create.hs @@ -0,0 +1,102 @@ +{- directory creating + - + - Copyright 2011-2020 Joey Hess + - + - 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 the directory + - in 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. + - + - Either or both of 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, not to the first FilePath. + -} +createDirectoryUnder :: RawFilePath -> RawFilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir R.createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => RawFilePath + -> RawFilePath + -> (RawFilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = P.splitDirectories p + -- Catch cases where the dir is not beneath the 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. + if headMaybe dirs == Just ".." || P.isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ fromRawFilePath topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir P.) (reverse (scanl1 (P.) dirs)) + 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 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -13,7 +13,7 @@ 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 --- 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 @@ #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 @@ #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 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -39,7 +39,7 @@ {- 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 + - where there's a problem that the user is expeected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,11 +1,12 @@ {- File mode utilities. - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileMode ( module Utility.FileMode, @@ -15,32 +16,30 @@ import System.IO import Control.Monad import System.PosixCompat.Types -import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Files (symbolicLinkMode) -import Control.Monad.IO.Class (liftIO) -#endif -import Control.Monad.IO.Class (MonadIO) +import System.PosixCompat.Files hiding (removeLink) +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 +72,15 @@ ] {- 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,20 +90,12 @@ , 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 @@ -160,7 +151,7 @@ stickyMode :: FileMode stickyMode = 512 -setSticky :: FilePath -> IO () +setSticky :: RawFilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -173,13 +164,13 @@ - 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' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = protectedOutput $ - withFile file WriteMode $ \h -> do + withFile (fromRawFilePath file) WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -1,5 +1,7 @@ {- File size. - + - Copyright 2015-2020 Joey Hess + - - License: BSD-2-clause -} @@ -12,10 +14,12 @@ getFileSize', ) where -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) +import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO +import Utility.FileSystemEncoding #endif type FileSize = Integer @@ -26,18 +30,18 @@ - 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 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -36,17 +36,18 @@ 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 #ifdef mingw32_HOST_OS import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 +#else +import Data.List +import Utility.Split #endif -import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) 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 @@ -178,6 +179,7 @@ toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeFilePath +#ifndef mingw32_HOST_OS {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - w82s produces a String, which may contain Chars that are invalid @@ -206,6 +208,7 @@ decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where nul = '\NUL' +#endif c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum diff --git a/Utility/Format.hs b/Utility/Format.hs --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,6 +1,6 @@ {- Formatted string handling. - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ Format, gen, format, + formatContainsVar, decode_c, encode_c, + encode_c', prop_encode_c_decode_c_roundtrip ) where @@ -29,9 +31,14 @@ {- 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 +52,8 @@ 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 $ encode_c' isSpace $ getvar name | otherwise = justify j $ getvar name getvar name = fromMaybe "" $ M.lookup name vars justify UnJustified s = s @@ -61,6 +66,8 @@ - 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 @@ -94,12 +101,24 @@ | 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. -} @@ -144,10 +163,7 @@ 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 - +{- Encodes special characters, as well as any matching the predicate. -} encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar where @@ -165,8 +181,8 @@ | 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 + | p c = e_asc c + | otherwise = [c] -- unicode character is decomposed to individual Word8s, -- and each is shown in octal e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,7 +19,6 @@ import Utility.PartialPrelude import Utility.QuickCheck -import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) @@ -45,8 +44,10 @@ 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 @@ -56,7 +57,7 @@ u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = Fail.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 } @@ -102,4 +103,4 @@ 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 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -186,15 +186,15 @@ genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + toInodeCache delta f =<< R.getFileStatus f -toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s #ifdef mingw32_HOST_OS - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else let mtime = modificationTimeHiRes s #endif diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2018 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ module Utility.Metered ( MeterUpdate, + MeterState(..), nullMeterUpdate, combineMeterUpdate, + TotalSize(..), BytesProcessed(..), toBytesProcessed, fromBytesProcessed, @@ -29,6 +31,8 @@ ProgressParser, commandMeter, commandMeter', + commandMeterExitCode, + commandMeterExitCode', demeterCommand, demeterCommandEnv, avoidProgress, @@ -46,6 +50,7 @@ import Utility.Percentage import Utility.DataUnits import Utility.HumanTime +import Utility.SimpleProtocol as Proto import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -73,7 +78,7 @@ {- 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 @@ -165,8 +170,9 @@ 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 +224,8 @@ p sz watcher sz getsz = catchDefaultIO zeroBytesProcessed $ - toBytesProcessed <$> getFileSize f + toBytesProcessed <$> getFileSize f' + f' = toRawFilePath f data OutputHandler = OutputHandler { quietMode :: Bool @@ -226,31 +233,45 @@ } {- 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 +280,24 @@ 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,9 +309,9 @@ 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 @@ -296,31 +324,39 @@ - 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 +369,7 @@ 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,33 +379,39 @@ meterupdate n else putMVar lastupdate prev -data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter +data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter -type MeterState = (BytesProcessed, POSIXTime) +data MeterState = MeterState + { meterBytesProcessed :: BytesProcessed + , meterTimeStamp :: POSIXTime + } deriving (Show) -type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO () +type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO () -type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String +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 +mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = do + ts <- getPOSIXTime + Meter + <$> newMVar totalsize + <*> newMVar (MeterState zeroBytesProcessed ts) + <*> newMVar "" + <*> pure displaymeter -setMeterTotalSize :: Meter -> Integer -> IO () +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 @@ -394,7 +436,7 @@ -- 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" @@ -405,7 +447,7 @@ where amount = roughSize' memoryUnits 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 @@ -417,8 +459,12 @@ 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/MoveFile.hs b/Utility/MoveFile.hs new file mode 100644 --- /dev/null +++ b/Utility/MoveFile.hs @@ -0,0 +1,74 @@ +{- moving files + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.MoveFile ( + moveFile, +) where + +import Control.Monad +import System.FilePath +import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error +import Prelude + +#ifndef mingw32_HOST_OS +import Control.Monad.IfElse +import Utility.SafeCommand +#endif + +import Utility.SystemDirectory +import Utility.Tmp +import Utility.Exception +import Utility.Monad + +{- 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 diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,63 +1,59 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2020 Joey Hess - - 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, + runSegmentPaths', inPath, searchPath, dotfile, - sanitizeFilePath, splitShortExtensions, - - prop_upFrom_basics, - prop_relPathDirToFile_basics, - prop_relPathDirToFile_regressionTest, + relPathDirToFileAbs, ) 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.Applicative import Prelude import Utility.Monad -import Utility.UserInfo import Utility.SystemDirectory -import Utility.Split + +#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 + - yeild 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,134 +68,37 @@ where p' = dropTrailingPathSeparator p -{- 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 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. -} -dirContains :: FilePath -> FilePath -> Bool +dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `isPrefixOf` b' + || (addTrailingPathSeparator a') `B.isPrefixOf` b' || a' == "." && normalise ("." b') == b' where a' = norm a b' = norm b norm = normalise . simplifyPath -{- Converts a filename into an absolute path. - - - - Also simplifies it using simplifyPath. - - - - Unlike Directory.canonicalizePath, this does not require the path - - already exists. -} -absPath :: FilePath -> IO FilePath -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 - cwd <- getCurrentDirectory - return $ absPathFrom cwd file - -{- Constructs a relative path from the CWD to a file. - - - - For example, assuming CWD is /tmp/foo/bar: - - relPathCwdToFile "/tmp/foo" == ".." - - relPathCwdToFile "/tmp/foo/bar" == "" - -} -relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = do - c <- getCurrentDirectory - relPathDirToFile c f - -{- Constructs a relative path from a directory to a file. -} -relPathDirToFile :: FilePath -> FilePath -> IO FilePath -relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to - -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ - - - - 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 from to -#ifdef mingw32_HOST_OS - | normdrive from /= normdrive to = to -#endif - | otherwise = joinPath $ dotdots ++ uncommon - where - pfrom = sp from - pto = sp to - sp = map dropTrailingPathSeparator . splitPath . dropDrive - common = map fst $ takeWhile same $ zip pfrom pto - same (c,d) = c == d - uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." - numcommon = length common -#ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . 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. @@ -213,30 +112,29 @@ - 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 +segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]] +segmentPaths = segmentPaths' (\_ r -> r) + +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 ls < 100 - then partition inl new - else break (not . inl) new - inl f = fromRawFilePath l `dirContains` fromRawFilePath f + (found, rest) = if length is < 100 + then partition ini new + else break (not . ini) new + ini p = i `dirContains` c p {- 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 +runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]] +runSegmentPaths c a paths = segmentPaths c 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 +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 command is available in PATH. - @@ -254,10 +152,10 @@ -} 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"] @@ -267,42 +165,52 @@ {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} -dotfile :: FilePath -> Bool +dotfile :: RawFilePath -> Bool dotfile file | f == "." = False | f == ".." = False | f == "" = False - | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + | otherwise = "." `B.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. - - - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' - - "../" will thus turn into ".._", which is safe. - -} -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 +{- Similar to splitExtensions, but knows that some things in RawFilePaths - after a dot are too long to be extensions. -} -splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" -splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions' maxextension = go [] where go c f - | len > 0 && len <= maxextension && not (null base) = + | len > 0 && len <= maxextension && not (B.null base) = go (ext:c) base | otherwise = (f, c) where (base, ext) = splitExtension f - len = length ext + len = B.length ext + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ + - + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. + -} +relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath +relPathDirToFileAbs from to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif + | otherwise = joinPath $ dotdots ++ uncommon + where + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath . dropDrive + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive +#endif diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs new file mode 100644 --- /dev/null +++ b/Utility/Path/AbsRel.hs @@ -0,0 +1,93 @@ +{- absolute and relative path manipulation + - + - Copyright 2010-2020 Joey Hess + - + - 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 +#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 itsef 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 a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: RawFilePath -> IO RawFilePath +relPathCwdToFile f = do +#ifdef mingw32_HOST_OS + c <- toRawFilePath <$> getCurrentDirectory +#else + c <- getWorkingDirectory +#endif + relPathDirToFile c f + +{- Constructs a 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 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -6,12 +6,11 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, Rank2Types #-} +{-# LANGUAGE CPP, Rank2Types, LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, - CreateProcess(..), StdHandle(..), readProcess, readProcess', @@ -20,64 +19,55 @@ forceSuccessProcess, forceSuccessProcess', checkSuccessProcess, - ignoreFailureProcess, - createProcessSuccess, - createProcessChecked, - createBackgroundProcess, - withHandle, - withIOHandles, - withOEHandles, withNullHandle, - withQuietOutput, - feedWithQuietOutput, createProcess, + withCreateProcess, waitForProcess, + cleanupProcess, + hGetLineUntilExitOrEOF, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, - ioHandles, processHandle, 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 System.Exit import System.IO import System.Log.Logger -import Control.Concurrent -import qualified Control.Exception as E -import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent.Async import qualified Data.ByteString as S -type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a - data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) -- | Normally, when reading from a process, it does not need to be fed any -- standard input. 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. @@ -87,26 +77,7 @@ -> Maybe [(String, String)] -> (Maybe (Handle -> IO ())) -> IO S.ByteString -writeReadProcessEnv cmd args environ writestdin = do - (Just inh, Just outh, _, pid) <- createProcess p - - -- fork off a thread to start consuming the output - outMVar <- newEmptyMVar - _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh - - -- now write and flush any input - maybe (return ()) (\a -> a inh >> hFlush inh) writestdin - hClose inh -- done with stdin - - -- wait on the output - output <- takeMVar outMVar - hClose outh - - -- wait on the process - forceSuccessProcess p pid - - return output - +writeReadProcessEnv cmd args environ writestdin = withCreateProcess p go where p = (proc cmd args) { std_in = CreatePipe @@ -114,7 +85,19 @@ , 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. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () @@ -126,117 +109,15 @@ 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 @@ -252,6 +133,7 @@ -- 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" @@ -261,12 +143,6 @@ 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 @@ -298,15 +174,24 @@ -- | 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 + debugM "Utility.Process" $ unwords + [ describePid pid + , action ++ ":" + , showCmd p + ] where action | piped (std_in p) && piped (std_out p) = "chat" @@ -316,9 +201,121 @@ 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) + debugM "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/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,15 +10,52 @@ module Utility.QuickCheck ( module X - , module Utility.QuickCheck + , TestableString + , fromTestableString + , TestableFilePath + , fromTestableFilePath + , 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 diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,4 +1,4 @@ -{- Portability shim around System.Posix.Files.ByteString +{- Portability shim for basic operations on RawFilePaths. - - On unix, this makes syscalls using RawFilesPaths as efficiently as - possible. @@ -7,38 +7,69 @@ - decoded. So this library will work, but less efficiently than using - FilePath would. - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - 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, ) 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 qualified Data.ByteString as B -import System.PosixCompat (FileStatus) +import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P +import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) +createSymbolicLink :: RawFilePath -> RawFilePath -> IO () +createSymbolicLink a b = P.createSymbolicLink + (fromRawFilePath a) + (fromRawFilePath b) + +createLink :: RawFilePath -> RawFilePath -> IO () +createLink a b = P.createLink + (fromRawFilePath a) + (fromRawFilePath 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.getFileStatus . fromRawFilePath @@ -47,4 +78,13 @@ 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 = F.setFileMode . fromRawFilePath #endif diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -114,7 +114,7 @@ -} 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 @@ 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 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -16,18 +16,13 @@ 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 @@ -- | 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,53 +78,15 @@ 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) safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } - --- | Wraps a shell command line inside sh -c, allowing it to be run in a --- login shell that may not support POSIX shell, eg csh. -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. diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs new file mode 100644 --- /dev/null +++ b/Utility/SimpleProtocol.hs @@ -0,0 +1,151 @@ +{- Simple line-based protocols. + - + - Copyright 2013-2020 Joey Hess + - + - 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/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -20,16 +20,22 @@ import System.FilePath import System.Directory import Control.Monad.IO.Class -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Utility.Exception import Utility.FileSystemEncoding +import Utility.FileMode type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - - directory as the final file to avoid cross-device renames. -} + - 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 @@ -42,6 +48,11 @@ _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do + -- 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 $ setFileMode tmpfile =<< defaultFileMode liftIO $ hClose h a tmpfile content liftIO $ rename tmpfile file @@ -54,7 +65,11 @@ 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 diff --git a/git-repair.cabal b/git-repair.cabal --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20200504 +Version: 1.20210111 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -28,7 +28,7 @@ custom-setup Setup-Depends: base (>= 4.11.1.0 && < 5.0), hslogger, split, unix-compat, process, unix, filepath, - filepath-bytestring (>= 1.4.2.1.1), + filepath-bytestring (>= 1.4.2.1.1), async, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -38,8 +38,8 @@ Executable git-repair Main-Is: git-repair.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -O2 - Default-Language: Haskell98 + 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, @@ -94,6 +94,7 @@ Utility.Data Utility.DataUnits Utility.Directory + Utility.Directory.Create Utility.DottedVersion Utility.Env Utility.Env.Basic @@ -109,8 +110,10 @@ Utility.Metered Utility.Misc Utility.Monad + Utility.MoveFile Utility.PartialPrelude Utility.Path + Utility.Path.AbsRel Utility.Percentage Utility.Process Utility.Process.Shim @@ -118,6 +121,7 @@ Utility.RawFilePath Utility.Rsync Utility.SafeCommand + Utility.SimpleProtocol Utility.Split Utility.SystemDirectory Utility.ThreadScheduler diff --git a/git-repair.hs b/git-repair.hs --- a/git-repair.hs +++ b/git-repair.hs @@ -93,7 +93,7 @@ ] 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