From c244daa32328f478bbf38a79f2fcacb138a1049f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:40:38 -0400 Subject: merge from git-annex --- Utility/CopyFile.hs | 18 ++++- Utility/Data.hs | 18 ++++- Utility/Debug.hs | 4 +- Utility/FileSystemEncoding.hs | 148 +++++++----------------------------------- Utility/HumanNumber.hs | 10 ++- Utility/InodeCache.hs | 9 +-- Utility/Metered.hs | 52 +++++++++++++-- Utility/Path.hs | 48 +++++++++++++- Utility/Tmp.hs | 18 ++++- Utility/Tmp/Dir.hs | 8 ++- 10 files changed, 179 insertions(+), 154 deletions(-) (limited to 'Utility') diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index f851326..9c93e70 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -1,6 +1,6 @@ {- file copying - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -30,6 +30,12 @@ copyMetaDataParams meta = map snd $ filter fst , Param "-p") , (not allmeta && BuildInfo.cp_preserve_timestamps , Param "--preserve=timestamps") + -- cp -a may preserve xattrs that have special meaning, + -- eg to NFS, and have even been observed to prevent later + -- changing the permissions of the file. So prevent preserving + -- xattrs. + , (allmeta && BuildInfo.cp_a && BuildInfo.cp_no_preserve_xattr_supported + , Param "--no-preserve=xattr") ] where allmeta = meta == CopyAllMetaData @@ -50,11 +56,17 @@ copyFileExternal meta src dest = do | otherwise = copyMetaDataParams meta {- When a filesystem supports CoW (and cp does), uses it to make - - an efficient copy of a file. Otherwise, returns False. -} + - an efficient copy of a file. Otherwise, returns False. + - + - The dest file must not exist yet, or it will fail to make a CoW copy, + - and will return False. + - + - Note that in coreutil 9.0, cp uses CoW by default, without needing an + - option. This code is only needed to support older versions. + -} 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 -> diff --git a/Utility/Data.hs b/Utility/Data.hs index 5510845..faf9b34 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013-2021 Joey Hess - - License: BSD-2-clause -} @@ -10,8 +10,12 @@ module Utility.Data ( firstJust, eitherToMaybe, + s2w8, + w82s, ) where +import Data.Word + {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of @@ -20,3 +24,15 @@ firstJust ms = case dropWhile (== Nothing) ms of eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c diff --git a/Utility/Debug.hs b/Utility/Debug.hs index e0be9c9..6e6e701 100644 --- a/Utility/Debug.hs +++ b/Utility/Debug.hs @@ -34,7 +34,7 @@ newtype DebugSource = DebugSource S.ByteString deriving (Eq, Show) instance IsString DebugSource where - fromString = DebugSource . encodeBS' + fromString = DebugSource . encodeBS -- | Selects whether to display a message from a source. data DebugSelector @@ -97,6 +97,6 @@ fastDebug (DebugSelector p) src msg formatDebugMessage :: DebugSource -> String -> IO S.ByteString formatDebugMessage (DebugSource src) msg = do - t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]" <$> getZonedTime return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 1f7c76b..2a1dc81 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -11,7 +11,6 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, - withFilePath, RawFilePath, fromRawFilePath, toRawFilePath, @@ -19,36 +18,22 @@ module Utility.FileSystemEncoding ( encodeBL, decodeBS, encodeBS, - decodeBL', - encodeBL', - decodeBS', - encodeBS', truncateFilePath, - s2w8, - w82s, - c2w8, - w82c, ) where import qualified GHC.Foreign as GHC import qualified GHC.IO.Encoding as Encoding -import Foreign.C import System.IO import System.IO.Unsafe -import Data.Word import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafePackMallocCStringLen) #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 Utility.Exception - {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale. @@ -81,40 +66,10 @@ fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding fileEncoding h = hSetEncoding h Encoding.utf8 #endif -{- Marshal a Haskell FilePath into a NUL terminated C string using temporary - - storage. The FilePath is encoded using the filesystem encoding, - - reversing the decoding that should have been done when the FilePath - - was obtained. -} -withFilePath :: FilePath -> (CString -> IO a) -> IO a -withFilePath fp f = Encoding.getFileSystemEncoding - >>= \enc -> GHC.withCString enc fp f - -{- Encodes a FilePath into a String, applying the filesystem encoding. - - - - There are very few things it makes sense to do with such an encoded - - string. It's not a legal filename; it should not be displayed. - - So this function is not exported, but instead used by the few functions - - that can usefully consume it. - - - - This use of unsafePerformIO is belived to be safe; GHC's interface - - only allows doing this conversion with CStrings, and the CString buffer - - is allocated, used, and deallocated within the call, with no side - - effects. - - - - If the FilePath contains a value that is not legal in the filesystem - - encoding, rather than thowing an exception, it will be returned as-is. - -} -{-# NOINLINE _encodeFilePath #-} -_encodeFilePath :: FilePath -> String -_encodeFilePath fp = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString enc fp (GHC.peekCString Encoding.char8) - `catchNonAsync` (\_ -> return fp) - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBL = encodeW8NUL . L.unpack +decodeBL = decodeBS . L.toStrict #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} @@ -124,104 +79,45 @@ decodeBL = L8.toString {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBL = L.pack . decodeW8NUL +encodeBL = L.fromStrict . encodeBS #else encodeBL = L8.fromString #endif decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . S.unpack +-- This does the same thing as System.FilePath.ByteString.decodeFilePath, +-- with an identical implementation. However, older versions of that library +-- truncated at NUL, which this must not do, because it may end up used on +-- something other than a unix filepath. +{-# NOINLINE decodeBS #-} +decodeBS b = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + S.useAsCStringLen b (GHC.peekCStringLen enc) #else decodeBS = S8.toString #endif encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS -encodeBS = S.pack . decodeW8NUL +-- This does the same thing as System.FilePath.ByteString.encodeFilePath, +-- with an identical implementation. However, older versions of that library +-- truncated at NUL, which this must not do, because it may end up used on +-- something other than a unix filepath. +{-# NOINLINE encodeBS #-} +encodeBS f = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.newCStringLen enc f >>= unsafePackMallocCStringLen #else encodeBS = S8.fromString #endif -{- Faster version that assumes the string does not contain NUL; - - if it does it will be truncated before the NUL. -} -decodeBS' :: S.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBS' = encodeW8 . S.unpack -#else -decodeBS' = S8.toString -#endif - -encodeBS' :: FilePath -> S.ByteString -#ifndef mingw32_HOST_OS -encodeBS' = S.pack . decodeW8 -#else -encodeBS' = S8.fromString -#endif - -decodeBL' :: L.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBL' = encodeW8 . L.unpack -#else -decodeBL' = L8.toString -#endif - -encodeBL' :: FilePath -> L.ByteString -#ifndef mingw32_HOST_OS -encodeBL' = L.pack . decodeW8 -#else -encodeBL' = L8.fromString -#endif - fromRawFilePath :: RawFilePath -> FilePath 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 - - unicode. From there, this is really a simple matter of applying the - - file system encoding, only complicated by GHC's interface to doing so. - - - - Note that the encoding stops at any NUL in the input. FilePaths - - cannot contain embedded NUL, but Haskell Strings may. - -} -{-# NOINLINE encodeW8 #-} -encodeW8 :: [Word8] -> FilePath -encodeW8 w8 = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc - -decodeW8 :: FilePath -> [Word8] -decodeW8 = s2w8 . _encodeFilePath - -{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} -encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) - where - nul = '\NUL' - -decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul - where - nul = '\NUL' -#endif - -c2w8 :: Char -> Word8 -c2w8 = fromIntegral . fromEnum - -w82c :: Word8 -> Char -w82c = toEnum . fromIntegral - -s2w8 :: String -> [Word8] -s2w8 = map c2w8 - -w82s :: [Word8] -> String -w82s = map w82c - {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - @@ -233,8 +129,8 @@ truncateFilePath :: Int -> FilePath -> FilePath truncateFilePath n = go . reverse where go f = - let bytes = decodeW8 f - in if length bytes <= n + let b = encodeBS f + in if S.length b <= n then reverse f else go (drop 1 f) #else diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs index 6143cef..04a18b0 100644 --- a/Utility/HumanNumber.hs +++ b/Utility/HumanNumber.hs @@ -1,6 +1,6 @@ {- numbers for humans - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -11,11 +11,15 @@ module Utility.HumanNumber (showImprecise) where - of decimal digits. -} showImprecise :: RealFrac a => Int -> a -> String showImprecise precision n - | precision == 0 || remainder == 0 = show (round n :: Integer) - | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + | precision == 0 || remainder' == 0 = show (round n :: Integer) + | otherwise = show int' ++ "." ++ striptrailing0s (pad0s $ show remainder') where int :: Integer (int, frac) = properFraction n remainder = round (frac * 10 ^ precision) :: Integer + (int', remainder') + -- carry the 1 + | remainder == 10 ^ precision = (int + 1, 0) + | otherwise = (int, remainder) pad0s s = replicate (precision - length s) '0' ++ s striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 9a21c63..b697ab3 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -55,7 +55,7 @@ import Data.Time.Clock.POSIX #ifdef mingw32_HOST_OS import Data.Word (Word64) #else -import System.Posix.Files +import qualified System.Posix.Files as Posix #endif data InodeCachePrim = InodeCachePrim FileID FileSize MTime @@ -200,7 +200,7 @@ toInodeCache' (TSDelta getdelta) f s inode #ifdef mingw32_HOST_OS mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else - let mtime = modificationTimeHiRes s + let mtime = Posix.modificationTimeHiRes s #endif return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing @@ -300,11 +300,6 @@ instance Arbitrary MTime where , (50, MTimeHighRes <$> arbitrary) ] -#ifdef mingw32_HOST_OS -instance Arbitrary FileID where - arbitrary = fromIntegral <$> (arbitrary :: Gen Word64) -#endif - prop_read_show_inodecache :: InodeCache -> Bool prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of Nothing -> False diff --git a/Utility/Metered.hs b/Utility/Metered.hs index a7c9c37..8fd9c9b 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -37,6 +37,7 @@ module Utility.Metered ( demeterCommandEnv, avoidProgress, rateLimitMeterUpdate, + bwLimitMeterUpdate, Meter, mkMeter, setMeterTotalSize, @@ -51,6 +52,7 @@ import Utility.Percentage import Utility.DataUnits import Utility.HumanTime import Utility.SimpleProtocol as Proto +import Utility.ThreadScheduler import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -380,6 +382,46 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do meterupdate n else putMVar lastupdate prev +-- | Bandwidth limiting by inserting a delay at the point that a meter is +-- updated. +-- +-- This will only work when the actions that use bandwidth are run in the +-- same process and thread as the call to the MeterUpdate. +-- +-- For example, if the desired bandwidth is 100kb/s, and over the past +-- 1/10th of a second, 30kb was sent, then the current bandwidth is +-- 300kb/s, 3x as fast as desired. So, after getting the next chunk, +-- pause for twice as long as it took to get it. +bwLimitMeterUpdate :: ByteSize -> Duration -> MeterUpdate -> IO MeterUpdate +bwLimitMeterUpdate bwlimit duration meterupdate + | bwlimit <= 0 = return meterupdate + | otherwise = do + nowtime <- getPOSIXTime + mv <- newMVar (nowtime, Nothing) + return (mu mv) + where + mu mv n@(BytesProcessed i) = do + endtime <- getPOSIXTime + (starttime, mprevi) <- takeMVar mv + + case mprevi of + Just previ -> do + let runtime = endtime - starttime + let currbw = fromIntegral (i - previ) / runtime + let pausescale = if currbw > bwlimit' + then (currbw / bwlimit') - 1 + else 0 + unboundDelay (floor (runtime * pausescale * msecs)) + Nothing -> return () + + meterupdate n + + nowtime <- getPOSIXTime + putMVar mv (nowtime, Just i) + + bwlimit' = fromIntegral (bwlimit * durationSeconds duration) + msecs = fromIntegral oneSecond + data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter data MeterState = MeterState @@ -417,12 +459,14 @@ updateMeter (Meter totalsizev sv bv displaymeter) new = do -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter displayMeterHandle h rendermeter v msize old new = do + olds <- takeMVar v let s = rendermeter msize old new - olds <- swapMVar v s + let padding = replicate (length olds - length s) ' ' + let s' = s <> padding + putMVar v s' -- Avoid writing when the rendered meter has not changed. - when (olds /= s) $ do - let padding = replicate (length olds - length s) ' ' - hPutStr h ('\r':s ++ padding) + when (olds /= s') $ do + hPutStr h ('\r':s') hFlush h -- | Clear meter displayed by displayMeterHandle. May be called before diff --git a/Utility/Path.hs b/Utility/Path.hs index cfda748..b5aeb16 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -95,13 +95,49 @@ upFrom dir dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `B.isPrefixOf` b' - || a' == "." && normalise ("." b') == b' + || (a'' `B.isPrefixOf` b' && avoiddotdotb) + || a' == "." && normalise ("." b') == b' && nodotdot b' + || dotdotcontains where a' = norm a + a'' = addTrailingPathSeparator a' b' = norm b norm = normalise . simplifyPath + {- This handles the case where a is ".." and b is "../..", + - which is not inside a. Similarly, "../.." does not contain + - "../../../". Due to the use of norm, cases like + - "../../foo/../../" get converted to eg "../../.." and + - so do not need to be handled specially here. + - + - When this is called, we already know that + - a'' is a prefix of b', so all that needs to be done is drop + - that prefix, and check if the next path component is ".." + -} + avoiddotdotb = nodotdot $ B.drop (B.length a'') b' + + nodotdot p = all (not . isdotdot) (splitPath p) + + isdotdot s = dropTrailingPathSeparator s == ".." + + {- This handles the case where a is ".." or "../.." etc, + - and b is "foo" or "../foo" etc. The rule is that when + - a is entirely ".." components, b is under it when it starts + - with fewer ".." components. + - + - Due to the use of norm, cases like "../../foo/../../" get + - converted to eg "../../../" and so do not need to be handled + - specially here. + -} + dotdotcontains + | isAbsolute b' = False + | otherwise = + let aps = splitPath a' + bps = splitPath b' + in if all isdotdot aps + then length (takeWhile isdotdot bps) < length aps + else False + {- 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. @@ -187,7 +223,13 @@ relPathDirToFileAbs from to dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common #ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive + normdrive = map toLower + -- Get just the drive letter, removing any leading + -- path separator, which takeDrive leaves on the drive + -- letter. + . dropWhileEnd (isPathSeparator . fromIntegral . ord) + . fromRawFilePath + . takeDrive #endif {- Checks if a command is available in PATH. diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 5877f68..92bd921 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -14,6 +14,7 @@ module Utility.Tmp ( withTmpFile, withTmpFileIn, relatedTemplate, + openTmpFileIn, ) where import System.IO @@ -21,6 +22,7 @@ import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error import Utility.Exception import Utility.FileSystemEncoding @@ -28,6 +30,18 @@ import Utility.FileMode type Template = String +{- This is the same as openTempFile, except when there is an + - error, it displays the template as well as the directory, + - to help identify what call was responsible. + -} +openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) +openTmpFileIn dir template = openTempFile dir template + `catchIO` decoraterrror + where + decoraterrror e = throwM $ + let loc = ioeGetLocation e ++ " template " ++ template + in annotateIOError e loc Nothing Nothing + {- 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. @@ -43,7 +57,7 @@ viaTmp a file content = bracketIO setup cleanup use template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir - openTempFile dir template + openTmpFileIn dir template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h tryIO $ removeFile tmpfile @@ -73,7 +87,7 @@ withTmpFile template a = do withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = liftIO $ openTempFile tmpdir template + create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h catchBoolIO (removeFile name >> return True) diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs index c68ef86..904b65a 100644 --- a/Utility/Tmp/Dir.hs +++ b/Utility/Tmp/Dir.hs @@ -1,6 +1,6 @@ {- Temporary directories - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2022 Joey Hess - - License: BSD-2-clause -} @@ -63,8 +63,10 @@ removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do -- after a process has just written to it and exited. -- Because it's crap, presumably. So, ignore failure -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive tmpdir + _ <- tryIO $ go tmpdir return () #else - removeDirectoryRecursive tmpdir + go tmpdir #endif + where + go = removeDirectoryRecursive -- cgit v1.2.3