From ad48349741384ed0e49fab9cf13ac7f90aba0dd1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 21:52:32 -0400 Subject: Merge from git-annex. --- Utility/Batch.hs | 28 +--- Utility/Directory.hs | 142 +----------------- Utility/Directory/Create.hs | 102 +++++++++++++ Utility/DottedVersion.hs | 2 +- Utility/Env/Set.hs | 6 + Utility/Exception.hs | 2 +- Utility/FileMode.hs | 47 +++--- Utility/FileSize.hs | 14 +- Utility/FileSystemEncoding.hs | 9 +- Utility/Format.hs | 46 ++++-- Utility/HumanTime.hs | 11 +- Utility/InodeCache.hs | 6 +- Utility/Metered.hs | 174 ++++++++++++++-------- Utility/MoveFile.hs | 74 ++++++++++ Utility/Path.hs | 244 ++++++++++-------------------- Utility/Path/AbsRel.hs | 93 ++++++++++++ Utility/Process.hs | 337 +++++++++++++++++++++--------------------- Utility/QuickCheck.hs | 41 ++++- Utility/RawFilePath.hs | 48 +++++- Utility/Rsync.hs | 6 +- Utility/SafeCommand.hs | 55 +------ Utility/SimpleProtocol.hs | 151 +++++++++++++++++++ Utility/Tmp.hs | 23 ++- 23 files changed, 980 insertions(+), 681 deletions(-) create mode 100644 Utility/Directory/Create.hs create mode 100644 Utility/MoveFile.hs create mode 100644 Utility/Path/AbsRel.hs create mode 100644 Utility/SimpleProtocol.hs (limited to 'Utility') diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 1d66881..58e326e 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced. - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Batch ( batch, BatchCommandMaker, + nonBatchCommandMaker, getBatchCommandMaker, toBatchCommand, batchCommand, @@ -22,7 +23,6 @@ import Common 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 @@ batch a = wait =<< batchthread batchthread = asyncBound $ do setProcessPriority 0 maxNice a + maxNice = 19 #else batch a = a #endif -maxNice :: Int -maxNice = 19 - {- Makes a command be run by whichever of nice, ionice, and nocache - are available in the path. -} type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) +nonBatchCommandMaker :: BatchCommandMaker +nonBatchCommandMaker = id + getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do #ifndef mingw32_HOST_OS @@ -75,11 +76,7 @@ toBatchCommand v = do return $ batchmaker v {- Runs a command in a way that's suitable for batch jobs that can be - - interrupted. - - - - If the calling thread receives an async exception, it sends the - - command a SIGTERM, and after the command finishes shuttting down, - - it re-raises the async exception. -} + - interrupted. -} batchCommand :: String -> [CommandParam] -> IO Bool batchCommand command params = batchCommandEnv command params Nothing @@ -87,13 +84,4 @@ batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bo batchCommandEnv command params environ = do batchmaker <- getBatchCommandMaker let (command', params') = batchmaker (command, params) - let p = proc command' $ toCommand params' - (_, _, _, pid) <- createProcess $ p { env = environ } - r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) - case r of - Right ExitSuccess -> return True - Right _ -> return False - Left asyncexception -> do - terminateProcess pid - void $ waitForProcess pid - E.throwIO asyncexception + boolSystemEnv command' params' environ diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 8b5b88b..38adf17 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,26 +16,16 @@ module Utility.Directory ( 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 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] =<< 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. +{- Use with an action that removes something, which may or may not exist. - - - 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. + - If an exception is thrown due to it not existing, it is ignored. -} -createDirectoryUnder :: FilePath -> FilePath -> IO () -createDirectoryUnder topdir dir = - createDirectoryUnder' topdir dir createDirectory - -createDirectoryUnder' - :: (MonadIO m, MonadCatch m) - => FilePath - -> FilePath - -> (FilePath -> m ()) - -> m () -createDirectoryUnder' topdir dir0 mkdir = do - p <- liftIO $ relPathDirToFile topdir dir0 - let dirs = splitDirectories p - -- Catch cases where the dir is not beneath the topdir. - -- If the relative path between them starts with "..", - -- it's not. And on Windows, if they are on different drives, - -- the path will not be relative. - if headMaybe dirs == Just ".." || isAbsolute p - then liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ topdir) - -- If dir0 is the same as the topdir, don't try to create - -- it, but make sure it does exist. - else if null dirs - then liftIO $ unlessM (doesDirectoryExist topdir) $ - ioError $ customerror doesNotExistErrorType - "createDirectoryFrom: does not exist" - else createdirs $ - map (topdir ) (reverse (scanl1 () dirs)) - where - customerror t s = mkIOError t s Nothing (Just dir0) - - createdirs [] = pure () - createdirs (dir:[]) = createdir dir (liftIO . ioError) - createdirs (dir:dirs) = createdir dir $ \_ -> do - createdirs dirs - createdir dir (liftIO . ioError) - - -- This is the same method used by createDirectoryIfMissing, - -- in particular the handling of errors that occur when the - -- directory already exists. See its source for explanation - -- of several subtleties. - createdir dir notexisthandler = tryIO (mkdir dir) >>= \case - Right () -> pure () - Left e - | isDoesNotExistError e -> notexisthandler e - | isAlreadyExistsError e || isPermissionError e -> - liftIO $ unlessM (doesDirectoryExist dir) $ - ioError e - | otherwise -> liftIO $ ioError e +removeWhenExistsWith :: (a -> IO ()) -> a -> IO () +removeWhenExistsWith f a = void $ tryWhenExists $ f a diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs new file mode 100644 index 0000000..32c0bcf --- /dev/null +++ b/Utility/Directory/Create.hs @@ -0,0 +1,102 @@ +{- directory creating + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Directory.Create ( + createDirectoryUnder, + createDirectoryUnder', +) where + +import Control.Monad +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.IfElse +import System.IO.Error +import Data.Maybe +import qualified System.FilePath.ByteString as P +import Prelude + +import Utility.SystemDirectory +import Utility.Path.AbsRel +import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R +import Utility.PartialPrelude + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, + - it will throw an exception. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - FilePath (or the same as it), it will fail with an exception + - even if the second FilePath's parent directory already exists. + - + - Either or both of the FilePaths can be relative, or absolute. + - They will be normalized as necessary. + - + - Note that, the second FilePath, if relative, is relative to the current + - working directory, not to the first FilePath. + -} +createDirectoryUnder :: RawFilePath -> RawFilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir R.createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => RawFilePath + -> RawFilePath + -> (RawFilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = P.splitDirectories p + -- Catch cases where the dir is not beneath the topdir. + -- If the relative path between them starts with "..", + -- it's not. And on Windows, if they are on different drives, + -- the path will not be relative. + if headMaybe dirs == Just ".." || P.isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ fromRawFilePath topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir P.) (reverse (scanl1 (P.) dirs)) + where + customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + createdir dir (liftIO . ioError) + + -- This is the same method used by createDirectoryIfMissing, + -- in particular the handling of errors that occur when the + -- directory already exists. See its source for explanation + -- of several subtleties. + createdir dir notexisthandler = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $ + ioError e + | otherwise -> liftIO $ ioError e diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index dff3717..84b8463 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -13,7 +13,7 @@ module Utility.DottedVersion ( normalize, ) where -import Common +import Utility.Split data DottedVersion = DottedVersion String Integer deriving (Eq) diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs index f14674c..45d2e7f 100644 --- a/Utility/Env/Set.hs +++ b/Utility/Env/Set.hs @@ -10,6 +10,7 @@ module Utility.Env.Set ( setEnv, unsetEnv, + legalInEnvVar, ) where #ifdef mingw32_HOST_OS @@ -18,6 +19,7 @@ import Utility.Env #else import qualified System.Posix.Env as PE #endif +import Data.Char {- Sets an environment variable. To overwrite an existing variable, - overwrite must be True. @@ -41,3 +43,7 @@ unsetEnv = PE.unsetEnv #else unsetEnv = System.SetEnv.unsetEnv #endif + +legalInEnvVar :: Char -> Bool +legalInEnvVar '_' = True +legalInEnvVar c = isAsciiLower c || isAsciiUpper c || (isNumber c && isAscii c) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index bcadb78..273f844 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -39,7 +39,7 @@ import Utility.Data {- Like error, this throws an exception. Unlike error, if this exception - is not caught, it won't generate a backtrace. So use this for situations - - where there's a problem that the user is excpected to see in some + - where there's a problem that the user is expeected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 7d36c55..6725601 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,11 +1,12 @@ {- File mode utilities. - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileMode ( module Utility.FileMode, @@ -15,32 +16,30 @@ module Utility.FileMode ( 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 @@ otherGroupModes = ] {- Removes the write bits from a file. -} -preventWrite :: FilePath -> IO () +preventWrite :: RawFilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: FilePath -> IO () +allowWrite :: RawFilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: FilePath -> IO () +allowRead :: RawFilePath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -91,20 +90,12 @@ groupSharedModes = , ownerReadMode, groupReadMode ] -groupWriteRead :: FilePath -> IO () +groupWriteRead :: RawFilePath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor -{- Checks if a file mode indicates it's a symlink. -} -isSymLink :: FileMode -> Bool -#ifdef mingw32_HOST_OS -isSymLink _ = False -#else -isSymLink = checkMode symbolicLinkMode -#endif - {- Checks if a file has any executable bits set. -} isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 @@ -160,7 +151,7 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -setSticky :: FilePath -> IO () +setSticky :: RawFilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -173,13 +164,13 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: FilePath -> String -> IO () +writeFileProtected :: RawFilePath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = protectedOutput $ - withFile file WriteMode $ \h -> do + withFile (fromRawFilePath file) WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 8544ad4..a503fda 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -1,4 +1,6 @@ {- File size. + - + - Copyright 2015-2020 Joey Hess - - License: BSD-2-clause -} @@ -12,10 +14,12 @@ module Utility.FileSize ( 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 @@ type FileSize = Integer - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: FilePath -> IO FileSize +getFileSize :: R.RawFilePath -> IO FileSize #ifndef mingw32_HOST_OS -getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) +getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f) #else -getFileSize f = bracket (openFile f ReadMode) hClose hFileSize +getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize #endif {- Gets the size of the file, when its FileStatus is already known. - - On windows, uses getFileSize. Otherwise, the FileStatus contains the - size, so this does not do any work. -} -getFileSize' :: FilePath -> FileStatus -> IO FileSize +getFileSize' :: R.RawFilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 4c099ff..1f7c76b 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -36,17 +36,18 @@ import Foreign.C import System.IO import System.IO.Unsafe import Data.Word -import Data.List +import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #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 @@ fromRawFilePath = decodeFilePath 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 :: FilePath -> [Word8] decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where nul = '\NUL' +#endif c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum diff --git a/Utility/Format.hs b/Utility/Format.hs index a2470fa..466988c 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,6 +1,6 @@ {- Formatted string handling. - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ module Utility.Format ( Format, gen, format, + formatContainsVar, decode_c, encode_c, + encode_c', prop_encode_c_decode_c_roundtrip ) where @@ -29,9 +31,14 @@ type FormatString = String {- 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 :: Format -> Variables -> String format f vars = concatMap expand f where expand (Const s) = s - expand (Var name j) - | "escaped_" `isPrefixOf` name = - justify j $ encode_c_strict $ - getvar $ drop (length "escaped_") name + expand (Var name j esc) + | esc = justify j $ 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 f vars = concatMap expand f - 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 @@ gen = filter (not . empty) . fuse [] . scan [] . decode_c | i < 0 = LeftJustified (-1 * i) | otherwise = RightJustified i novar v = "${" ++ reverse v - foundvar f v p = scan (Var (reverse v) p : f) + foundvar f varname_r p = + let varname = reverse varname_r + var = if "escaped_" `isPrefixOf` varname + then Var (drop (length "escaped_") varname) p True + else Var varname p False + in scan (var : f) empty :: Frag -> Bool empty (Const "") = True empty _ = False +{- Check if a Format contains a variable with a specified name. -} +formatContainsVar :: String -> Format -> Bool +formatContainsVar v = any go + where + go (Var v' _ _) | v' == v = True + go _ = False + {- Decodes a C-style encoding, where \n is a newline (etc), - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} @@ -144,10 +163,7 @@ decode_c s = unescape ("", s) 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 @@ encode_c' p = concatMap echar | ord c < 0x20 = e_asc c -- low ascii | ord c >= 256 = e_utf c -- unicode | ord c > 0x7E = e_asc c -- high ascii - | p c = e_asc c -- unprintable ascii - | otherwise = [c] -- printable ascii + | p c = e_asc c + | otherwise = [c] -- unicode character is decomposed to individual Word8s, -- and each is shown in octal e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index d90143e..5178531 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,7 +19,6 @@ module Utility.HumanTime ( 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 :: Integer -> Duration daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: MonadFail m => String -> m Duration -parseDuration = maybe parsefail (return . Duration) . go 0 +parseDuration :: String -> Either String Duration +parseDuration d + | null d = parsefail + | otherwise = maybe parsefail (Right . Duration) $ go 0 d where go n [] = return n go n s = do @@ -56,7 +57,7 @@ parseDuration = maybe parsefail (return . Duration) . go 0 u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = Fail.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 @@ instance Arbitrary Duration where arbitrary = Duration <$> nonNegative arbitrary prop_duration_roundtrips :: Duration -> Bool -prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d +prop_duration_roundtrips d = parseDuration (fromDuration d) == Right d diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index d890fc7..74c6dff 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -186,15 +186,15 @@ readInodeCache s = case words s of genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + toInodeCache delta f =<< R.getFileStatus f -toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s #ifdef mingw32_HOST_OS - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else let mtime = modificationTimeHiRes s #endif diff --git a/Utility/Metered.hs b/Utility/Metered.hs index ec16e33..1715f0b 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2018 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ module Utility.Metered ( MeterUpdate, + MeterState(..), nullMeterUpdate, combineMeterUpdate, + TotalSize(..), BytesProcessed(..), toBytesProcessed, fromBytesProcessed, @@ -29,6 +31,8 @@ module Utility.Metered ( ProgressParser, commandMeter, commandMeter', + commandMeterExitCode, + commandMeterExitCode', demeterCommand, demeterCommandEnv, avoidProgress, @@ -46,6 +50,7 @@ import Common 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 @@ combineMeterUpdate a b = \n -> a n >> b n {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed @@ -165,8 +170,9 @@ hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do - hClose h - return $ L.empty + when (wantsize /= Just 0) $ + hClose h + return L.empty else do let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' @@ -218,7 +224,8 @@ watchFileSize f p a = bracket p sz watcher sz getsz = catchDefaultIO zeroBytesProcessed $ - toBytesProcessed <$> getFileSize f + toBytesProcessed <$> getFileSize f' + f' = toRawFilePath f data OutputHandler = OutputHandler { quietMode :: Bool @@ -226,31 +233,45 @@ data OutputHandler = OutputHandler } {- Parses the String looking for a command's progress output, and returns - - Maybe the number of bytes done so far, and any any remainder of the - - string that could be an incomplete progress output. That remainder - - should be prepended to future output, and fed back in. This interface - - allows the command's output to be read in any desired size chunk, or - - even one character at a time. + - Maybe the number of bytes done so far, optionally a total size, + - and any any remainder of the string that could be an incomplete + - progress output. That remainder should be prepended to future output, + - and fed back in. This interface allows the command's output to be read + - in any desired size chunk, or even one character at a time. -} -type ProgressParser = String -> (Maybe BytesProcessed, String) +type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) + +newtype TotalSize = TotalSize Integer + deriving (Show, Eq) {- Runs a command and runs a ProgressParser on its output, in order - to update a meter. + - + - If the Meter is provided, the ProgressParser can report the total size, + - which allows creating a Meter before the size is known. -} -commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool -commandMeter progressparser oh meterupdate cmd params = do - ret <- commandMeter' progressparser oh meterupdate cmd params +commandMeter :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meter meterupdate cmd params = + commandMeter' progressparser oh meter meterupdate cmd params id + +commandMeter' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +commandMeter' progressparser oh meter meterupdate cmd params mkprocess = do + ret <- commandMeterExitCode' progressparser oh meter meterupdate cmd params mkprocess return $ case ret of Just ExitSuccess -> True _ -> False -commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) -commandMeter' progressparser oh meterupdate cmd params = - outputFilter cmd params Nothing - (feedprogress zeroBytesProcessed []) +commandMeterExitCode :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) +commandMeterExitCode progressparser oh meter meterupdate cmd params = + commandMeterExitCode' progressparser oh meter meterupdate cmd params id + +commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode) +commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = + outputFilter cmd params mkprocess Nothing + (const $ feedprogress mmeter zeroBytesProcessed []) handlestderr where - feedprogress prev buf h = do + feedprogress sendtotalsize prev buf h = do b <- S.hGetSome h 80 if S.null b then return () @@ -259,17 +280,24 @@ commandMeter' progressparser oh meterupdate cmd params = S.hPut stdout b hFlush stdout let s = decodeBS b - let (mbytes, buf') = progressparser (buf++s) + let (mbytes, mtotalsize, buf') = progressparser (buf++s) + sendtotalsize' <- case (sendtotalsize, mtotalsize) of + (Just meter, Just t) -> do + setMeterTotalSize meter t + return Nothing + _ -> return sendtotalsize case mbytes of - Nothing -> feedprogress prev buf' h + Nothing -> feedprogress sendtotalsize' prev buf' h (Just bytes) -> do when (bytes /= prev) $ meterupdate bytes - feedprogress bytes buf' h + feedprogress sendtotalsize' bytes buf' h - handlestderr h = unlessM (hIsEOF h) $ do - stderrHandler oh =<< hGetLine h - handlestderr h + handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case + Just l -> do + stderrHandler oh l + handlestderr ph h + Nothing -> return () {- Runs a command, that may display one or more progress meters on - either stdout or stderr, and prevents the meters from being displayed. @@ -281,9 +309,9 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool demeterCommandEnv oh cmd params environ = do - ret <- outputFilter cmd params environ - (\outh -> avoidProgress True outh stdouthandler) - (\errh -> avoidProgress True errh $ stderrHandler oh) + ret <- outputFilter cmd params id environ + (\ph outh -> avoidProgress True ph outh stdouthandler) + (\ph errh -> avoidProgress True ph errh $ stderrHandler oh) return $ case ret of Just ExitSuccess -> True _ -> False @@ -296,31 +324,39 @@ demeterCommandEnv oh cmd params environ = do - 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 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do return $ mu lastupdate where mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case - Just t | i >= t -> meterupdate n + Just (TotalSize t) | i >= t -> meterupdate n _ -> do now <- getPOSIXTime prev <- takeMVar lastupdate @@ -343,33 +379,39 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do 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 - -setMeterTotalSize :: Meter -> Integer -> IO () +mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = do + ts <- getPOSIXTime + Meter + <$> newMVar totalsize + <*> newMVar (MeterState zeroBytesProcessed ts) + <*> newMVar "" + <*> pure displaymeter + +setMeterTotalSize :: Meter -> TotalSize -> IO () setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just -- | Updates the meter, displaying it if necessary. updateMeter :: Meter -> MeterUpdate updateMeter (Meter totalsizev sv bv displaymeter) new = do now <- getPOSIXTime - (old, before) <- swapMVar sv (new, now) - when (old /= new) $ do + let curms = MeterState new now + oldms <- swapMVar sv curms + when (meterBytesProcessed oldms /= new) $ do totalsize <- readMVar totalsizev - displaymeter bv totalsize (old, before) (new, now) + displaymeter bv totalsize oldms curms -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter @@ -394,7 +436,7 @@ clearMeterHandle (Meter _ _ v _) h = do -- or when total size is not known: -- 1.3 MiB 300 KiB/s bandwidthMeter :: RenderMeter -bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = +bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState (BytesProcessed new) now) = unwords $ catMaybes [ Just percentamount -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s" @@ -405,7 +447,7 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) 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 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) transferred = max 0 (new - old) duration = max 0 (now - before) estimatedcompletion = case mtotalsize of - Just totalsize + Just (TotalSize totalsize) | bytespersecond > 0 -> Just $ fromDuration $ Duration $ (totalsize - new) `div` bytespersecond _ -> Nothing + +instance Proto.Serializable BytesProcessed where + serialize (BytesProcessed n) = show n + deserialize = BytesProcessed <$$> readish diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs new file mode 100644 index 0000000..3ea17e8 --- /dev/null +++ b/Utility/MoveFile.hs @@ -0,0 +1,74 @@ +{- moving files + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.MoveFile ( + moveFile, +) where + +import Control.Monad +import System.FilePath +import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error +import Prelude + +#ifndef mingw32_HOST_OS +import Control.Monad.IfElse +import Utility.SafeCommand +#endif + +import Utility.SystemDirectory +import Utility.Tmp +import Utility.Exception +import Utility.Monad + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = viaTmp mv dest () + where + rethrow = throwM e + + mv tmp () = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + throwM e' + +#ifndef mingw32_HOST_OS + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s +#endif diff --git a/Utility/Path.hs b/Utility/Path.hs index a8ab918..6bd407e 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,63 +1,59 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path ( simplifyPath, - absPathFrom, parentDir, upFrom, dirContains, - absPath, - relPathCwdToFile, - relPathDirToFile, - relPathDirToFileAbs, segmentPaths, + segmentPaths', runSegmentPaths, - relHome, + runSegmentPaths', inPath, searchPath, dotfile, - sanitizeFilePath, splitShortExtensions, - - prop_upFrom_basics, - prop_relPathDirToFile_basics, - prop_relPathDirToFile_regressionTest, + relPathDirToFileAbs, ) where -import System.FilePath +import System.FilePath.ByteString +import qualified System.FilePath as P +import qualified Data.ByteString as B import Data.List import Data.Maybe -import Data.Char import Control.Applicative import Prelude import Utility.Monad -import Utility.UserInfo import Utility.SystemDirectory -import Utility.Split + +#ifdef mingw32_HOST_OS +import Data.Char import Utility.FileSystemEncoding +#endif {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. - - On Windows, preserves whichever style of path separator might be used in - - the input FilePaths. This is done because some programs in Windows + - the input RawFilePaths. This is done because some programs in Windows - demand a particular path separator -- and which one actually varies! - - This does not guarantee that two paths that refer to the same location, - and are both relative to the same location (or both absolute) will - - yeild the same result. Run both through normalise from System.FilePath + - yeild the same result. Run both through normalise from System.RawFilePath - to ensure that. -} -simplifyPath :: FilePath -> FilePath +simplifyPath :: RawFilePath -> RawFilePath simplifyPath path = dropTrailingPathSeparator $ joinDrive drive $ joinPath $ norm [] $ splitPath path' where @@ -72,134 +68,37 @@ simplifyPath path = dropTrailingPathSeparator $ 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 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - 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 @@ inPath command = isJust <$> searchPath command -} searchPath :: String -> IO (Maybe FilePath) searchPath command - | isAbsolute command = check command - | otherwise = getSearchPath >>= getM indir + | P.isAbsolute command = check command + | otherwise = P.getSearchPath >>= getM indir where - indir d = check $ d command + indir d = check $ d P. command check f = firstM doesFileExist #ifdef mingw32_HOST_OS [f, f ++ ".exe"] @@ -267,42 +165,52 @@ searchPath command {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} -dotfile :: FilePath -> Bool +dotfile :: RawFilePath -> Bool dotfile file | f == "." = False | f == ".." = False | f == "" = False - | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file -{- Given a string that we'd like to use as the basis for FilePath, but that - - was provided by a third party and is not to be trusted, returns the closest - - sane FilePath. - - - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' - - "../" will thus turn into ".._", which is safe. - -} -sanitizeFilePath :: String -> FilePath -sanitizeFilePath = map sanitize - where - sanitize c - | c == '.' = c - | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' - | otherwise = c - -{- Similar to splitExtensions, but knows that some things in FilePaths +{- Similar to splitExtensions, but knows that some things in RawFilePaths - after a dot are too long to be extensions. -} -splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" -splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions' maxextension = go [] where go c f - | len > 0 && len <= maxextension && not (null base) = + | len > 0 && len <= maxextension && not (B.null base) = go (ext:c) base | otherwise = (f, c) where (base, ext) = splitExtension f - len = length ext + len = B.length ext + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ + - + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. + -} +relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath +relPathDirToFileAbs from to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif + | otherwise = joinPath $ dotdots ++ uncommon + where + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath . dropDrive + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive +#endif diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs new file mode 100644 index 0000000..0026bd6 --- /dev/null +++ b/Utility/Path/AbsRel.hs @@ -0,0 +1,93 @@ +{- absolute and relative path manipulation + - + - Copyright 2010-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path.AbsRel ( + absPathFrom, + absPath, + relPathCwdToFile, + relPathDirToFile, + relPathDirToFileAbs, + relHome, +) where + +import System.FilePath.ByteString +#ifdef mingw32_HOST_OS +import System.Directory (getCurrentDirectory) +#else +import System.Posix.Directory.ByteString (getWorkingDirectory) +#endif +import Control.Applicative +import Prelude + +import Utility.Path +import Utility.UserInfo +import Utility.FileSystemEncoding + +{- Makes a path absolute. + - + - Also simplifies it using simplifyPath. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute, and should itsef be absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath +absPathFrom dir path = simplifyPath (combine dir path) + +{- Converts a filename into an absolute path. + - + - Also simplifies it using simplifyPath. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: RawFilePath -> IO RawFilePath +absPath file + -- Avoid unncessarily getting the current directory when the path + -- is already absolute. absPathFrom uses simplifyPath + -- so also used here for consistency. + | isAbsolute file = return $ simplifyPath file + | otherwise = do +#ifdef mingw32_HOST_OS + cwd <- toRawFilePath <$> getCurrentDirectory +#else + cwd <- getWorkingDirectory +#endif + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: RawFilePath -> IO RawFilePath +relPathCwdToFile f = do +#ifdef mingw32_HOST_OS + c <- toRawFilePath <$> getCurrentDirectory +#else + c <- getWorkingDirectory +#endif + relPathDirToFile c f + +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + let path' = toRawFilePath path + home <- toRawFilePath <$> myHomeDir + return $ if dirContains home path' + then fromRawFilePath ("~/" <> relPathDirToFileAbs home path') + else path diff --git a/Utility/Process.hs b/Utility/Process.hs index e7142b9..4a725c8 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -6,12 +6,11 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, Rank2Types #-} +{-# LANGUAGE CPP, Rank2Types, LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, - CreateProcess(..), StdHandle(..), readProcess, readProcess', @@ -20,64 +19,55 @@ module Utility.Process ( forceSuccessProcess, forceSuccessProcess', checkSuccessProcess, - ignoreFailureProcess, - createProcessSuccess, - createProcessChecked, - createBackgroundProcess, - withHandle, - withIOHandles, - withOEHandles, withNullHandle, - withQuietOutput, - feedWithQuietOutput, createProcess, + withCreateProcess, waitForProcess, + cleanupProcess, + hGetLineUntilExitOrEOF, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, - ioHandles, processHandle, 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 @@ writeReadProcessEnv -> 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,6 +85,18 @@ writeReadProcessEnv cmd args environ writestdin = do , std_err = Inherit , env = environ } + + go (Just inh) (Just outh) _ pid = do + let reader = hClose outh `after` S.hGetContents outh + let writer = do + maybe (return ()) (\a -> a inh >> hFlush inh) writestdin + hClose inh + (output, ()) <- concurrently reader writer + + forceSuccessProcess p pid + + return output + go _ _ _ _ = error "internal" -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. @@ -126,117 +109,15 @@ forceSuccessProcess' p (ExitFailure n) = fail $ showCmd p ++ " exited " ++ show n -- | Waits for a ProcessHandle and returns True if it exited successfully. --- Note that using this with createProcessChecked will throw away --- the Bool, and is only useful to ignore the exit code of a process, --- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid return $ code == ExitSuccess -ignoreFailureProcess :: ProcessHandle -> IO Bool -ignoreFailureProcess pid = do - void $ waitForProcess pid - return True - --- | Runs createProcess, then an action on its handles, and then --- forceSuccessProcess. -createProcessSuccess :: CreateProcessRunner -createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a - --- | Runs createProcess, then an action on its handles, and then --- a checker action on its exit code, which must wait for the process. -createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner -createProcessChecked checker p a = do - t@(_, _, _, pid) <- createProcess p - r <- tryNonAsync $ a t - _ <- checker pid - either E.throw return r - --- | Leaves the process running, suitable for lazy streaming. --- Note: Zombies will result, and must be waited on. -createBackgroundProcess :: CreateProcessRunner -createBackgroundProcess p a = a =<< createProcess p - --- | Runs a CreateProcessRunner, on a CreateProcess structure, that --- is adjusted to pipe only from/to a single StdHandle, and passes --- the resulting Handle to an action. -withHandle - :: StdHandle - -> CreateProcessRunner - -> CreateProcess - -> (Handle -> IO a) - -> IO a -withHandle h creator p a = creator p' $ a . select - where - base = p - { std_in = Inherit - , std_out = Inherit - , std_err = Inherit - } - (select, p') = case h of - StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) - StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) - StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) - --- | Like withHandle, but passes (stdin, stdout) handles to the action. -withIOHandles - :: CreateProcessRunner - -> CreateProcess - -> ((Handle, Handle) -> IO a) - -> IO a -withIOHandles creator p a = creator p' $ a . ioHandles - where - p' = p - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - } - --- | Like withHandle, but passes (stdout, stderr) handles to the action. -withOEHandles - :: CreateProcessRunner - -> CreateProcess - -> ((Handle, Handle) -> IO a) - -> IO a -withOEHandles creator p a = creator p' $ a . oeHandles - where - p' = p - { std_in = Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - -withNullHandle :: (Handle -> IO a) -> IO a -withNullHandle = withFile devNull WriteMode - --- | Forces the CreateProcessRunner to run quietly; --- both stdout and stderr are discarded. -withQuietOutput - :: CreateProcessRunner - -> CreateProcess - -> IO () -withQuietOutput creator p = withNullHandle $ \nullh -> do - let p' = p - { std_out = UseHandle nullh - , std_err = UseHandle nullh - } - creator p' $ const $ return () - --- | Stdout and stderr are discarded, while the process is fed stdin --- from the handle. -feedWithQuietOutput - :: CreateProcessRunner - -> CreateProcess - -> (Handle -> IO a) - -> IO a -feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do - let p' = p - { std_in = CreatePipe - , std_out = UseHandle nullh - , std_err = UseHandle nullh - } - creator p' $ a . stdinHandle +withNullHandle :: (MonadIO m, MonadMask m) => (Handle -> m a) -> m a +withNullHandle = bracket + (liftIO $ openFile devNull WriteMode) + (liftIO . hClose) devNull :: FilePath #ifndef mingw32_HOST_OS @@ -252,6 +133,7 @@ devNull = "\\\\.\\NUL" -- Get it wrong and the runtime crash will always happen, so should be -- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle + stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h stdinHandle _ = error "expected stdinHandle" @@ -261,12 +143,6 @@ stdoutHandle _ = error "expected stdoutHandle" stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" -ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -ioHandles (Just hin, Just hout, _, _) = (hin, hout) -ioHandles _ = error "expected ioHandles" -oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -oeHandles (_, Just hout, Just herr, _) = (hout, herr) -oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid @@ -298,15 +174,24 @@ startInteractiveProcess cmd args environ = do -- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do - debugProcess p - Utility.Process.Shim.createProcess p + r@(_, _, _, h) <- Utility.Process.Shim.createProcess p + debugProcess p h + return r + +-- | Wrapper around 'System.Process.withCreateProcess' that does debug logging. +withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a +withCreateProcess p action = bracket (createProcess p) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) -- | Debugging trace for a CreateProcess. -debugProcess :: CreateProcess -> IO () -debugProcess p = debugM "Utility.Process" $ unwords - [ action ++ ":" - , showCmd p - ] +debugProcess :: CreateProcess -> ProcessHandle -> IO () +debugProcess p h = do + pid <- getPid h + debugM "Utility.Process" $ unwords + [ describePid pid + , action ++ ":" + , showCmd p + ] where action | piped (std_in p) && piped (std_out p) = "chat" @@ -316,9 +201,121 @@ debugProcess p = debugM "Utility.Process" $ unwords piped Inherit = False piped _ = True +describePid :: Maybe Utility.Process.Shim.Pid -> String +describePid Nothing = "process" +describePid (Just p) = "process [" ++ show p ++ "]" + -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess h = do + -- Have to get pid before waiting, which closes the ProcessHandle. + pid <- getPid h r <- Utility.Process.Shim.waitForProcess h - debugM "Utility.Process" ("process done " ++ show r) + debugM "Utility.Process" (describePid pid ++ " done " ++ show r) return r + +cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +#if MIN_VERSION_process(1,6,4) +cleanupProcess = Utility.Process.Shim.cleanupProcess +#else +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do + -- Unlike the real cleanupProcess, this does not wait + -- for the process to finish in the background, so if + -- the process ignores SIGTERM, this can block until the process + -- gets around the exiting. + terminateProcess pid + let void _ = return () + maybe (return ()) (void . tryNonAsync . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + void $ waitForProcess pid +#endif + +{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of + - file is reached, or the handle is closed, or if the process has exited + - and there is nothing more buffered to read from the handle. + - + - This is useful to protect against situations where the process might + - have transferred the handle being read to another process, and so + - the handle could remain open after the process has exited. That is a rare + - situation, but can happen. Consider a the process that started up a + - daemon, and the daemon inherited stderr from it, rather than the more + - usual behavior of closing the file descriptor. Reading from stderr + - would block past the exit of the process. + - + - In that situation, this will detect when the process has exited, + - and avoid blocking forever. But will still return anything the process + - buffered to the handle before exiting. + - + - Note on newline mode: This ignores whatever newline mode is configured + - for the handle, because there is no way to query that. On Windows, + - it will remove any \r coming before the \n. On other platforms, + - it does not treat \r specially. + -} +hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String) +hGetLineUntilExitOrEOF ph h = go [] + where + go buf = do + ready <- waitforinputorerror smalldelay + if ready + then getloop buf go + else getProcessExitCode ph >>= \case + -- Process still running, wait longer. + Nothing -> go buf + -- Process is done. It's possible + -- that it output something and exited + -- since the prior hWaitForInput, + -- so check one more time for any buffered + -- output. + Just _ -> finalcheck buf + + finalcheck buf = do + ready <- waitforinputorerror 0 + if ready + then getloop buf finalcheck + -- No remaining buffered input, though the handle + -- may not be EOF if something else is keeping it + -- open. Treated the same as EOF. + else eofwithnolineend buf + + -- On exception, proceed as if there was input; + -- EOF and any encoding issues are dealt with + -- when reading from the handle. + waitforinputorerror t = hWaitForInput h t + `catchNonAsync` const (pure True) + + getchar = + catcherr EOF $ + -- If the handle is closed, reading from it is + -- an IllegalOperation. + catcherr IllegalOperation $ + Just <$> hGetChar h + where + catcherr t = catchIOErrorType t (const (pure Nothing)) + + getloop buf cont = + getchar >>= \case + Just c + | c == '\n' -> return (Just (gotline buf)) + | otherwise -> cont (c:buf) + Nothing -> eofwithnolineend buf + +#ifndef mingw32_HOST_OS + gotline buf = reverse buf +#else + gotline ('\r':buf) = reverse buf + gotline buf = reverse buf +#endif + + eofwithnolineend buf = return $ + if null buf + then Nothing -- no line read + else Just (reverse buf) + + -- Tenth of a second delay. If the process exits with the FD being + -- held open, will wait up to twice this long before returning. + -- This delay could be made smaller. However, that is an unusual + -- case, and making it too small would cause lots of wakeups while + -- waiting for output. Bearing in mind that this could be run on + -- many processes at the same time. + smalldelay = 100 -- milliseconds diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index b0a39f3..2093670 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,16 +10,53 @@ 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 arbitrary = do diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index 6a5f704..f32b226 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,4 +1,4 @@ -{- Portability shim around System.Posix.Files.ByteString +{- Portability shim for basic operations on RawFilePaths. - - On unix, this makes syscalls using RawFilesPaths as efficiently as - possible. @@ -7,38 +7,69 @@ - decoded. So this library will work, but less efficiently than using - FilePath would. - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.RawFilePath ( RawFilePath, readSymbolicLink, + createSymbolicLink, + createLink, + removeLink, getFileStatus, getSymbolicLinkStatus, doesPathExist, + getCurrentDirectory, + createDirectory, + setFileMode, ) where #ifndef mingw32_HOST_OS import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString +import qualified System.Posix.Directory.ByteString as D +-- | Checks if a file or directory exists. Note that a dangling symlink +-- will be false. doesPathExist :: RawFilePath -> IO Bool doesPathExist = fileExist +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = D.getWorkingDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory p = D.createDirectory p 0o777 + #else -import qualified Data.ByteString as B -import System.PosixCompat (FileStatus) +import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P +import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) +createSymbolicLink :: RawFilePath -> RawFilePath -> IO () +createSymbolicLink a b = P.createSymbolicLink + (fromRawFilePath a) + (fromRawFilePath b) + +createLink :: RawFilePath -> RawFilePath -> IO () +createLink a b = P.createLink + (fromRawFilePath a) + (fromRawFilePath b) + +{- On windows, removeLink is not available, so only remove files, + - not symbolic links. -} +removeLink :: RawFilePath -> IO () +removeLink = D.removeFile . fromRawFilePath + getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath @@ -47,4 +78,13 @@ getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath doesPathExist :: RawFilePath -> IO Bool doesPathExist = D.doesPathExist . fromRawFilePath + +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory = D.createDirectory . fromRawFilePath + +setFileMode :: RawFilePath -> FileMode -> IO () +setFileMode = F.setFileMode . fromRawFilePath #endif diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index c6881b7..e377eb9 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -114,7 +114,7 @@ rsyncUrlIsPath s -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress oh meter ps = - commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case + commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case Just ExitSuccess -> return True Just (ExitFailure exitcode) -> do when (exitcode /= 1) $ @@ -136,10 +136,10 @@ rsyncProgress oh meter ps = parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks where - go remainder [] = (Nothing, remainder) + go remainder [] = (Nothing, Nothing, remainder) go remainder (x:xs) = case parsebytes (findbytesstart x) of Nothing -> go (delim:x++remainder) xs - Just b -> (Just (toBytesProcessed b), remainder) + Just b -> (Just (toBytesProcessed b), Nothing, remainder) delim = '\r' diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 19d5f20..6f9419c 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -16,18 +16,13 @@ module Utility.SafeCommand ( safeSystem, safeSystem', safeSystemEnv, - shellWrap, - shellEscape, - shellUnEscape, segmentXargsOrdered, segmentXargsUnordered, - prop_isomorphic_shellEscape, - prop_isomorphic_shellEscape_multiword, ) where -import System.Exit import Utility.Process -import Utility.Split + +import System.Exit import System.FilePath import Data.Char import Data.List @@ -61,6 +56,8 @@ toCommand' (File s) = s -- | Run a system command, and returns True or False if it succeeded or failed. -- +-- (Throws an exception if the command is not found.) +-- -- This and other command running functions in this module log the commands -- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool @@ -81,9 +78,9 @@ safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystem' command params id safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode -safeSystem' command params mkprocess = do - (_, _, _, pid) <- createProcess p - waitForProcess pid +safeSystem' command params mkprocess = + withCreateProcess p $ \_ _ _ pid -> + waitForProcess pid where p = mkprocess $ proc command (toCommand params) @@ -91,44 +88,6 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } --- | Wraps a shell command line inside sh -c, allowing it to be run in a --- login shell that may not support POSIX shell, eg csh. -shellWrap :: String -> String -shellWrap cmdline = "sh -c " ++ shellEscape cmdline - --- | Escapes a filename or other parameter to be safely able to be exposed to --- the shell. --- --- This method works for POSIX shells, as well as other shells like csh. -shellEscape :: String -> String -shellEscape f = "'" ++ escaped ++ "'" - where - -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ splitc '\'' f - --- | Unescapes a set of shellEscaped words or filenames. -shellUnEscape :: String -> [String] -shellUnEscape [] = [] -shellUnEscape s = word : shellUnEscape rest - where - (word, rest) = findword "" s - findword w [] = (w, "") - findword w (c:cs) - | c == ' ' = (w, cs) - | c == '\'' = inquote c w cs - | c == '"' = inquote c w cs - | otherwise = findword (w++[c]) cs - inquote _ w [] = (w, "") - inquote q w (c:cs) - | c == q = findword w cs - | otherwise = inquote q (w++[c]) cs - --- | For quickcheck. -prop_isomorphic_shellEscape :: String -> Bool -prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s -prop_isomorphic_shellEscape_multiword :: [String] -> Bool -prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s - -- | Segments a list of filenames into groups that are all below the maximum -- command-line length limit. segmentXargsOrdered :: [FilePath] -> [[FilePath]] diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs new file mode 100644 index 0000000..acd2439 --- /dev/null +++ b/Utility/SimpleProtocol.hs @@ -0,0 +1,151 @@ +{- Simple line-based protocols. + - + - Copyright 2013-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utility.SimpleProtocol ( + Sendable(..), + Receivable(..), + parseMessage, + Serializable(..), + Parser, + parseFail, + parse0, + parse1, + parse2, + parse3, + parse4, + parse5, + dupIoHandles, + getProtocolLine, +) where + +import Data.Char +import GHC.IO.Handle +import Text.Read + +import Common + +-- Messages that can be sent. +class Sendable m where + formatMessage :: m -> [String] + +-- Messages that can be received. +class Receivable m where + -- Passed the first word of the message, returns + -- a Parser that can be be fed the rest of the message to generate + -- the value. + parseCommand :: String -> Parser m + +parseMessage :: (Receivable m) => String -> Maybe m +parseMessage s = parseCommand command rest + where + (command, rest) = splitWord s + +class Serializable a where + serialize :: a -> String + deserialize :: String -> Maybe a + +instance Serializable [Char] where + serialize = id + deserialize = Just + +instance Serializable Integer where + serialize = show + deserialize = readMaybe + +instance Serializable ExitCode where + serialize ExitSuccess = "0" + serialize (ExitFailure n) = show n + deserialize "0" = Just ExitSuccess + deserialize s = ExitFailure <$> readMaybe s + +{- Parsing the parameters of messages. Using the right parseN ensures + - that the string is split into exactly the requested number of words, + - which allows the last parameter of a message to contain arbitrary + - whitespace, etc, without needing any special quoting. + -} +type Parser a = String -> Maybe a + +parseFail :: Parser a +parseFail _ = Nothing + +parse0 :: a -> Parser a +parse0 mk "" = Just mk +parse0 _ _ = Nothing + +parse1 :: Serializable p1 => (p1 -> a) -> Parser a +parse1 mk p1 = mk <$> deserialize p1 + +parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a +parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 + where + (p1, p2) = splitWord s + +parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a +parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 + where + (p1, rest) = splitWord s + (p2, p3) = splitWord rest + +parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a +parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, p4) = splitWord rest' + +parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a +parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, rest'') = splitWord rest' + (p4, p5) = splitWord rest'' + +splitWord :: String -> (String, String) +splitWord = separate isSpace + +{- When a program speaks a simple protocol over stdio, any other output + - to stdout (or anything that attempts to read from stdin) + - will mess up the protocol. To avoid that, close stdin, + - and duplicate stderr to stdout. Return two new handles + - that are duplicates of the original (stdin, stdout). -} +dupIoHandles :: IO (Handle, Handle) +dupIoHandles = do + readh <- hDuplicate stdin + writeh <- hDuplicate stdout + nullh <- openFile devNull ReadMode + nullh `hDuplicateTo` stdin + stderr `hDuplicateTo` stdout + return (readh, writeh) + +{- Reads a line, but to avoid super-long lines eating memory, returns + - Nothing if 32 kb have been read without seeing a '\n' + - + - If there is a '\r' before the '\n', it is removed, to support + - systems using "\r\n" at ends of lines + - + - This implementation is not super efficient, but as long as the Handle + - supports buffering, it avoids reading a character at a time at the + - syscall level. + - + - Throws isEOFError when no more input is available. + -} +getProtocolLine :: Handle -> IO (Maybe String) +getProtocolLine h = go (32768 :: Int) [] + where + go 0 _ = return Nothing + go n l = do + c <- hGetChar h + if c == '\n' + then return $ Just $ reverse $ + case l of + ('\r':rest) -> rest + _ -> l + else go (n-1) (c:l) diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 6ee592b..5877f68 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -20,16 +20,22 @@ import System.IO 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 @@ viaTmp a file content = bracketIO setup cleanup use _ <- 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 @@ withTmpFile template a = do withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - - then removes the file. -} + - then removes the file. + - + - Note that the tmp file will have a file mode that only allows the + - current user to access it. + -} withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where -- cgit v1.2.3