module Propellor.DotDir
( distrepo
, dotPropellor
, interactiveInit
, checkRepoUpToDate
) where
import Propellor.Message
import Propellor.Bootstrap
import Propellor.Git
import Propellor.Gpg
import Propellor.Types.Result
import Utility.UserInfo
import Utility.Monad
import Utility.Process
import Utility.SafeCommand
import Utility.Exception
import Utility.Directory
import Utility.Path
import qualified Paths_propellor as Package
import Data.Char
import Data.List
import Data.Version
import Control.Monad
import Control.Monad.IfElse
import System.FilePath
import System.Posix.Directory
import System.IO
import System.Console.Concurrent
import Control.Applicative
import Prelude
distdir :: FilePath
distdir = "/usr/src/propellor"
distrepo :: FilePath
distrepo = distdir </> "propellor.git"
disthead :: FilePath
disthead = distdir </> "head"
upstreambranch :: String
upstreambranch = "upstream/master"
netrepo :: String
netrepo = "https://git.joeyh.name/git/propellor.git"
dotPropellor :: IO FilePath
dotPropellor = do
home <- myHomeDir
return (home </> ".propellor")
buildSystem :: IO String
buildSystem = do
d <- Package.getLibDir
return $ if "stack-work" `isInfixOf` d then "stack" else "cabal"
interactiveInit :: IO ()
interactiveInit = ifM (doesDirectoryExist =<< dotPropellor)
( error "~/.propellor/ already exists, not doing anything"
, do
welcomeBanner
setup
)
cabalSandboxRequired :: IO Bool
cabalSandboxRequired = ifM cabal
( do
home <- myHomeDir
ls <- lines <$> catchDefaultIO []
(readFile (home </> ".cabal" </> "config"))
return $ any ("True" `isInfixOf`) $
filter ("require-sandbox:" `isPrefixOf`) ls
, return False
)
where
cabal = buildSystem >>= \bSystem -> return (bSystem == "cabal")
say :: String -> IO ()
say = outputConcurrent
sayLn :: String -> IO ()
sayLn s = say (s ++ "\n")
welcomeBanner :: IO ()
welcomeBanner = say $ 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
say (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")
flushConcurrentOutput
hFlush stdout
r <- map toLower <$> getLine
if null r
then snd (head cs)
else case filter (\(s, _) -> map toLower s == r) cs of
[(_, a)] -> a
_ -> do
sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
prompt p cs
section :: IO ()
section = do
sayLn ""
sayLn "------------------------------------------------------------------------------"
sayLn ""
setup :: IO ()
setup = do
sayLn "Propellor's configuration file is ~/.propellor/config.hs"
sayLn ""
sayLn "Let's get you started with a simple config that you can adapt"
sayLn "to your needs. You can start with:"
sayLn " A: A clone of propellor's git repository (most flexible)"
sayLn " B: The bare minimum files to use propellor (most simple)"
prompt "Which would you prefer?"
[ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone)
, ("B", void $ actionMessage "Creating minimal config" minimalConfig)
]
changeWorkingDirectory =<< dotPropellor
section
sayLn "Let's try building the propellor configuration, to make sure it will work..."
sayLn ""
b <- buildSystem
void $ boolSystem "git"
[ Param "config"
, Param "propellor.buildsystem"
, Param b
]
ifM cabalSandboxRequired
( void $ boolSystem "cabal"
[ Param "sandbox"
, Param "init"
]
, return ()
)
buildPropellor Nothing
sayLn ""
sayLn "Great! Propellor is bootstrapped."
section
sayLn "Propellor can use gpg to encrypt private data about the systems it manages,"
sayLn "and to sign git commits."
gpg <- getGpgBin
ifM (inPath gpg)
( setupGpgKey
, do
sayLn "You don't seem to have gpg installed, so skipping setting it up."
explainManualSetupGpgKey
)
section
sayLn "Everything is set up ..."
sayLn "Your next step is to edit ~/.propellor/config.hs"
sayLn "and run propellor again to try it out."
sayLn ""
sayLn "For docs, see https://propellor.branchable.com/"
sayLn "Enjoy propellor!"
explainManualSetupGpgKey :: IO ()
explainManualSetupGpgKey = do
sayLn "Propellor can still be used without gpg, but it won't be able to"
sayLn "manage private data. You can set this up later:"
sayLn " 1. gpg --gen-key"
sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
setupGpgKey :: IO ()
setupGpgKey = do
ks <- listSecretKeys
sayLn ""
case ks of
[] -> makeGpgKey
[(k, d)] -> do
sayLn $ "You have one gpg key: " ++ desckey k d
prompt "Should propellor use that key?"
[ ("Y", propellorAddKey k)
, ("N", sayLn $ "Skipping gpg setup. If you change your mind, run: propellor --add-key " ++ k)
]
_ -> do
let nks = zip ks (map show ([1..] :: [Integer]))
sayLn "I see you have several gpg keys:"
forM_ nks $ \((k, d), n) ->
sayLn $ " " ++ n ++ " " ++ desckey k d
prompt "Which of your gpg keys should propellor use?"
(map (\((k, _), n) -> (n, propellorAddKey k)) nks)
where
desckey k d = d ++ " (keyid " ++ k ++ ")"
makeGpgKey :: IO ()
makeGpgKey = do
sayLn "You seem to not have any gpg secret keys."
prompt "Would you like to create one now?"
[("Y", rungpg), ("N", nope)]
where
nope = do
sayLn "No problem."
explainManualSetupGpgKey
rungpg = do
sayLn "Running gpg --gen-key ..."
gpg <- getGpgBin
void $ boolSystem gpg [Param "--gen-key"]
ks <- listSecretKeys
case ks of
[] -> do
sayLn "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
sayLn ""
sayLn $ "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
sayLn "Oops, that didn't work! You can retry the same command later."
sayLn "Continuing onward ..."
minimalConfig :: IO Result
minimalConfig = do
d <- dotPropellor
createDirectoryIfMissing True d
changeWorkingDirectory d
void $ boolSystem "git" [Param "init"]
addfile "config.cabal" cabalcontent
addfile "config.hs" configcontent
addfile "stack.yaml" stackcontent
return MadeChange
where
addfile f content = do
writeFile f (unlines content)
void $ boolSystem "git" [Param "add" , File f]
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 >= 4.9"
]
configcontent =
[ "-- This is the main configuration file for Propellor, and is used to build"
, "-- the propellor program. https://propellor.branchable.com/"
, ""
, "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 X86_64"
, " & Apt.stdSourcesList"
, " & Apt.unattendedUpgrades"
, " & Apt.installed [\"etckeeper\"]"
, " & Apt.installed [\"ssh\"]"
, " & User.hasSomePassword (User \"root\")"
, " & File.dirExists \"/var/www\""
, " & Cron.runPropellor (Cron.Times \"30 * * * *\")"
, ""
]
stackcontent =
[ "resolver: " ++ stackResolver
, "packages:"
, "- '.'"
, "extra-deps:"
, "- propellor-" ++ showVersion Package.version
]
stackResolver :: String
stackResolver = "lts-9.21"
fullClone :: IO Result
fullClone = do
d <- dotPropellor
let enterdotpropellor = changeWorkingDirectory d >> return True
ok <- ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
( allM id
[ boolSystem "git" [Param "clone", File distrepo, File d]
, fetchUpstreamBranch distrepo
, enterdotpropellor
, boolSystem "git" [Param "remote", Param "rm", Param "origin"]
]
, allM id
[ boolSystem "git" [Param "clone", Param netrepo, File d]
, enterdotpropellor
, boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]
, boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"]
]
)
return (toResult ok)
fetchUpstreamBranch :: FilePath -> IO Bool
fetchUpstreamBranch repo = do
changeWorkingDirectory =<< dotPropellor
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 updateUpstreamMaster 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")
updateUpstreamMaster :: String -> IO ()
updateUpstreamMaster newref = do
changeWorkingDirectory =<< dotPropellor
go =<< getoldref
where
go Nothing = return ()
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"]
v <- gitVersion
let mergeparams =
[ "merge", newref
, "-s", "recursive"
, "-Xtheirs"
, "--quiet"
, "-m", "merging upstream version"
] ++ if v >= [2,9]
then [ "--allow-unrelated-histories" ]
else []
git mergeparams
void $ fetchUpstreamBranch tmprepo
cleantmprepo
warnoutofdate True
git = run "git"
run cmd ps = unlessM (boolSystem cmd (map Param ps)) $
error $ "Failed to run " ++ cmd ++ " " ++ show ps
getoldref = do
mref <- catchMaybeIO $ takeWhile (/= '\n')
<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
case mref of
Just _ -> do
ifM (hasRemote "upstream")
( do
v <- remoteUrl "upstream"
return $ case v of
Just rurl | rurl == distrepo -> mref
_ -> Nothing
, return mref
)
Nothing -> return mref
warnoutofdate :: Bool -> IO ()
warnoutofdate havebranch = warningMessage $ unlines
[ "** Your ~/.propellor/ is out of date.."
, indent "A newer upstream version is available in " ++ distrepo
, indent $ if havebranch
then "To merge it, run: git merge " ++ upstreambranch
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."
]
where
indent s = " " ++ s