merge from git-annex

10 files changed, 179 insertions, 154 deletions

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 <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - 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 <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
  -
  - 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 <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - 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 <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - 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 <id@joeyh.name>
+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>
  -
  - 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