summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog4
-rw-r--r--doc/README.mdwn2
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/CmdLine.hs4
-rw-r--r--src/Propellor/DotDir.hs348
-rw-r--r--src/Propellor/Types/CmdLine.hs1
-rw-r--r--src/wrapper.hs353
7 files changed, 370 insertions, 343 deletions
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