propellor/src/wrapper.hs

161 lines
5.2 KiB
Haskell
Raw Normal View History

-- | Wrapper program for propellor distribution.
--
-- Distributions should install this program into PATH.
2014-06-09 16:34:32 +00:00
-- (Cabal builds it as dist/build/propellor/propellor).
--
-- This is not the propellor main program (that's config.hs)
--
-- This installs propellor's source into ~/.propellor,
-- uses it to build the real propellor program (if not already built),
-- and runs it.
--
-- The source is cloned from /usr/src/propellor when available,
-- or is cloned from git over the network.
module Main where
2014-08-19 21:12:57 +00:00
import Propellor.Message
import Utility.UserInfo
import Utility.Monad
import Utility.Process
import Utility.SafeCommand
import Utility.Exception
import Control.Monad
import Control.Monad.IfElse
2014-08-19 20:44:51 +00:00
import Control.Applicative
import System.Directory
import System.FilePath
import System.Environment (getArgs)
import System.Exit
import System.Posix.Directory
import System.IO
2014-08-19 19:29:32 +00:00
distdir :: FilePath
distdir = "/usr/src/propellor"
distrepo :: FilePath
2014-08-19 19:29:32 +00:00
distrepo = distdir </> "propellor.git"
disthead :: FilePath
disthead = distdir </> "head"
upstreambranch :: String
upstreambranch = "upstream/master"
-- Using the github mirror of the main propellor repo because
-- it is accessible over https for better security.
netrepo :: String
netrepo = "https://github.com/joeyh/propellor.git"
main :: IO ()
main = do
args <- getArgs
home <- myHomeDir
let propellordir = home </> ".propellor"
let propellorbin = propellordir </> "propellor"
wrapper args propellordir propellorbin
wrapper :: [String] -> FilePath -> FilePath -> IO ()
wrapper args propellordir propellorbin = do
ifM (doesDirectoryExist propellordir)
( checkRepo
, makeRepo
)
buildruncfg
where
makeRepo = do
putStrLn $ "Setting up your propellor repo in " ++ propellordir
putStrLn ""
ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
( do
void $ boolSystem "git" [Param "clone", File distrepo, File propellordir]
fetchUpstreamBranch propellordir distrepo
changeWorkingDirectory propellordir
void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]
, void $ boolSystem "git" [Param "clone", Param netrepo, File propellordir]
)
checkRepo = whenM (doesFileExist disthead) $ do
2014-08-19 20:44:51 +00:00
headrev <- takeWhile (/= '\n') <$> readFile disthead
changeWorkingDirectory propellordir
headknown <- catchMaybeIO $
withQuietOutput createProcessSuccess $
2014-08-19 19:23:29 +00:00
proc "git" ["log", headrev]
when (headknown == Nothing) $
setupupstreammaster headrev propellordir
buildruncfg = do
changeWorkingDirectory propellordir
ifM (boolSystem "make" [Param "build"])
( do
putStrLn ""
putStrLn ""
chain
, error "Propellor build failed."
)
chain = do
(_, _, _, pid) <- createProcess (proc propellorbin args)
exitWith =<< waitForProcess pid
-- Passed the user's propellordir repository, makes upstream/master
-- be a usefully mergeable branch.
--
-- We cannot just use origin/master, because in the case of a distrepo,
-- it only contains 1 commit. So, trying to merge with it will result
-- in lots of merge conflicts, since git cannot find a common parent
-- commit.
--
2014-08-19 21:51:34 +00:00
-- Instead, the upstream/master branch is created by taking the
-- upstream/master branch (which must be an old version of propellor,
-- as distributed), and diffing from it to the current origin/master,
-- and committing the result. This is done in a temporary clone of the
-- repository, giving it a new master branch. That new branch is fetched
-- into the user's repository, as if fetching from a upstream remote,
-- yielding a new upstream/master branch.
setupupstreammaster :: String -> FilePath -> IO ()
setupupstreammaster newref propellordir = do
changeWorkingDirectory propellordir
2014-08-19 21:09:11 +00:00
go =<< catchMaybeIO getoldrev
where
go Nothing = warnoutofdate False
go (Just oldref) = do
let tmprepo = ".git/propellordisttmp"
2014-08-19 21:09:11 +00:00
let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo
cleantmprepo
git ["clone", "--quiet", ".", tmprepo]
changeWorkingDirectory tmprepo
git ["fetch", distrepo, "--quiet"]
git ["reset", "--hard", oldref, "--quiet"]
2014-08-19 21:59:15 +00:00
git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"]
fetchUpstreamBranch propellordir tmprepo
2014-08-19 21:09:11 +00:00
cleantmprepo
warnoutofdate True
2014-08-19 21:09:11 +00:00
getoldrev = takeWhile (/= '\n')
<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
git = run "git"
run cmd ps = unlessM (boolSystem cmd (map Param ps)) $
error $ "Failed to run " ++ cmd ++ " " ++ show ps
warnoutofdate havebranch = do
2014-08-19 21:17:01 +00:00
warningMessage ("** Your " ++ propellordir ++ " is out of date..")
2014-08-19 21:12:57 +00:00
let also s = hPutStrLn stderr (" " ++ s)
2014-08-19 21:17:01 +00:00
also ("A newer upstream version is available in " ++ distrepo)
if havebranch
2014-08-19 21:17:01 +00:00
then also ("To merge it, run: git merge " ++ upstreambranch)
else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.")
2014-08-19 21:17:36 +00:00
also ""
fetchUpstreamBranch :: FilePath -> FilePath -> IO ()
fetchUpstreamBranch propellordir repo = do
changeWorkingDirectory propellordir
void $ boolSystem "git"
[ Param "fetch"
, File repo
, Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch)
, Param "--quiet"
]