From 1dc914a71c94e0395641565e5891a2dc33ba1b35 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 1 Apr 2016 21:20:13 -0400 Subject: separate propellor --init --- debian/changelog | 4 +- doc/README.mdwn | 2 +- propellor.cabal | 1 + src/Propellor/CmdLine.hs | 4 + src/Propellor/DotDir.hs | 348 ++++++++++++++++++++++++++++++++++++++++ src/Propellor/Types/CmdLine.hs | 1 + src/wrapper.hs | 353 ++--------------------------------------- 7 files changed, 370 insertions(+), 343 deletions(-) create mode 100644 src/Propellor/DotDir.hs diff --git a/debian/changelog b/debian/changelog index 21c53bf8..ae593902 100644 --- a/debian/changelog +++ b/debian/changelog @@ -64,8 +64,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium these complex new types. * Added dependency on concurrent-output; removed embedded copy. * Apt.PPA: New module, contributed by Evan Cofsky. - * Improved propellor's first run experience; the wrapper program will - now walk the user through setting up ~/.propellor, with a choice between + * Improved propellor's first run experience; propellor --init will + walk the user through setting up ~/.propellor, with a choice between a clone of propellor's git repository, or a minimal config, and will configure propellor to use a gpg key. diff --git a/doc/README.mdwn b/doc/README.mdwn index fc3c3fd1..31d222c1 100644 --- a/doc/README.mdwn +++ b/doc/README.mdwn @@ -42,7 +42,7 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask `cabal install propellor` or `apt-get install propellor` -2. Run `propellor` for the first time. It will set up a `~/.propellor/` git +2. Run `propellor --init` ; this will set up a `~/.propellor/` git repository for you. 3. Edit `~/.propellor/config.hs`, and add a host you want to manage. You can start by not adding any properties, or only a few. diff --git a/propellor.cabal b/propellor.cabal index 9f74d264..d97d4096 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -151,6 +151,7 @@ Library Propellor.Info Propellor.Message Propellor.Debug + Propellor.DotDir Propellor.PrivData Propellor.Engine Propellor.EnsureProperty diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index d93a8e3a..19e49f5a 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -16,6 +16,7 @@ import Propellor.Git.VerifiedBranch import Propellor.Bootstrap import Propellor.Spin import Propellor.Types.CmdLine +import Propellor.DotDir (interactiveInit) import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim @@ -23,6 +24,7 @@ import qualified Propellor.Shim as Shim usage :: Handle -> IO () usage h = hPutStrLn h $ unlines [ "Usage:" + , " propellor --init" , " propellor" , " propellor hostname" , " propellor --spin targethost [--via relayhost]" @@ -69,6 +71,7 @@ processCmdLine = go =<< getArgs go ("--serialized":s:[]) = serialized Serialized s go ("--continue":s:[]) = serialized Continue s go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) + go ("--init":_) = return Init go ("--run":h:[]) = go [h] go (h:[]) | "--" `isPrefixOf` h = usageError [h] @@ -130,6 +133,7 @@ defaultMain hostlist = withConcurrentOutput $ do fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn)) -- When continuing after a rebuild, don't want to rebuild again. go _ (Continue cmdline) = go NoRebuild cmdline + go _ Init = interactiveInit withhost :: HostName -> (Host -> IO ()) -> IO () withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs new file mode 100644 index 00000000..92c20654 --- /dev/null +++ b/src/Propellor/DotDir.hs @@ -0,0 +1,348 @@ +module Propellor.DotDir where + +import Propellor.Message +import Propellor.Bootstrap +import Propellor.Git +import Propellor.Gpg +import Utility.UserInfo +import Utility.Monad +import Utility.Process +import Utility.SafeCommand +import Utility.Exception +import Utility.Path + +import Data.Char +import Data.List +import Control.Monad +import Control.Monad.IfElse +import System.Directory +import System.FilePath +import System.Posix.Directory +import System.IO +import Control.Applicative +import Prelude + +distdir :: FilePath +distdir = "/usr/src/propellor" + +-- A distribution may include a bundle of propellor's git repository here. +-- If not, it will be pulled from the network when needed. +distrepo :: FilePath +distrepo = distdir "propellor.git" + +-- File containing the head rev of the distrepo. +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" + +dotPropellor :: IO FilePath +dotPropellor = do + home <- myHomeDir + return (home ".propellor") + +interactiveInit :: IO () +interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) + ( error "~/.propellor/ already exists, not doing anything" + , do + welcomeBanner + setup + ) + +welcomeBanner :: IO () +welcomeBanner = putStr $ unlines $ map prettify + [ "" + , "" + , " _ ______`| ,-.__" + , " .--------------------------- / ~___-=O`/|O`/__| (____.'" + , " - Welcome to -- ~ / | / ) _.-'-._" + , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" + , " `--------------------------- * ~ | | '--------'" + , " (o) `" + , "" + , "" + ] + where + prettify = map (replace '~' '\\') + replace x y c + | c == x = y + | otherwise = c + +prompt :: String -> [(String, IO ())] -> IO () +prompt p cs = do + putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") + hFlush stdout + r <- map toLower <$> getLine + if null r + then snd (head cs) -- default to first choice on return + else case filter (\(s, _) -> map toLower s == r) cs of + [(_, a)] -> a + _ -> do + putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)" + prompt p cs + +section :: IO () +section = do + putStrLn "" + putStrLn "---------------------------------------------------------------------------------" + putStrLn "" + +setup :: IO () +setup = do + dotpropellor <- dotPropellor + putStrLn "Propellor's configuration file is ~/.propellor/config.hs" + putStrLn "" + putStrLn "Lets get you started with a simple config that you can adapt" + putStrLn "to your needs. You can start with:" + putStrLn " A: A clone of propellor's git repository (most flexible)" + putStrLn " B: The bare minimum files to use propellor (most simple)" + prompt "Which would you prefer?" + [ ("A", fullClone) + , ("B", minimalConfig) + ] + putStrLn "Ok, ~/.propellor/config.hs is set up!" + changeWorkingDirectory dotpropellor + + section + putStrLn "Let's try building the propellor configuration, to make sure it will work..." + buildPropellor Nothing + putStrLn "Great! Propellor is bootstrapped." + + section + putStrLn "Propellor uses gpg to encrypt private data about the systems it manages," + putStrLn "and to sign git commits." + gpg <- getGpgBin + ifM (inPath gpg) + ( setupGpgKey + , do + putStrLn "You don't seem to have gpg installed, so skipping setting it up." + explainManualSetupGpgKey + ) + + section + putStrLn "Everything is set up ..." + putStrLn "Your next step is to edit ~/.propellor/config.hs," + putStrLn "and run propellor again to try it out." + putStrLn "" + putStrLn "For docs, see https://propellor.branchable.com/" + putStrLn "Enjoy propellor!" + +explainManualSetupGpgKey :: IO () +explainManualSetupGpgKey = do + putStrLn "Propellor can still be used without gpg, but it won't be able to" + putStrLn "manage private data. You can set this up later:" + putStrLn " 1. gpg --gen-key" + putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)" + +setupGpgKey :: IO () +setupGpgKey = do + ks <- listSecretKeys + putStrLn "" + case ks of + [] -> makeGpgKey + [(k, _)] -> propellorAddKey k + _ -> do + let nks = zip ks (map show ([1..] :: [Integer])) + putStrLn "I see you have several gpg keys:" + forM_ nks $ \((k, d), n) -> + putStrLn $ " " ++ n ++ " " ++ d ++ " (keyid " ++ k ++ ")" + prompt "Which of your gpg keys should propellor use?" + (map (\((k, _), n) -> (n, propellorAddKey k)) nks) + +makeGpgKey :: IO () +makeGpgKey = do + putStrLn "You seem to not have any gpg secret keys." + prompt "Would you like to create one now?" + [("Y", rungpg), ("N", nope)] + where + nope = do + putStrLn "No problem." + explainManualSetupGpgKey + rungpg = do + putStrLn "Running gpg --gen-key ..." + gpg <- getGpgBin + void $ boolSystem gpg [Param "--gen-key"] + ks <- listSecretKeys + case ks of + [] -> do + putStrLn "Hmm, gpg seemed to not set up a secret key." + prompt "Want to try running gpg again?" + [("Y", rungpg), ("N", nope)] + ((k, _):_) -> propellorAddKey k + +propellorAddKey :: String -> IO () +propellorAddKey keyid = do + putStrLn "" + putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid + d <- dotPropellor + unlessM (boolSystem (d "propellor") [Param "--add-key", Param keyid]) $ do + putStrLn "Oops, that didn't work! You can retry the same command later." + putStrLn "Continuing onward ..." + +minimalConfig :: IO () +minimalConfig = do + d <- dotPropellor + createDirectoryIfMissing True d + let cabalfile = d "config.cabal" + let configfile = d "config.hs" + writeFile cabalfile (unlines cabalcontent) + writeFile configfile (unlines configcontent) + changeWorkingDirectory d + void $ boolSystem "git" [Param "init"] + void $ boolSystem "git" [Param "add" , File cabalfile, File configfile] + where + cabalcontent = + [ "-- This is a cabal file to use to build your propellor configuration." + , "" + , "Name: config" + , "Cabal-Version: >= 1.6" + , "Build-Type: Simple" + , "Version: 0" + , "" + , "Executable propellor-config" + , " Main-Is: config.hs" + , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" + , " Extensions: TypeOperators" + , " Build-Depends: propellor >= 3.0, base >= 3" + ] + configcontent = + [ "-- This is the main configuration file for Propellor, and is used to build" + , "-- the propellor program." + , "" + , "import Propellor" + , "import qualified Propellor.Property.File as File" + , "import qualified Propellor.Property.Apt as Apt" + , "import qualified Propellor.Property.Cron as Cron" + , "import qualified Propellor.Property.User as User" + , "" + , "main :: IO ()" + , "main = defaultMain hosts" + , "" + , "-- The hosts propellor knows about." + , "hosts :: [Host]" + , "hosts =" + , " [ mybox" + , " ]" + , "" + , "-- An example host." + , "mybox :: Host" + , "mybox = host \"mybox.example.com\" $ props" + , " & osDebian Unstable \"amd64\"" + , " & Apt.stdSourcesList" + , " & Apt.unattendedUpgrades" + , " & Apt.installed [\"etckeeper\"]" + , " & Apt.installed [\"ssh\"]" + , " & User.hasSomePassword (User \"root\")" + , " & File.dirExists \"/var/www\"" + , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" + , "" + ] + +fullClone :: IO () +fullClone = do + d <- dotPropellor + ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) + ( do + void $ boolSystem "git" [Param "clone", File distrepo, File d] + fetchUpstreamBranch distrepo + changeWorkingDirectory d + void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] + , do + void $ boolSystem "git" [Param "clone", Param netrepo, File d] + changeWorkingDirectory d + -- Rename origin to upstream and avoid + -- git push to that read-only repo. + void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] + void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] + ) + +fetchUpstreamBranch :: FilePath -> IO () +fetchUpstreamBranch repo = do + changeWorkingDirectory =<< dotPropellor + void $ boolSystem "git" + [ Param "fetch" + , File repo + , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) + , Param "--quiet" + ] + +checkRepoUpToDate :: IO () +checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do + headrev <- takeWhile (/= '\n') <$> readFile disthead + changeWorkingDirectory =<< dotPropellor + headknown <- catchMaybeIO $ + withQuietOutput createProcessSuccess $ + proc "git" ["log", headrev] + if (headknown == Nothing) + then setupUpstreamMaster headrev + else do + theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef + when (theirhead /= headrev) $ do + merged <- not . null <$> + readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] + unless merged $ + warnoutofdate True + where + gitbundleavail = doesFileExist disthead + dotpropellorpopulated = do + d <- dotPropellor + doesFileExist (d "propellor.cabal") + +-- Passed the user's dotpropellor 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. +-- +-- 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 -> IO () +setupUpstreamMaster newref = do + changeWorkingDirectory =<< dotPropellor + go =<< catchMaybeIO getoldrev + where + go Nothing = warnoutofdate False + go (Just oldref) = do + let tmprepo = ".git/propellordisttmp" + let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo + cleantmprepo + git ["clone", "--quiet", ".", tmprepo] + + changeWorkingDirectory tmprepo + git ["fetch", distrepo, "--quiet"] + git ["reset", "--hard", oldref, "--quiet"] + git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] + + fetchUpstreamBranch tmprepo + cleantmprepo + warnoutofdate True + + 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 :: Bool -> IO () +warnoutofdate havebranch = do + warningMessage ("** Your ~/.propellor/ is out of date..") + let also s = hPutStrLn stderr (" " ++ s) + also ("A newer upstream version is available in " ++ distrepo) + if havebranch + 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.") + also "" diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs index 558c6e8b..0773d9d9 100644 --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -28,4 +28,5 @@ data CmdLine | ChrootChain HostName FilePath Bool Bool | GitPush Fd Fd | Check + | Init deriving (Read, Show, Eq) diff --git a/src/wrapper.hs b/src/wrapper.hs index 32e036da..1a90fcb0 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -9,360 +9,33 @@ module Main where +import Propellor.DotDir import Propellor.Message import Propellor.Bootstrap -import Propellor.Git -import Propellor.Gpg -import Utility.UserInfo import Utility.Monad import Utility.Process -import Utility.SafeCommand -import Utility.Exception -import Utility.Path -import Data.Char -import Data.List -import Control.Monad -import Control.Monad.IfElse import System.Directory -import System.FilePath import System.Environment (getArgs) import System.Exit import System.Posix.Directory -import System.IO -import Control.Applicative -import Prelude - -distdir :: FilePath -distdir = "/usr/src/propellor" - --- A distribution may include a bundle of propellor's git repository here. --- If not, it will be pulled from the network when needed. -distrepo :: FilePath -distrepo = distdir "propellor.git" - --- File containing the head rev of the distrepo. -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 = withConcurrentOutput $ do - args <- getArgs - home <- myHomeDir - let dotpropellor = home ".propellor" - ifM (doesDirectoryExist dotpropellor) +main = withConcurrentOutput $ go =<< getArgs + where + go ["--init"] = interactiveInit + go args = ifM (doesDirectoryExist =<< dotPropellor) ( do - checkRepoUpToDate dotpropellor - buildRunConfig dotpropellor args - , do - welcomeBanner - setup dotpropellor + checkRepoUpToDate + buildRunConfig args + , error "Seems that ~/.propellor/ does not exist. To set it up, run: propellor --init" ) -buildRunConfig :: FilePath -> [String] -> IO () -buildRunConfig dotpropellor args = do - changeWorkingDirectory dotpropellor - buildPropellor Nothing - putStrLn "" - putStrLn "" - chain - where - propellorbin = dotpropellor "propellor" - chain = do - (_, _, _, pid) <- createProcess (proc propellorbin args) - exitWith =<< waitForProcess pid - -welcomeBanner :: IO () -welcomeBanner = putStr $ unlines $ map prettify - [ "" - , "" - , " _ ______`| ,-.__" - , " .--------------------------- / ~___-=O`/|O`/__| (____.'" - , " - Welcome to -- ~ / | / ) _.-'-._" - , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" - , " `--------------------------- * ~ | | '--------'" - , " (o) `" - , "" - , "" - ] - where - prettify = map (replace '~' '\\') - replace x y c - | c == x = y - | otherwise = c - -prompt :: String -> [(String, IO ())] -> IO () -prompt p cs = do - putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") - hFlush stdout - r <- map toLower <$> getLine - if null r - then snd (head cs) -- default to first choice on return - else case filter (\(s, _) -> map toLower s == r) cs of - [(_, a)] -> a - _ -> do - putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)" - prompt p cs - -section :: IO () -section = do - putStrLn "" - putStrLn "---------------------------------------------------------------------------------" - putStrLn "" - -setup :: FilePath -> IO () -setup dotpropellor = do - putStrLn "Propellor's configuration file is ~/.propellor/config.hs" - putStrLn "" - putStrLn "Lets get you started with a simple config that you can adapt" - putStrLn "to your needs. You can start with:" - putStrLn " A: A clone of propellor's git repository (most flexible)" - putStrLn " B: The bare minimum files to use propellor (most simple)" - prompt "Which would you prefer?" - [ ("A", fullClone dotpropellor) - , ("B", minimalConfig dotpropellor) - ] - putStrLn "Ok, ~/.propellor/config.hs is set up!" - changeWorkingDirectory dotpropellor - - section - putStrLn "Let's try building the propellor configuration, to make sure it will work..." +buildRunConfig :: [String] -> IO () +buildRunConfig args = do + changeWorkingDirectory =<< dotPropellor buildPropellor Nothing - putStrLn "Great! Propellor is bootstrapped." - - section - putStrLn "Propellor uses gpg to encrypt private data about the systems it manages," - putStrLn "and to sign git commits." - gpg <- getGpgBin - ifM (inPath gpg) - ( setupGpgKey dotpropellor - , do - putStrLn "You don't seem to have gpg installed, so skipping setting it up." - explainManualSetupGpgKey - ) - - section - putStrLn "Everything is set up ..." - putStrLn "Your next step is to edit ~/.propellor/config.hs," - putStrLn "and run propellor again to try it out." putStrLn "" - putStrLn "For docs, see https://propellor.branchable.com/" - putStrLn "Enjoy propellor!" - -explainManualSetupGpgKey :: IO () -explainManualSetupGpgKey = do - putStrLn "Propellor can still be used without gpg, but it won't be able to" - putStrLn "manage private data. You can set this up later:" - putStrLn " 1. gpg --gen-key" - putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)" - -setupGpgKey :: FilePath -> IO () -setupGpgKey dotpropellor = do - ks <- listSecretKeys - putStrLn "" - case ks of - [] -> makeGpgKey dotpropellor - [(k, _)] -> propellorAddKey dotpropellor k - _ -> do - let nks = zip ks (map show ([1..] :: [Integer])) - putStrLn "I see you have several gpg keys:" - forM_ nks $ \((k, d), n) -> - putStrLn $ " " ++ n ++ " " ++ d ++ " (keyid " ++ k ++ ")" - prompt "Which of your gpg keys should propellor use?" - (map (\((k, _), n) -> (n, propellorAddKey dotpropellor k)) nks) - -makeGpgKey :: FilePath -> IO () -makeGpgKey dotpropellor = do - putStrLn "You seem to not have any gpg secret keys." - prompt "Would you like to create one now?" - [("Y", rungpg), ("N", nope)] - where - nope = do - putStrLn "No problem." - explainManualSetupGpgKey - rungpg = do - putStrLn "Running gpg --gen-key ..." - gpg <- getGpgBin - void $ boolSystem gpg [Param "--gen-key"] - ks <- listSecretKeys - case ks of - [] -> do - putStrLn "Hmm, gpg seemed to not set up a secret key." - prompt "Want to try running gpg again?" - [("Y", rungpg), ("N", nope)] - ((k, _):_) -> propellorAddKey dotpropellor k - -propellorAddKey :: FilePath -> String -> IO () -propellorAddKey dotpropellor keyid = do putStrLn "" - putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid - unlessM (boolSystem propellorbin [Param "--add-key", Param keyid]) $ do - putStrLn "Oops, that didn't work! You can retry the same command later." - putStrLn "Continuing onward ..." - where - propellorbin = dotpropellor "propellor" - -minimalConfig :: FilePath -> IO () -minimalConfig dotpropellor = do - createDirectoryIfMissing True dotpropellor - writeFile cabalfile (unlines cabalcontent) - writeFile configfile (unlines configcontent) - changeWorkingDirectory dotpropellor - void $ boolSystem "git" [Param "init"] - void $ boolSystem "git" [Param "add" , File cabalfile, File configfile] - where - cabalfile = dotpropellor "config.cabal" - configfile = dotpropellor "config.hs" - cabalcontent = - [ "-- This is a cabal file to use to build your propellor configuration." - , "" - , "Name: config" - , "Cabal-Version: >= 1.6" - , "Build-Type: Simple" - , "Version: 0" - , "" - , "Executable propellor-config" - , " Main-Is: config.hs" - , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" - , " Extensions: TypeOperators" - , " Build-Depends: propellor >= 3.0, base >= 3" - ] - configcontent = - [ "-- This is the main configuration file for Propellor, and is used to build" - , "-- the propellor program." - , "" - , "import Propellor" - , "import qualified Propellor.Property.File as File" - , "import qualified Propellor.Property.Apt as Apt" - , "import qualified Propellor.Property.Cron as Cron" - , "import qualified Propellor.Property.User as User" - , "" - , "main :: IO ()" - , "main = defaultMain hosts" - , "" - , "-- The hosts propellor knows about." - , "hosts :: [Host]" - , "hosts =" - , " [ mybox" - , " ]" - , "" - , "-- An example host." - , "mybox :: Host" - , "mybox = host \"mybox.example.com\" $ props" - , " & osDebian Unstable \"amd64\"" - , " & Apt.stdSourcesList" - , " & Apt.unattendedUpgrades" - , " & Apt.installed [\"etckeeper\"]" - , " & Apt.installed [\"ssh\"]" - , " & User.hasSomePassword (User \"root\")" - , " & File.dirExists \"/var/www\"" - , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" - , "" - ] - -fullClone :: FilePath -> IO () -fullClone dotpropellor = ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) - ( do - void $ boolSystem "git" [Param "clone", File distrepo, File dotpropellor] - fetchUpstreamBranch dotpropellor distrepo - changeWorkingDirectory dotpropellor - void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] - , do - void $ boolSystem "git" [Param "clone", Param netrepo, File dotpropellor] - changeWorkingDirectory dotpropellor - -- Rename origin to upstream and avoid - -- git push to that read-only repo. - void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] - void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] - ) - -checkRepoUpToDate :: FilePath -> IO () -checkRepoUpToDate dotpropellor = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do - headrev <- takeWhile (/= '\n') <$> readFile disthead - changeWorkingDirectory dotpropellor - headknown <- catchMaybeIO $ - withQuietOutput createProcessSuccess $ - proc "git" ["log", headrev] - if (headknown == Nothing) - then setupUpstreamMaster headrev dotpropellor - else do - theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef - when (theirhead /= headrev) $ do - merged <- not . null <$> - readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] - unless merged $ - warnoutofdate dotpropellor True - where - gitbundleavail = doesFileExist disthead - dotpropellorpopulated = doesFileExist (dotpropellor "propellor.cabal") - --- Passed the user's dotpropellor 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. --- --- 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 dotpropellor = do - changeWorkingDirectory dotpropellor - go =<< catchMaybeIO getoldrev - where - go Nothing = warnoutofdate dotpropellor False - go (Just oldref) = do - let tmprepo = ".git/propellordisttmp" - let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo - cleantmprepo - git ["clone", "--quiet", ".", tmprepo] - - changeWorkingDirectory tmprepo - git ["fetch", distrepo, "--quiet"] - git ["reset", "--hard", oldref, "--quiet"] - git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] - - fetchUpstreamBranch dotpropellor tmprepo - cleantmprepo - warnoutofdate dotpropellor True - - 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 :: FilePath -> Bool -> IO () -warnoutofdate dotpropellor havebranch = do - warningMessage ("** Your " ++ dotpropellor ++ " is out of date..") - let also s = hPutStrLn stderr (" " ++ s) - also ("A newer upstream version is available in " ++ distrepo) - if havebranch - 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.") - also "" - -fetchUpstreamBranch :: FilePath -> FilePath -> IO () -fetchUpstreamBranch dotpropellor repo = do - changeWorkingDirectory dotpropellor - void $ boolSystem "git" - [ Param "fetch" - , File repo - , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) - , Param "--quiet" - ] + (_, _, _, pid) <- createProcess (proc "./propellor" args) + exitWith =<< waitForProcess pid -- cgit v1.2.3