propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

DotDir.hs (14089B)


      1 module Propellor.DotDir
      2 	( distrepo
      3 	, dotPropellor
      4 	, interactiveInit
      5 	, checkRepoUpToDate
      6 	) where
      7 
      8 import Propellor.Message
      9 import Propellor.Bootstrap
     10 import Propellor.Git
     11 import Propellor.Gpg
     12 import Propellor.Types.Result
     13 import Utility.UserInfo
     14 import Utility.Monad
     15 import Utility.Process
     16 import Utility.SafeCommand
     17 import Utility.Exception
     18 import Utility.Directory
     19 import Utility.Path
     20 -- This module is autogenerated by the build system.
     21 import qualified Paths_propellor as Package
     22 
     23 import Data.Char
     24 import Data.List
     25 import Data.Version
     26 import Control.Monad
     27 import Control.Monad.IfElse
     28 import System.FilePath
     29 import System.Posix.Directory
     30 import System.IO
     31 import System.Console.Concurrent
     32 import Control.Applicative
     33 import Prelude
     34 
     35 distdir :: FilePath
     36 distdir = "/usr/src/propellor"
     37 
     38 -- A distribution may include a bundle of propellor's git repository here.
     39 -- If not, it will be pulled from the network when needed.
     40 distrepo :: FilePath
     41 distrepo = distdir </> "propellor.git"
     42 
     43 -- File containing the head rev of the distrepo.
     44 disthead :: FilePath
     45 disthead = distdir </> "head"
     46 
     47 upstreambranch :: String
     48 upstreambranch = "upstream/master"
     49 
     50 -- Using the joeyh.name mirror of the main propellor repo because
     51 -- it is accessible over https for better security.
     52 netrepo :: String
     53 netrepo = "https://git.joeyh.name/git/propellor.git"
     54 
     55 dotPropellor :: IO FilePath
     56 dotPropellor = do
     57 	home <- myHomeDir
     58 	return (home </> ".propellor")
     59 
     60 -- Detect if propellor was built using stack. This is somewhat of a hack.
     61 buildSystem :: IO String
     62 buildSystem = do
     63 	d <- Package.getLibDir
     64 	return $ if "stack-work" `isInfixOf` d then "stack" else "cabal"
     65 
     66 interactiveInit :: IO ()
     67 interactiveInit = ifM (doesDirectoryExist =<< dotPropellor)
     68 	( error "~/.propellor/ already exists, not doing anything"
     69 	, do
     70 		welcomeBanner
     71 		setup
     72 	)
     73 
     74 -- | Determine whether we need to create a cabal sandbox in ~/.propellor/,
     75 -- which we do if the user has configured cabal to require a sandbox, and the
     76 -- build system is cabal.
     77 cabalSandboxRequired :: IO Bool
     78 cabalSandboxRequired = ifM cabal
     79 	( do
     80 		home <- myHomeDir
     81 		ls <- lines <$> catchDefaultIO []
     82 			(readFile (home </> ".cabal" </> "config"))
     83 		-- For simplicity, we assume a sane ~/.cabal/config here:
     84 		return $ any ("True" `isInfixOf`) $
     85 			filter ("require-sandbox:" `isPrefixOf`) ls
     86 	, return False
     87 	)
     88   where
     89 	cabal = buildSystem >>= \bSystem -> return (bSystem == "cabal")
     90 
     91 say :: String -> IO ()
     92 say = outputConcurrent
     93 
     94 sayLn :: String -> IO ()
     95 sayLn s = say (s ++ "\n")
     96 
     97 welcomeBanner :: IO ()
     98 welcomeBanner = say $ unlines $ map prettify
     99 	[ ""
    100 	, ""
    101 	, "                                 _         ______`|                     ,-.__"
    102 	, " .---------------------------  /   ~___-=O`/|O`/__|                    (____.'"
    103 	, "  - Welcome to              -- ~          / | /    )        _.-'-._"
    104 	, "  -            Propellor!   --  `/-==__ _/__|/__=-|        (       ~_"
    105 	, " `---------------------------   *             ~ | |         '--------'"
    106 	, "                                            (o)  `"
    107 	, ""
    108 	, ""
    109 	]
    110   where
    111 	prettify = map (replace '~' '\\')
    112 	replace x y c
    113 		| c == x = y
    114 		| otherwise = c
    115 
    116 prompt :: String -> [(String, IO ())] -> IO ()
    117 prompt p cs = do
    118 	say (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")
    119 	flushConcurrentOutput
    120 	hFlush stdout
    121 	r <- map toLower <$> getLine
    122 	if null r
    123 		then snd (head cs) -- default to first choice on return
    124 		else case filter (\(s, _) -> map toLower s == r) cs of
    125 			[(_, a)] -> a
    126 			_ -> do
    127 				sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
    128 				prompt p cs
    129 
    130 section :: IO ()
    131 section = do
    132 	sayLn ""
    133 	sayLn "------------------------------------------------------------------------------"
    134 	sayLn ""
    135 
    136 setup :: IO ()
    137 setup = do
    138 	sayLn "Propellor's configuration file is ~/.propellor/config.hs"
    139 	sayLn ""
    140 	sayLn "Let's get you started with a simple config that you can adapt"
    141 	sayLn "to your needs. You can start with:"
    142 	sayLn "   A: A clone of propellor's git repository    (most flexible)"
    143 	sayLn "   B: The bare minimum files to use propellor  (most simple)"
    144 	prompt "Which would you prefer?"
    145 		[ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone)
    146 		, ("B", void $ actionMessage "Creating minimal config" minimalConfig)
    147 		]
    148 	changeWorkingDirectory =<< dotPropellor
    149 
    150 	section
    151 	sayLn "Let's try building the propellor configuration, to make sure it will work..."
    152 	sayLn ""
    153 	b <- buildSystem
    154 	void $ boolSystem "git"
    155 		[ Param "config"
    156 		, Param "propellor.buildsystem"
    157 		, Param b
    158 		]
    159 	ifM cabalSandboxRequired
    160 		( void $ boolSystem "cabal"
    161 			[ Param "sandbox"
    162 			, Param "init"
    163 			]
    164 		, return ()
    165 		)
    166 	buildPropellor Nothing
    167 	sayLn ""
    168 	sayLn "Great! Propellor is bootstrapped."
    169 
    170 	section
    171 	sayLn "Propellor can use gpg to encrypt private data about the systems it manages,"
    172 	sayLn "and to sign git commits."
    173 	gpg <- getGpgBin
    174 	ifM (inPath gpg)
    175 		( setupGpgKey
    176 		, do
    177 			sayLn "You don't seem to have gpg installed, so skipping setting it up."
    178 			explainManualSetupGpgKey
    179 		)
    180 
    181 	section
    182 	sayLn "Everything is set up ..."
    183 	sayLn "Your next step is to edit ~/.propellor/config.hs"
    184 	sayLn "and run propellor again to try it out."
    185 	sayLn ""
    186 	sayLn "For docs, see https://propellor.branchable.com/"
    187 	sayLn "Enjoy propellor!"
    188 
    189 explainManualSetupGpgKey :: IO ()
    190 explainManualSetupGpgKey = do
    191 	sayLn "Propellor can still be used without gpg, but it won't be able to"
    192 	sayLn "manage private data. You can set this up later:"
    193 	sayLn " 1. gpg --gen-key"
    194 	sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
    195 
    196 setupGpgKey :: IO ()
    197 setupGpgKey = do
    198 	ks <- listSecretKeys
    199 	sayLn ""
    200 	case ks of
    201 		[] -> makeGpgKey
    202 		[(k, d)] -> do
    203 			sayLn $ "You have one gpg key: " ++ desckey k d
    204 			prompt "Should propellor use that key?"
    205 				[ ("Y", propellorAddKey k)
    206 				, ("N", sayLn $ "Skipping gpg setup. If you change your mind, run: propellor --add-key " ++ k)
    207 				]
    208 		_ -> do
    209 			let nks = zip ks (map show ([1..] :: [Integer]))
    210 			sayLn "I see you have several gpg keys:"
    211 			forM_ nks $ \((k, d), n) ->
    212 				sayLn $ "   " ++ n ++ "   " ++ desckey k d
    213 			prompt "Which of your gpg keys should propellor use?"
    214 				(map (\((k, _), n) -> (n, propellorAddKey k)) nks)
    215   where
    216 	desckey k d = d ++ "  (keyid " ++ k ++ ")"
    217 
    218 makeGpgKey :: IO ()
    219 makeGpgKey = do
    220 	sayLn "You seem to not have any gpg secret keys."
    221 	prompt "Would you like to create one now?"
    222 		[("Y", rungpg), ("N", nope)]
    223   where
    224 	nope = do
    225 		sayLn "No problem."
    226 		explainManualSetupGpgKey
    227 	rungpg = do
    228 		sayLn "Running gpg --gen-key ..."
    229 		gpg <- getGpgBin
    230 		void $ boolSystem gpg [Param "--gen-key"]
    231 		ks <- listSecretKeys
    232 		case ks of
    233 			[] -> do
    234 				sayLn "Hmm, gpg seemed to not set up a secret key."
    235 				prompt "Want to try running gpg again?"
    236 					[("Y", rungpg), ("N", nope)]
    237 			((k, _):_) -> propellorAddKey k
    238 
    239 propellorAddKey :: String -> IO ()
    240 propellorAddKey keyid = do
    241 	sayLn ""
    242 	sayLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid
    243 	d <- dotPropellor
    244 	unlessM (boolSystem (d </> "propellor") [Param "--add-key", Param keyid]) $ do
    245 		sayLn "Oops, that didn't work! You can retry the same command later."
    246 		sayLn "Continuing onward ..."
    247 
    248 minimalConfig :: IO Result
    249 minimalConfig = do
    250 	d <- dotPropellor
    251 	createDirectoryIfMissing True d
    252 	changeWorkingDirectory d
    253 	void $ boolSystem "git" [Param "init"]
    254 	addfile "config.cabal" cabalcontent
    255 	addfile "config.hs" configcontent
    256 	addfile "stack.yaml" stackcontent
    257 	return MadeChange
    258   where
    259 	addfile f content = do
    260 		writeFile f (unlines content)
    261 		void $ boolSystem "git" [Param "add" , File f]
    262 	cabalcontent =
    263 		[ "-- This is a cabal file to use to build your propellor configuration."
    264 		, ""
    265 		, "Name: config"
    266 		, "Cabal-Version: >= 1.6"
    267 		, "Build-Type: Simple"
    268 		, "Version: 0"
    269 		, ""
    270 		, "Executable propellor-config"
    271 		, "  Main-Is: config.hs"
    272 		, "  GHC-Options: -threaded -Wall -fno-warn-tabs -O0"
    273 		, "  Extensions: TypeOperators"
    274 		, "  Build-Depends: propellor >= 3.0, base >= 4.9"
    275 		]
    276 	configcontent =
    277 		[ "-- This is the main configuration file for Propellor, and is used to build"
    278 		, "-- the propellor program.    https://propellor.branchable.com/"
    279 		, ""
    280 		, "import Propellor"
    281 		, "import qualified Propellor.Property.File as File"
    282 		, "import qualified Propellor.Property.Apt as Apt"
    283 		, "import qualified Propellor.Property.Cron as Cron"
    284 		, "import qualified Propellor.Property.User as User"
    285 		, ""
    286 		, "main :: IO ()"
    287 		, "main = defaultMain hosts"
    288 		, ""
    289 		, "-- The hosts propellor knows about."
    290 		, "hosts :: [Host]"
    291 		, "hosts ="
    292 		, "        [ mybox"
    293 		, "        ]"
    294 		, ""
    295 		, "-- An example host."
    296 		, "mybox :: Host"
    297 		, "mybox = host \"mybox.example.com\" $ props"
    298 		, "        & osDebian Unstable X86_64"
    299 		, "        & Apt.stdSourcesList"
    300 		, "        & Apt.unattendedUpgrades"
    301 		, "        & Apt.installed [\"etckeeper\"]"
    302 		, "        & Apt.installed [\"ssh\"]"
    303 		, "        & User.hasSomePassword (User \"root\")"
    304 		, "        & File.dirExists \"/var/www\""
    305 		, "        & Cron.runPropellor (Cron.Times \"30 * * * *\")"
    306 		, ""
    307 		]
    308 	stackcontent =
    309 		-- This should be the same resolver version in propellor's
    310 		-- own stack.yaml
    311 		[ "resolver: " ++ stackResolver
    312 		, "packages:"
    313 		, "- '.'"
    314 		, "extra-deps:"
    315 		, "- propellor-" ++ showVersion Package.version
    316 		]
    317 
    318 stackResolver :: String
    319 stackResolver = "lts-9.21"
    320 
    321 fullClone :: IO Result
    322 fullClone = do
    323 	d <- dotPropellor
    324 	let enterdotpropellor = changeWorkingDirectory d >> return True
    325 	ok <- ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
    326 		( allM id
    327 			[ boolSystem "git" [Param "clone", File distrepo, File d]
    328 			, fetchUpstreamBranch distrepo
    329 			, enterdotpropellor
    330 			, boolSystem "git" [Param "remote", Param "rm", Param "origin"]
    331 			]
    332 		, allM id
    333 			[ boolSystem "git" [Param "clone", Param netrepo, File d]
    334 			, enterdotpropellor
    335 			-- Rename origin to upstream and avoid
    336 			-- git push to that read-only repo.
    337 			, boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]
    338 			, boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"]
    339 			]
    340 		)
    341 	return (toResult ok)
    342 
    343 fetchUpstreamBranch :: FilePath -> IO Bool
    344 fetchUpstreamBranch repo = do
    345 	changeWorkingDirectory =<< dotPropellor
    346 	boolSystem "git"
    347 		[ Param "fetch"
    348 		, File repo
    349 		, Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch)
    350 		, Param "--quiet"
    351 		]
    352 
    353 checkRepoUpToDate :: IO ()
    354 checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do
    355 	headrev <- takeWhile (/= '\n') <$> readFile disthead
    356 	changeWorkingDirectory =<< dotPropellor
    357 	headknown <- catchMaybeIO $
    358 		withQuietOutput createProcessSuccess $
    359 			proc "git" ["log", headrev]
    360 	if (headknown == Nothing)
    361 		then updateUpstreamMaster headrev
    362 		else do
    363 			theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef
    364 			when (theirhead /= headrev) $ do
    365 				merged <- not . null <$>
    366 					readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"]
    367 				unless merged $
    368 					warnoutofdate True
    369   where
    370 	gitbundleavail = doesFileExist disthead
    371 	dotpropellorpopulated = do
    372 		d <- dotPropellor
    373 		doesFileExist (d </> "propellor.cabal")
    374 
    375 -- Updates upstream/master in dotPropellor so merging from it will update
    376 -- to the latest distrepo.
    377 --
    378 -- We cannot just fetch the distrepo because the distrepo contains only 
    379 -- 1 commit. So, trying to merge with it will result in lots of merge
    380 -- conflicts, since git cannot find a common parent commit.
    381 --
    382 -- Instead, the new upstream/master branch is updated by taking the
    383 -- current upstream/master branch (which must be an old version of propellor,
    384 -- as distributed), and diffing from it to the current origin/master,
    385 -- and committing the result. This is done in a temporary clone of the
    386 -- repository, giving it a new master branch. That new branch is fetched
    387 -- into the user's repository, as if fetching from a upstream remote,
    388 -- yielding a new upstream/master branch.
    389 --
    390 -- If there's no upstream/master, or the repo is not using the distrepo,
    391 -- do nothing.
    392 updateUpstreamMaster :: String -> IO ()
    393 updateUpstreamMaster newref = do
    394 	changeWorkingDirectory =<< dotPropellor
    395 	go =<< getoldref
    396   where
    397 	go Nothing = return ()
    398 	go (Just oldref) = do
    399 		let tmprepo = ".git/propellordisttmp"
    400 		let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo
    401 		cleantmprepo
    402 		git ["clone", "--quiet", ".", tmprepo]
    403 
    404 		changeWorkingDirectory tmprepo
    405 		git ["fetch", distrepo, "--quiet"]
    406 		git ["reset", "--hard", oldref, "--quiet"]
    407 		v <- gitVersion
    408 		let mergeparams =
    409 			[ "merge", newref
    410 			, "-s", "recursive"
    411 			, "-Xtheirs"
    412 			, "--quiet"
    413 			, "-m", "merging upstream version"
    414 			] ++ if v >= [2,9]
    415 				then [ "--allow-unrelated-histories" ]
    416 				else []
    417 		git mergeparams
    418 
    419 		void $ fetchUpstreamBranch tmprepo
    420 		cleantmprepo
    421 		warnoutofdate True
    422 
    423 	git = run "git"
    424 	run cmd ps = unlessM (boolSystem cmd (map Param ps)) $
    425 		error $ "Failed to run " ++ cmd ++ " " ++ show ps
    426 
    427 	-- Get ref that the upstreambranch points to, only when
    428 	-- the distrepo is being used.
    429 	getoldref = do
    430 		mref <- catchMaybeIO $ takeWhile (/= '\n')
    431 			<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
    432 		case mref of
    433 			Just _ -> do
    434 				-- Normally there will be no upstream
    435 				-- remote when the distrepo is used.
    436 				-- Older versions of propellor set up
    437 				-- an upstream remote pointing at the 
    438 				-- distrepo.
    439 				ifM (hasRemote "upstream")
    440 					( do
    441 						v <- remoteUrl "upstream"
    442 						return $ case v of
    443 							Just rurl | rurl == distrepo -> mref
    444 							_ -> Nothing
    445 					, return mref
    446 					)
    447 			Nothing -> return mref
    448 
    449 warnoutofdate :: Bool -> IO ()
    450 warnoutofdate havebranch = warningMessage $ unlines
    451 	[ "** Your ~/.propellor/ is out of date.."
    452 	, indent "A newer upstream version is available in " ++ distrepo
    453 	, indent $ if havebranch
    454 		then "To merge it, run: git merge " ++ upstreambranch
    455 		else "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."
    456 	]
    457   where
    458 	indent s = "   " ++ s