git-repair 1.20200504 → 1.20210111
raw patch · 47 files changed
+1616/−1049 lines, 47 files
Files
- CHANGELOG +9/−0
- Common.hs +2/−0
- Git.hs +13/−12
- Git/CatFile.hs +160/−21
- Git/Command.hs +29/−24
- Git/Config.hs +41/−21
- Git/Construct.hs +61/−36
- Git/CurrentRepo.hs +22/−15
- Git/Destroyer.hs +4/−3
- Git/FilePath.hs +1/−2
- Git/Filename.hs +11/−17
- Git/Fsck.hs +31/−23
- Git/HashObject.hs +3/−3
- Git/Index.hs +13/−9
- Git/LsFiles.hs +83/−91
- Git/LsTree.hs +19/−4
- Git/Objects.hs +19/−13
- Git/Ref.hs +7/−2
- Git/Repair.hs +42/−33
- Git/Types.hs +20/−5
- Git/UpdateIndex.hs +37/−29
- Git/Version.hs +1/−1
- Utility/Batch.hs +8/−20
- Utility/Directory.hs +5/−137
- Utility/Directory/Create.hs +102/−0
- Utility/DottedVersion.hs +1/−1
- Utility/Env/Set.hs +6/−0
- Utility/Exception.hs +1/−1
- Utility/FileMode.hs +19/−28
- Utility/FileSize.hs +9/−5
- Utility/FileSystemEncoding.hs +6/−3
- Utility/Format.hs +31/−15
- Utility/HumanTime.hs +6/−5
- Utility/InodeCache.hs +3/−3
- Utility/Metered.hs +109/−63
- Utility/MoveFile.hs +74/−0
- Utility/Path.hs +76/−168
- Utility/Path/AbsRel.hs +93/−0
- Utility/Process.hs +167/−170
- Utility/QuickCheck.hs +39/−2
- Utility/RawFilePath.hs +44/−4
- Utility/Rsync.hs +3/−3
- Utility/SafeCommand.hs +7/−48
- Utility/SimpleProtocol.hs +151/−0
- Utility/Tmp.hs +19/−4
- git-repair.cabal +8/−4
- git-repair.hs +1/−1
CHANGELOG view
@@ -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 <id@joeyh.name> Mon, 11 Jan 2021 22:00:49 -0400+ git-repair (1.20200504) unstable; urgency=medium * Fix a few documentation typos.
Common.hs view
@@ -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
Git.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - 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
Git/CatFile.hs view
@@ -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
Git/Command.hs view
@@ -1,6 +1,6 @@ {- running git commands -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -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
Git/Config.hs view
@@ -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"
Git/Construct.hs view
@@ -1,10 +1,11 @@ {- Construction of Git Repo objects -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE 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
Git/CurrentRepo.hs view
@@ -1,10 +1,12 @@ {- The current git repository. -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - 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 }
Git/Destroyer.hs view
@@ -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])
Git/FilePath.hs view
@@ -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 -}
Git/Filename.hs view
@@ -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
Git/Fsck.hs view
@@ -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
Git/HashObject.hs view
@@ -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. -
Git/Index.hs view
@@ -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"
Git/LsFiles.hs view
@@ -1,22 +1,24 @@ {- git ls-files interface -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} 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"
Git/LsTree.hs view
@@ -1,17 +1,17 @@ {- git ls-tree interface -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} -{-# 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
Git/Objects.hs view
@@ -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. -}
Git/Ref.hs view
@@ -1,6 +1,6 @@ {- git ref stuff -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,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
Git/Repair.hs view
@@ -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)
Git/Types.hs view
@@ -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
Git/UpdateIndex.hs view
@@ -1,6 +1,6 @@ {- git-update-index library -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -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"
Git/Version.hs view
@@ -14,7 +14,7 @@ GitVersion, ) where -import Common+import Utility.Process import Utility.DottedVersion type GitVersion = DottedVersion
Utility/Batch.hs view
@@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced. -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -10,6 +10,7 @@ module Utility.Batch ( batch, BatchCommandMaker,+ nonBatchCommandMaker, getBatchCommandMaker, toBatchCommand, batchCommand,@@ -22,7 +23,6 @@ import 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
Utility/Directory.hs view
@@ -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
+ Utility/Directory/Create.hs view
@@ -0,0 +1,102 @@+{- directory creating+ -+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Directory.Create (+ createDirectoryUnder,+ createDirectoryUnder',+) where++import Control.Monad+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.IfElse+import System.IO.Error+import Data.Maybe+import qualified System.FilePath.ByteString as P+import Prelude++import Utility.SystemDirectory+import Utility.Path.AbsRel+import Utility.Exception+import Utility.FileSystemEncoding+import qualified Utility.RawFilePath as R+import Utility.PartialPrelude++{- Like createDirectoryIfMissing True, but it will only create+ - missing parent directories up to but not including 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
Utility/DottedVersion.hs view
@@ -13,7 +13,7 @@ normalize, ) where -import Common+import Utility.Split data DottedVersion = DottedVersion String Integer deriving (Eq)
Utility/Env/Set.hs view
@@ -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)
Utility/Exception.hs view
@@ -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
Utility/FileMode.hs view
@@ -1,11 +1,12 @@ {- File mode utilities. -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileMode ( module Utility.FileMode,@@ -15,32 +16,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
Utility/FileSize.hs view
@@ -1,5 +1,7 @@ {- File size. -+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - - 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
Utility/FileSystemEncoding.hs view
@@ -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
Utility/Format.hs view
@@ -1,6 +1,6 @@ {- Formatted string handling. -- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - 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])
Utility/HumanTime.hs view
@@ -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
Utility/InodeCache.hs view
@@ -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
Utility/Metered.hs view
@@ -1,6 +1,6 @@ {- Metered IO and actions -- - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -9,8 +9,10 @@ module Utility.Metered ( MeterUpdate,+ MeterState(..), nullMeterUpdate, combineMeterUpdate,+ TotalSize(..), BytesProcessed(..), toBytesProcessed, fromBytesProcessed,@@ -29,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
+ Utility/MoveFile.hs view
@@ -0,0 +1,74 @@+{- moving files+ -+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.MoveFile (+ moveFile,+) where++import Control.Monad+import System.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
Utility/Path.hs view
@@ -1,63 +1,59 @@ {- path manipulation -- - Copyright 2010-2014 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path ( simplifyPath,- absPathFrom, parentDir, upFrom, dirContains,- absPath,- relPathCwdToFile,- relPathDirToFile,- relPathDirToFileAbs, segmentPaths,+ segmentPaths', runSegmentPaths,- relHome,+ 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
+ Utility/Path/AbsRel.hs view
@@ -0,0 +1,93 @@+{- absolute and relative path manipulation+ -+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Path.AbsRel (+ absPathFrom,+ absPath,+ relPathCwdToFile,+ relPathDirToFile,+ relPathDirToFileAbs,+ relHome,+) where++import System.FilePath.ByteString+#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
Utility/Process.hs view
@@ -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
Utility/QuickCheck.hs view
@@ -1,6 +1,6 @@ {- QuickCheck with additional instances -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - 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
Utility/RawFilePath.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2019-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.RawFilePath ( RawFilePath, readSymbolicLink,+ createSymbolicLink,+ createLink,+ removeLink, getFileStatus, getSymbolicLinkStatus, doesPathExist,+ getCurrentDirectory,+ createDirectory,+ setFileMode, ) 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
Utility/Rsync.hs view
@@ -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'
Utility/SafeCommand.hs view
@@ -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.
+ Utility/SimpleProtocol.hs view
@@ -0,0 +1,151 @@+{- Simple line-based protocols.+ -+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Utility.SimpleProtocol (+ Sendable(..),+ Receivable(..),+ parseMessage,+ Serializable(..),+ Parser,+ parseFail,+ parse0,+ parse1,+ parse2,+ parse3,+ parse4,+ parse5,+ dupIoHandles,+ getProtocolLine,+) where++import Data.Char+import GHC.IO.Handle+import Text.Read++import Common++-- Messages that can be sent.+class Sendable m where+ formatMessage :: m -> [String]++-- Messages that can be received.+class Receivable m where+ -- Passed the first word of the message, returns+ -- a Parser that can be be fed the rest of the message to generate+ -- the value.+ parseCommand :: String -> Parser m++parseMessage :: (Receivable m) => String -> Maybe m+parseMessage s = parseCommand command rest+ where+ (command, rest) = splitWord s++class Serializable a where+ serialize :: a -> String+ deserialize :: String -> Maybe a++instance Serializable [Char] where+ serialize = id+ deserialize = Just++instance Serializable Integer where+ serialize = show+ deserialize = readMaybe++instance Serializable ExitCode where+ serialize ExitSuccess = "0"+ serialize (ExitFailure n) = show n+ deserialize "0" = Just ExitSuccess+ deserialize s = ExitFailure <$> readMaybe s++{- Parsing the parameters of messages. Using the right parseN ensures+ - that the string is split into exactly the requested number of words,+ - which allows the last parameter of a message to contain arbitrary+ - whitespace, etc, without needing any special quoting.+ -}+type Parser a = String -> Maybe a++parseFail :: Parser a+parseFail _ = Nothing++parse0 :: a -> Parser a+parse0 mk "" = Just mk+parse0 _ _ = Nothing++parse1 :: Serializable p1 => (p1 -> a) -> Parser a+parse1 mk p1 = mk <$> deserialize p1++parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a+parse2 mk s = mk <$> deserialize p1 <*> deserialize p2+ where+ (p1, p2) = splitWord s++parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a+parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3+ where+ (p1, rest) = splitWord s+ (p2, p3) = splitWord rest++parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a+parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4+ where+ (p1, rest) = splitWord s+ (p2, rest') = splitWord rest+ (p3, p4) = splitWord rest'++parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a+parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5+ where+ (p1, rest) = splitWord s+ (p2, rest') = splitWord rest+ (p3, rest'') = splitWord rest'+ (p4, p5) = splitWord rest''++splitWord :: String -> (String, String)+splitWord = separate isSpace++{- When a program speaks a simple protocol over stdio, any other output+ - to stdout (or anything that attempts to read from stdin)+ - will mess up the protocol. To avoid that, close stdin,+ - and duplicate stderr to stdout. Return two new handles+ - that are duplicates of the original (stdin, stdout). -}+dupIoHandles :: IO (Handle, Handle)+dupIoHandles = do+ readh <- hDuplicate stdin+ writeh <- hDuplicate stdout+ nullh <- openFile devNull ReadMode+ nullh `hDuplicateTo` stdin+ stderr `hDuplicateTo` stdout+ return (readh, writeh)++{- Reads a line, but to avoid super-long lines eating memory, returns+ - Nothing if 32 kb have been read without seeing a '\n'+ -+ - If there is a '\r' before the '\n', it is removed, to support+ - systems using "\r\n" at ends of lines + -+ - This implementation is not super efficient, but as long as the Handle+ - supports buffering, it avoids reading a character at a time at the+ - syscall level.+ -+ - Throws isEOFError when no more input is available.+ -}+getProtocolLine :: Handle -> IO (Maybe String)+getProtocolLine h = go (32768 :: Int) []+ where+ go 0 _ = return Nothing+ go n l = do+ c <- hGetChar h+ if c == '\n'+ then return $ Just $ reverse $ + case l of+ ('\r':rest) -> rest+ _ -> l+ else go (n-1) (c:l)
Utility/Tmp.hs view
@@ -1,6 +1,6 @@ {- Temporary files. -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -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
git-repair.cabal view
@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20200504+Version: 1.20210111 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net>@@ -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
git-repair.hs view
@@ -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