From 2db8167ddbfa080b44509d4532d7d34887cdc64a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jun 2021 13:28:25 -0400 Subject: merge from git-annex Fixes 2 bugs, one a data loss bug. It is possible to get those fixes without merging all the other changes, if a backport is wanted. --- Utility/Batch.hs | 2 +- Utility/CopyFile.hs | 83 ++++++++++++++++++++++++++++++++++++ Utility/Debug.hs | 102 +++++++++++++++++++++++++++++++++++++++++++++ Utility/Exception.hs | 2 +- Utility/InodeCache.hs | 8 +++- Utility/Metered.hs | 20 +++++---- Utility/Path.hs | 78 ++++++++++++++++++++-------------- Utility/Path/AbsRel.hs | 20 +++++---- Utility/Process.hs | 7 ++-- Utility/QuickCheck.hs | 3 +- Utility/ThreadScheduler.hs | 1 + 11 files changed, 270 insertions(+), 56 deletions(-) create mode 100644 Utility/CopyFile.hs create mode 100644 Utility/Debug.hs (limited to 'Utility') diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 58e326e..6ed7881 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -57,7 +57,7 @@ nonBatchCommandMaker = id getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do #ifndef mingw32_HOST_OS - nicers <- filterM (inPath . fst) + nicers <- filterM (inSearchPath . fst) [ ("nice", []) , ("ionice", ["-c3"]) , ("nocache", []) diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs new file mode 100644 index 0000000..f851326 --- /dev/null +++ b/Utility/CopyFile.hs @@ -0,0 +1,83 @@ +{- file copying + - + - Copyright 2010-2019 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.CopyFile ( + copyFileExternal, + copyCoW, + createLinkOrCopy, + CopyMetaData(..) +) where + +import Common +import qualified BuildInfo + +data CopyMetaData + -- Copy timestamps when possible, but no other metadata, and + -- when copying a symlink, makes a copy of its content. + = CopyTimeStamps + -- Copy all metadata when possible. + | CopyAllMetaData + deriving (Eq) + +copyMetaDataParams :: CopyMetaData -> [CommandParam] +copyMetaDataParams meta = map snd $ filter fst + [ (allmeta && BuildInfo.cp_a, Param "-a") + , (allmeta && BuildInfo.cp_p && not BuildInfo.cp_a + , Param "-p") + , (not allmeta && BuildInfo.cp_preserve_timestamps + , Param "--preserve=timestamps") + ] + where + allmeta = meta == CopyAllMetaData + +{- The cp command is used, because I hate reinventing the wheel, + - and because this allows easy access to features like cp --reflink + - and preserving metadata. -} +copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyFileExternal meta src dest = do + -- Delete any existing dest file because an unwritable file + -- would prevent cp from working. + void $ tryIO $ removeFile dest + boolSystem "cp" $ params ++ [File src, File dest] + where + params + | BuildInfo.cp_reflink_supported = + Param "--reflink=auto" : copyMetaDataParams meta + | otherwise = copyMetaDataParams meta + +{- When a filesystem supports CoW (and cp does), uses it to make + - an efficient copy of a file. Otherwise, returns False. -} +copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyCoW meta src dest + | BuildInfo.cp_reflink_supported = do + void $ tryIO $ removeFile dest + -- When CoW is not supported, cp will complain to stderr, + -- so have to discard its stderr. + ok <- catchBoolIO $ withNullHandle $ \nullh -> + let p = (proc "cp" $ toCommand $ params ++ [File src, File dest]) + { std_out = UseHandle nullh + , std_err = UseHandle nullh + } + in withCreateProcess p $ \_ _ _ -> checkSuccessProcess + -- When CoW is not supported, cp creates the destination + -- file but leaves it empty. + unless ok $ + void $ tryIO $ removeFile dest + return ok + | otherwise = return False + where + params = Param "--reflink=always" : copyMetaDataParams meta + +{- Create a hard link if the filesystem allows it, and fall back to copying + - the file. -} +createLinkOrCopy :: FilePath -> FilePath -> IO Bool +createLinkOrCopy src dest = go `catchIO` const fallback + where + go = do + createLink src dest + return True + fallback = copyFileExternal CopyAllMetaData src dest diff --git a/Utility/Debug.hs b/Utility/Debug.hs new file mode 100644 index 0000000..e0be9c9 --- /dev/null +++ b/Utility/Debug.hs @@ -0,0 +1,102 @@ +{- Debug output + - + - Copyright 2021 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.Debug ( + DebugSource(..), + DebugSelector(..), + configureDebug, + getDebugSelector, + debug, + fastDebug +) where + +import qualified Data.ByteString as S +import Data.IORef +import Data.String +import Data.Time +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Semigroup as Sem +import Prelude + +import Utility.FileSystemEncoding + +-- | The source of a debug message. For example, this could be a module or +-- function name. +newtype DebugSource = DebugSource S.ByteString + deriving (Eq, Show) + +instance IsString DebugSource where + fromString = DebugSource . encodeBS' + +-- | Selects whether to display a message from a source. +data DebugSelector + = DebugSelector (DebugSource -> Bool) + | NoDebugSelector + +instance Sem.Semigroup DebugSelector where + DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v) + NoDebugSelector <> NoDebugSelector = NoDebugSelector + NoDebugSelector <> b = b + a <> NoDebugSelector = a + +instance Monoid DebugSelector where + mempty = NoDebugSelector + +-- | Configures debugging. +configureDebug + :: (S.ByteString -> IO ()) + -- ^ Used to display debug output. + -> DebugSelector + -> IO () +configureDebug src p = writeIORef debugConfigGlobal (src, p) + +-- | Gets the currently configured DebugSelector. +getDebugSelector :: IO DebugSelector +getDebugSelector = snd <$> readIORef debugConfigGlobal + +-- A global variable for the debug configuration. +{-# NOINLINE debugConfigGlobal #-} +debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector) +debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone) + where + dontshow _ = return () + selectnone = NoDebugSelector + +-- | Displays a debug message, if that has been enabled by configureDebug. +-- +-- This is reasonably fast when debugging is not enabled, but since it does +-- have to consult a IORef each time, using it in a tight loop may slow +-- down the program. +debug :: DebugSource -> String -> IO () +debug src msg = readIORef debugConfigGlobal >>= \case + (displayer, NoDebugSelector) -> + displayer =<< formatDebugMessage src msg + (displayer, DebugSelector p) + | p src -> displayer =<< formatDebugMessage src msg + | otherwise -> return () + +-- | Displays a debug message, if the DebugSelector allows. +-- +-- When the DebugSelector does not let the message be displayed, this runs +-- very quickly, allowing it to be used inside tight loops. +fastDebug :: DebugSelector -> DebugSource -> String -> IO () +fastDebug NoDebugSelector src msg = do + (displayer, _) <- readIORef debugConfigGlobal + displayer =<< formatDebugMessage src msg +fastDebug (DebugSelector p) src msg + | p src = fastDebug NoDebugSelector src msg + | otherwise = return () + +formatDebugMessage :: DebugSource -> String -> IO S.ByteString +formatDebugMessage (DebugSource src) msg = do + t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + <$> getZonedTime + return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 273f844..4c60eac 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 expeected to see in some + - where there's a problem that the user is expected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 74c6dff..9a21c63 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -24,6 +24,7 @@ module Utility.InodeCache ( showInodeCache, genInodeCache, toInodeCache, + toInodeCache', InodeCacheKey, inodeCacheToKey, @@ -189,7 +190,10 @@ genInodeCache f delta = catchDefaultIO Nothing $ toInodeCache delta f =<< R.getFileStatus f toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) -toInodeCache (TSDelta getdelta) f s +toInodeCache d f s = toInodeCache' d f s (fileID s) + +toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache) +toInodeCache' (TSDelta getdelta) f s inode | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s @@ -198,7 +202,7 @@ toInodeCache (TSDelta getdelta) f s #else let mtime = modificationTimeHiRes s #endif - return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime delta)) + return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing {- Some filesystem get new random inodes each time they are mounted. diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 1715f0b..a7c9c37 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -118,23 +118,24 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a -{- Writes a ByteString to a Handle, updating a meter as it's written. -} -meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () -meteredWrite meterupdate h = void . meteredWrite' meterupdate h +{- Calls the action repeatedly with chunks from the lazy ByteString. + - Updates the meter after each chunk is processed. -} +meteredWrite :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO () +meteredWrite meterupdate a = void . meteredWrite' meterupdate a -meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed -meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite' :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks where go sofar [] = return sofar go sofar (c:cs) = do - S.hPut h c + a c let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> - meteredWrite meterupdate h b + meteredWrite meterupdate (S.hPut h) b {- Applies an offset to a MeterUpdate. This can be useful when - performing a sequence of actions, such as multiple meteredWriteFiles, @@ -424,7 +425,8 @@ displayMeterHandle h rendermeter v msize old new = do hPutStr h ('\r':s ++ padding) hFlush h --- | Clear meter displayed by displayMeterHandle. +-- | Clear meter displayed by displayMeterHandle. May be called before +-- outputting something else, followed by more calls to displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO () clearMeterHandle (Meter _ _ v _) h = do olds <- readMVar v diff --git a/Utility/Path.hs b/Utility/Path.hs index 6bd407e..cfda748 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -18,11 +18,12 @@ module Utility.Path ( segmentPaths', runSegmentPaths, runSegmentPaths', - inPath, - searchPath, dotfile, splitShortExtensions, relPathDirToFileAbs, + inSearchPath, + searchPath, + searchPathContents, ) where import System.FilePath.ByteString @@ -30,11 +31,13 @@ import qualified System.FilePath as P import qualified Data.ByteString as B import Data.List import Data.Maybe +import Control.Monad import Control.Applicative import Prelude import Utility.Monad import Utility.SystemDirectory +import Utility.Exception #ifdef mingw32_HOST_OS import Data.Char @@ -136,33 +139,6 @@ runSegmentPaths c a paths = segmentPaths c paths <$> a paths 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. - - - - The command may be fully-qualified, in which case, this succeeds as - - long as it exists. -} -inPath :: String -> IO Bool -inPath command = isJust <$> searchPath command - -{- Finds a command in PATH and returns the full path to it. - - - - The command may be fully qualified already, in which case it will - - be returned if it exists. - - - - Note that this will find commands in PATH that are not executable. - -} -searchPath :: String -> IO (Maybe FilePath) -searchPath command - | P.isAbsolute command = check command - | otherwise = P.getSearchPath >>= getM indir - where - indir d = check $ d P. command - check f = firstM doesFileExist -#ifdef mingw32_HOST_OS - [f, f ++ ".exe"] -#else - [f] -#endif - {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} dotfile :: RawFilePath -> Bool @@ -189,8 +165,7 @@ splitShortExtensions' maxextension = go [] (base, ext) = splitExtension f len = B.length ext -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ +{- This requires both paths to be absolute and normalized. - - On Windows, if the paths are on different drives, - a relative path is not possible and the path is simply @@ -214,3 +189,44 @@ relPathDirToFileAbs from to #ifdef mingw32_HOST_OS normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive #endif + +{- Checks if a command is available in PATH. + - + - The command may be fully-qualified, in which case, this succeeds as + - long as it exists. -} +inSearchPath :: String -> IO Bool +inSearchPath command = isJust <$> searchPath command + +{- Finds a command in PATH and returns the full path to it. + - + - The command may be fully qualified already, in which case it will + - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. + -} +searchPath :: String -> IO (Maybe FilePath) +searchPath command + | P.isAbsolute command = check command + | otherwise = P.getSearchPath >>= getM indir + where + indir d = check $ d P. command + check f = firstM doesFileExist +#ifdef mingw32_HOST_OS + [f, f ++ ".exe"] +#else + [f] +#endif + +{- Finds commands in PATH that match a predicate. Note that the predicate + - matches on the basename of the command, but the full path to it is + - returned. + - + - Note that this will find commands in PATH that are not executable. + -} +searchPathContents :: (FilePath -> Bool) -> IO [FilePath] +searchPathContents p = + filterM doesFileExist + =<< (concat <$> (P.getSearchPath >>= mapM go)) + where + go d = map (d P.) . filter p + <$> catchDefaultIO [] (getDirectoryContents d) diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs index 0026bd6..857dd5e 100644 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -1,6 +1,6 @@ {- absolute and relative path manipulation - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -19,6 +19,7 @@ module Utility.Path.AbsRel ( ) where import System.FilePath.ByteString +import qualified Data.ByteString as B #ifdef mingw32_HOST_OS import System.Directory (getCurrentDirectory) #else @@ -64,22 +65,27 @@ absPath file #endif return $ absPathFrom cwd file -{- Constructs a relative path from the CWD to a file. +{- Constructs the minimal relative path from the CWD to a file. - - For example, assuming CWD is /tmp/foo/bar: - relPathCwdToFile "/tmp/foo" == ".." - relPathCwdToFile "/tmp/foo/bar" == "" + - relPathCwdToFile "../bar/baz" == "baz" -} relPathCwdToFile :: RawFilePath -> IO RawFilePath -relPathCwdToFile f = do +relPathCwdToFile f + -- Optimisation: Avoid doing any IO when the path is relative + -- and does not contain any ".." component. + | isRelative f && not (".." `B.isInfixOf` f) = return f + | otherwise = do #ifdef mingw32_HOST_OS - c <- toRawFilePath <$> getCurrentDirectory + c <- toRawFilePath <$> getCurrentDirectory #else - c <- getWorkingDirectory + c <- getWorkingDirectory #endif - relPathDirToFile c f + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. -} +{- Constructs a minimal relative path from a directory to a file. -} relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to diff --git a/Utility/Process.hs b/Utility/Process.hs index 4a725c8..4cf6105 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP, Rank2Types, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( @@ -38,10 +39,10 @@ import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(.. import Utility.Misc import Utility.Exception import Utility.Monad +import Utility.Debug import System.Exit import System.IO -import System.Log.Logger import Control.Monad.IO.Class import Control.Concurrent.Async import qualified Data.ByteString as S @@ -187,7 +188,7 @@ withCreateProcess p action = bracket (createProcess p) cleanupProcess debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do pid <- getPid h - debugM "Utility.Process" $ unwords + debug "Utility.Process" $ unwords [ describePid pid , action ++ ":" , showCmd p @@ -211,7 +212,7 @@ 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" (describePid pid ++ " done " ++ show r) + debug "Utility.Process" (describePid pid ++ " done " ++ show r) return r cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 2093670..650f559 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -12,8 +12,7 @@ module Utility.QuickCheck ( module X , TestableString , fromTestableString - , TestableFilePath - , fromTestableFilePath + , TestableFilePath(..) , nonNegative , positive ) where diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index ef69ead..9ab94d9 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -15,6 +15,7 @@ module Utility.ThreadScheduler ( threadDelaySeconds, waitForTermination, oneSecond, + unboundDelay, ) where import Control.Monad -- cgit v1.2.3