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.

11 files changed, 270 insertions, 56 deletions

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