21ff5e1e5a
Improved probing when CoW copies can be made between files on the same drive. Now supports CoW between BTRFS subvolumes. And, falls back to rsync instead of using cp when CoW won't work, eg copies between repos on the same EXT4 filesystem. Rather than trying cp --reflink=always for each file copied to a remote, it's tried once and if it fails it falls back to using rsync thereafter for the lifetime of the Remote object. That avoids overhead of calling cp which while small, will add up over a large number of files. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
88 lines
2.7 KiB
Haskell
88 lines
2.7 KiB
Haskell
{- Checks system configuration and generates Build/SysConfig and Build/Version. -}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-tabs #-}
|
|
|
|
module Build.Configure where
|
|
|
|
import Build.TestConfig
|
|
import Build.Version
|
|
import Utility.SafeCommand
|
|
import Utility.Env.Basic
|
|
import qualified Git.Version
|
|
import Utility.Directory
|
|
|
|
import Control.Monad
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
tests :: [TestCase]
|
|
tests =
|
|
[ TestCase "UPGRADE_LOCATION" getUpgradeLocation
|
|
, TestCase "git" $ testCmd "git" "git --version >/dev/null"
|
|
, TestCase "git version" getGitVersion
|
|
, testCp "cp_a" "-a"
|
|
, testCp "cp_p" "-p"
|
|
, testCp "cp_preserve_timestamps" "--preserve=timestamps"
|
|
, testCp "cp_reflink_supported" "--reflink=auto"
|
|
, TestCase "xargs -0" $ testCmd "xargs_0" "xargs -0 </dev/null"
|
|
, TestCase "rsync" $ testCmd "rsync" "rsync --version >/dev/null"
|
|
, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
|
|
, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
|
|
, TestCase "nice" $ testCmd "nice" "nice true >/dev/null"
|
|
, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
|
|
, TestCase "nocache" $ testCmd "nocache" "nocache true >/dev/null"
|
|
, TestCase "gpg" $ maybeSelectCmd "gpg"
|
|
[ ("gpg", "--version >/dev/null")
|
|
, ("gpg2", "--version >/dev/null") ]
|
|
, TestCase "lsof" $ findCmdPath "lsof" "lsof"
|
|
, TestCase "git-remote-gcrypt" $ findCmdPath "gcrypt" "git-remote-gcrypt"
|
|
, TestCase "ssh connection caching" getSshConnectionCaching
|
|
]
|
|
|
|
tmpDir :: String
|
|
tmpDir = "tmp"
|
|
|
|
testFile :: String
|
|
testFile = tmpDir ++ "/testfile"
|
|
|
|
testCp :: ConfigKey -> String -> TestCase
|
|
testCp k option = TestCase cmd $ testCmd k cmdline
|
|
where
|
|
cmd = "cp " ++ option
|
|
cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"
|
|
|
|
getUpgradeLocation :: Test
|
|
getUpgradeLocation = do
|
|
e <- getEnv "UPGRADE_LOCATION"
|
|
return $ Config "upgradelocation" $ MaybeStringConfig e
|
|
|
|
getGitVersion :: Test
|
|
getGitVersion = go =<< getEnv "FORCE_GIT_VERSION"
|
|
where
|
|
go (Just s) = return $ Config "gitversion" $ StringConfig s
|
|
go Nothing = do
|
|
v <- Git.Version.installed
|
|
let oldestallowed = Git.Version.normalize "1.7.1.0"
|
|
when (v < oldestallowed) $
|
|
error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)"
|
|
return $ Config "gitversion" $ StringConfig $ show v
|
|
|
|
getSshConnectionCaching :: Test
|
|
getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
|
|
boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]
|
|
|
|
setup :: IO ()
|
|
setup = do
|
|
createDirectoryIfMissing True tmpDir
|
|
writeFile testFile "test file contents"
|
|
|
|
cleanup :: IO ()
|
|
cleanup = removeDirectoryRecursive tmpDir
|
|
|
|
run :: [TestCase] -> IO ()
|
|
run ts = do
|
|
setup
|
|
config <- runTests ts
|
|
writeSysConfig config
|
|
writeVersion =<< getVersion
|
|
cleanup
|