2012-03-10 18:00:26 +00:00
|
|
|
{- Checks system configuration and generates SysConfig.hs. -}
|
|
|
|
|
2013-04-17 15:57:46 +00:00
|
|
|
module Build.Configure where
|
|
|
|
|
2012-03-10 18:00:26 +00:00
|
|
|
import System.Directory
|
|
|
|
import Data.List
|
2012-07-18 19:30:26 +00:00
|
|
|
import System.Process
|
2012-03-10 18:00:26 +00:00
|
|
|
import Control.Applicative
|
2012-06-01 03:33:07 +00:00
|
|
|
import System.FilePath
|
2013-02-11 20:56:04 +00:00
|
|
|
import System.Environment
|
2013-04-10 20:53:04 +00:00
|
|
|
import Data.Maybe
|
2013-05-10 20:36:31 +00:00
|
|
|
import Control.Monad.IfElse
|
2013-05-17 15:24:18 +00:00
|
|
|
import Data.Char
|
2012-03-10 18:00:26 +00:00
|
|
|
|
|
|
|
import Build.TestConfig
|
|
|
|
import Utility.SafeCommand
|
2013-04-10 20:53:04 +00:00
|
|
|
import Utility.Monad
|
|
|
|
import Utility.Exception
|
2013-05-08 15:17:09 +00:00
|
|
|
import Utility.ExternalSHA
|
2013-08-02 22:31:01 +00:00
|
|
|
import qualified Git.Version
|
2012-03-10 18:00:26 +00:00
|
|
|
|
2012-03-22 21:09:54 +00:00
|
|
|
tests :: [TestCase]
|
|
|
|
tests =
|
2012-03-10 18:00:26 +00:00
|
|
|
[ TestCase "version" getVersion
|
|
|
|
, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
|
|
|
|
, TestCase "git version" getGitVersion
|
|
|
|
, testCp "cp_a" "-a"
|
|
|
|
, testCp "cp_p" "-p"
|
|
|
|
, testCp "cp_reflink_auto" "--reflink=auto"
|
|
|
|
, TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null"
|
|
|
|
, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
|
|
|
|
, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
|
|
|
|
, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
|
|
|
|
, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
|
2013-08-22 22:25:21 +00:00
|
|
|
, TestCase "quvi" $ testCmd "quvi" "quvi --version >/dev/null"
|
2013-06-21 17:43:04 +00:00
|
|
|
, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
|
2013-05-19 21:59:58 +00:00
|
|
|
, TestCase "gpg" $ maybeSelectCmd "gpg"
|
|
|
|
[ ("gpg", "--version >/dev/null")
|
|
|
|
, ("gpg2", "--version >/dev/null") ]
|
2012-12-14 19:52:44 +00:00
|
|
|
, TestCase "lsof" $ findCmdPath "lsof" "lsof"
|
2012-03-10 18:00:26 +00:00
|
|
|
, TestCase "ssh connection caching" getSshConnectionCaching
|
configure: Check that checksum programs produce correct checksums. + bitter rant
So, it might be called sha1sum, or on some other OS, it might be called
sha1. It might be hidden away off of PATH on that OS. That's just expected
insanity; UNIX has been this way since 1980's. And these days, nobody even
gives the flying flip about standards that we briefly did in the 90's
after the first round of unix wars.
But it's the 2010's now, and we've certainly learned something.
So, let's make it so sometimes sha1 is a crazy program that wants to run as
root so it can lock memory while prompting for a passphrase, and outputting
binary garbage. Yes, that'd be wise. Let's package that in major Linux
distros, too, so users can stumble over it.
2012-10-25 04:05:12 +00:00
|
|
|
] ++ shaTestCases
|
|
|
|
[ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")
|
|
|
|
, (256, "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
|
|
|
|
, (512, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")
|
|
|
|
, (224, "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f")
|
|
|
|
, (384, "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b")
|
|
|
|
]
|
2012-03-10 18:00:26 +00:00
|
|
|
|
2012-11-09 15:27:50 +00:00
|
|
|
{- shaNsum are the program names used by coreutils. Some systems like OSX
|
|
|
|
- sometimes install these with 'g' prefixes.
|
|
|
|
-
|
configure: Check that checksum programs produce correct checksums. + bitter rant
So, it might be called sha1sum, or on some other OS, it might be called
sha1. It might be hidden away off of PATH on that OS. That's just expected
insanity; UNIX has been this way since 1980's. And these days, nobody even
gives the flying flip about standards that we briefly did in the 90's
after the first round of unix wars.
But it's the 2010's now, and we've certainly learned something.
So, let's make it so sometimes sha1 is a crazy program that wants to run as
root so it can lock memory while prompting for a passphrase, and outputting
binary garbage. Yes, that'd be wise. Let's package that in major Linux
distros, too, so users can stumble over it.
2012-10-25 04:05:12 +00:00
|
|
|
- On some systems, shaN is used instead, but on other
|
|
|
|
- systems, it might be "hashalot", which does not produce
|
|
|
|
- usable checksums. Only accept programs that produce
|
2013-05-08 15:17:09 +00:00
|
|
|
- known-good hashes when run on files. -}
|
configure: Check that checksum programs produce correct checksums. + bitter rant
So, it might be called sha1sum, or on some other OS, it might be called
sha1. It might be hidden away off of PATH on that OS. That's just expected
insanity; UNIX has been this way since 1980's. And these days, nobody even
gives the flying flip about standards that we briefly did in the 90's
after the first round of unix wars.
But it's the 2010's now, and we've certainly learned something.
So, let's make it so sometimes sha1 is a crazy program that wants to run as
root so it can lock memory while prompting for a passphrase, and outputting
binary garbage. Yes, that'd be wise. Let's package that in major Linux
distros, too, so users can stumble over it.
2012-10-25 04:05:12 +00:00
|
|
|
shaTestCases :: [(Int, String)] -> [TestCase]
|
2012-07-04 13:08:20 +00:00
|
|
|
shaTestCases l = map make l
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2013-05-08 15:17:09 +00:00
|
|
|
make (n, knowngood) = TestCase key $
|
|
|
|
Config key . MaybeStringConfig <$> search (shacmds n)
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
key = "sha" ++ show n
|
2013-05-08 15:17:09 +00:00
|
|
|
search [] = return Nothing
|
|
|
|
search (c:cmds) = do
|
|
|
|
sha <- externalSHA c n "/dev/null"
|
|
|
|
if sha == Right knowngood
|
|
|
|
then return $ Just c
|
|
|
|
else search cmds
|
|
|
|
|
2012-11-11 04:51:07 +00:00
|
|
|
shacmds n = concatMap (\x -> [x, 'g':x, osxpath </> x]) $
|
|
|
|
map (\x -> "sha" ++ show n ++ x) ["sum", ""]
|
2013-05-08 15:17:09 +00:00
|
|
|
|
2012-11-11 04:51:07 +00:00
|
|
|
{- Max OSX sometimes puts GNU tools outside PATH, so look in
|
|
|
|
- the location it uses, and remember where to run them
|
|
|
|
- from. -}
|
|
|
|
osxpath = "/opt/local/libexec/gnubin"
|
2012-03-10 18:00:26 +00:00
|
|
|
|
|
|
|
tmpDir :: String
|
|
|
|
tmpDir = "tmp"
|
|
|
|
|
|
|
|
testFile :: String
|
|
|
|
testFile = tmpDir ++ "/testfile"
|
|
|
|
|
|
|
|
testCp :: ConfigKey -> String -> TestCase
|
|
|
|
testCp k option = TestCase cmd $ testCmd k cmdline
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
cmd = "cp " ++ option
|
|
|
|
cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"
|
2012-03-10 18:00:26 +00:00
|
|
|
|
2013-05-10 20:36:31 +00:00
|
|
|
isReleaseBuild :: IO Bool
|
2013-05-10 22:52:35 +00:00
|
|
|
isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")
|
2013-05-10 20:36:31 +00:00
|
|
|
|
2013-04-10 20:53:04 +00:00
|
|
|
{- Version is usually based on the major version from the changelog,
|
|
|
|
- plus the date of the last commit, plus the git rev of that commit.
|
|
|
|
- This works for autobuilds, ad-hoc builds, etc.
|
|
|
|
-
|
|
|
|
- If git or a git repo is not available, or something goes wrong,
|
2013-05-10 22:52:35 +00:00
|
|
|
- or this is a release build, just use the version from the changelog. -}
|
2012-03-10 18:00:26 +00:00
|
|
|
getVersion :: Test
|
|
|
|
getVersion = do
|
2013-04-10 20:53:04 +00:00
|
|
|
changelogversion <- getChangelogVersion
|
2013-05-10 20:36:31 +00:00
|
|
|
version <- ifM (isReleaseBuild)
|
2013-04-10 20:53:04 +00:00
|
|
|
( return changelogversion
|
|
|
|
, catchDefaultIO changelogversion $ do
|
|
|
|
let major = takeWhile (/= '.') changelogversion
|
|
|
|
autoversion <- readProcess "sh"
|
|
|
|
[ "-c"
|
|
|
|
, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"
|
|
|
|
] ""
|
|
|
|
if null autoversion
|
|
|
|
then return changelogversion
|
|
|
|
else return $ concat [ major, ".", autoversion ]
|
|
|
|
)
|
2012-03-10 18:00:26 +00:00
|
|
|
return $ Config "packageversion" (StringConfig version)
|
|
|
|
|
2013-04-10 20:53:04 +00:00
|
|
|
getChangelogVersion :: IO String
|
|
|
|
getChangelogVersion = do
|
2013-05-10 20:26:53 +00:00
|
|
|
changelog <- readFile "debian/changelog"
|
|
|
|
let verline = takeWhile (/= '\n') changelog
|
2012-03-10 18:00:26 +00:00
|
|
|
return $ middle (words verline !! 1)
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
middle = drop 1 . init
|
2012-03-10 18:00:26 +00:00
|
|
|
|
|
|
|
getGitVersion :: Test
|
2013-08-02 22:31:01 +00:00
|
|
|
getGitVersion = Config "gitversion" . StringConfig . show
|
|
|
|
<$> Git.Version.installed
|
2012-03-10 18:00:26 +00:00
|
|
|
|
|
|
|
getSshConnectionCaching :: Test
|
|
|
|
getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
|
|
|
|
boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]
|
|
|
|
|
|
|
|
{- Set up cabal file with version. -}
|
|
|
|
cabalSetup :: IO ()
|
|
|
|
cabalSetup = do
|
2013-05-17 15:24:18 +00:00
|
|
|
version <- takeWhile (\c -> isDigit c || c == '.')
|
|
|
|
<$> getChangelogVersion
|
2012-03-10 18:00:26 +00:00
|
|
|
cabal <- readFile cabalfile
|
|
|
|
writeFile tmpcabalfile $ unlines $
|
|
|
|
map (setfield "Version" version) $
|
|
|
|
lines cabal
|
|
|
|
renameFile tmpcabalfile cabalfile
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
cabalfile = "git-annex.cabal"
|
|
|
|
tmpcabalfile = cabalfile++".tmp"
|
|
|
|
setfield field value s
|
|
|
|
| fullfield `isPrefixOf` s = fullfield ++ value
|
|
|
|
| otherwise = s
|
|
|
|
where
|
|
|
|
fullfield = field ++ ": "
|
2012-03-10 18:00:26 +00:00
|
|
|
|
|
|
|
setup :: IO ()
|
|
|
|
setup = do
|
|
|
|
createDirectoryIfMissing True tmpDir
|
|
|
|
writeFile testFile "test file contents"
|
|
|
|
|
|
|
|
cleanup :: IO ()
|
|
|
|
cleanup = removeDirectoryRecursive tmpDir
|
|
|
|
|
|
|
|
run :: [TestCase] -> IO ()
|
|
|
|
run ts = do
|
2013-02-11 20:56:04 +00:00
|
|
|
args <- getArgs
|
2012-03-10 18:00:26 +00:00
|
|
|
setup
|
|
|
|
config <- runTests ts
|
2013-02-11 20:56:04 +00:00
|
|
|
if args == ["Android"]
|
|
|
|
then writeSysConfig $ androidConfig config
|
|
|
|
else writeSysConfig config
|
2012-03-10 18:00:26 +00:00
|
|
|
cleanup
|
2013-05-10 20:36:31 +00:00
|
|
|
whenM (isReleaseBuild) $
|
|
|
|
cabalSetup
|
2013-02-11 20:56:04 +00:00
|
|
|
|
|
|
|
{- Hard codes some settings to cross-compile for Android. -}
|
|
|
|
androidConfig :: [Config] -> [Config]
|
|
|
|
androidConfig c = overrides ++ filter (not . overridden) c
|
|
|
|
where
|
|
|
|
overrides =
|
|
|
|
[ Config "cp_reflink_auto" $ BoolConfig False
|
|
|
|
, Config "curl" $ BoolConfig False
|
|
|
|
, Config "sha224" $ MaybeStringConfig Nothing
|
|
|
|
, Config "sha384" $ MaybeStringConfig Nothing
|
|
|
|
]
|
|
|
|
overridden (Config k _) = k `elem` overridekeys
|
|
|
|
overridekeys = map (\(Config k _) -> k) overrides
|
|
|
|
|