summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2017-07-13 12:31:20 -0400
committerJoey Hess2017-07-13 12:31:20 -0400
commitadffd9c76dec8de90407da98fb2c8e25c1d4e815 (patch)
tree151a36bf2448793a995283655873ed093681843d /src
parent4a965c7b06b741b5de105e86d08228dfc9768ecc (diff)
parente952199fbe22af6e6c29a8c7d60c03cde685f63e (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs167
-rw-r--r--src/Propellor/Property/Bootstrap.hs45
-rw-r--r--src/Propellor/Property/Cron.hs5
-rw-r--r--src/Propellor/Protocol.hs10
-rw-r--r--src/Propellor/Spin.hs33
5 files changed, 188 insertions, 72 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 4b3f2da2..baf36e49 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -1,4 +1,8 @@
module Propellor.Bootstrap (
+ Bootstrapper(..),
+ Builder(..),
+ defaultBootstrapper,
+ getBootstrapper,
bootstrapPropellorCommand,
checkBinaryCommand,
installGitCommand,
@@ -16,71 +20,120 @@ import Data.List
type ShellCommand = String
+-- | Different ways that Propellor's dependencies can be installed,
+-- and propellor can be built. The default is `Robustly Cabal`
+--
+-- `Robustly Cabal` and `Robustly Stack` use the OS's native packages
+-- as much as possible to install Cabal, Stack, and propellor's build
+-- dependencies. When necessary, dependencies are built from source
+-- using Cabal or Stack rather than using the OS's native packages.
+--
+-- `OSOnly` uses the OS's native packages of Cabal and all of propellor's
+-- build dependencies. It may not work on all systems.
+data Bootstrapper = Robustly Builder | OSOnly
+ deriving (Show)
+
+data Builder = Cabal | Stack
+ deriving (Show)
+
+defaultBootstrapper :: Bootstrapper
+defaultBootstrapper = Robustly Cabal
+
+-- | Gets the Bootstrapper for the Host propellor is running on.
+getBootstrapper :: Propellor Bootstrapper
+getBootstrapper = go <$> askInfo
+ where
+ go NoInfoVal = defaultBootstrapper
+ go (InfoVal bs) = bs
+
+getBuilder :: Bootstrapper -> Builder
+getBuilder (Robustly b) = b
+getBuilder OSOnly = Cabal
+
-- Shell command line to ensure propellor is bootstrapped and ready to run.
-- Should be run inside the propellor config dir, and will install
-- all necessary build dependencies and build propellor.
-bootstrapPropellorCommand :: Maybe System -> ShellCommand
-bootstrapPropellorCommand msys = checkDepsCommand msys ++
+bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand
+bootstrapPropellorCommand bs msys = checkDepsCommand bs msys ++
"&& if ! test -x ./propellor; then "
- ++ buildCommand ++
- "; fi;" ++ checkBinaryCommand
+ ++ buildCommand bs ++
+ "; fi;" ++ checkBinaryCommand bs
-- Use propellor --check to detect if the local propellor binary has
-- stopped working (eg due to library changes), and must be rebuilt.
-checkBinaryCommand :: ShellCommand
-checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi"
+checkBinaryCommand :: Bootstrapper -> ShellCommand
+checkBinaryCommand bs = "if test -x ./propellor && ! ./propellor --check; then " ++ go (getBuilder bs) ++ "; fi"
where
- go = intercalate " && "
+ go Cabal = intercalate " && "
[ "cabal clean"
- , buildCommand
+ , buildCommand bs
+ ]
+ go Stack = intercalate " && "
+ [ "stack clean"
+ , buildCommand bs
]
-buildCommand :: ShellCommand
-buildCommand = intercalate " && "
- [ "cabal configure"
- , "cabal build propellor-config"
- , "ln -sf dist/build/propellor-config/propellor-config propellor"
- ]
+buildCommand :: Bootstrapper -> ShellCommand
+buildCommand bs = intercalate " && " (go (getBuilder bs))
+ where
+ go Cabal =
+ [ "cabal configure"
+ , "cabal build propellor-config"
+ , "ln -sf dist/build/propellor-config/propellor-config propellor"
+ ]
+ go Stack =
+ [ "stack build :propellor-config"
+ , "ln -sf $(stack path --dist-dir)/build/propellor-config propellor"
+ ]
-- Run cabal configure to check if all dependencies are installed;
-- if not, run the depsCommand.
-checkDepsCommand :: Maybe System -> ShellCommand
-checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi"
+checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+checkDepsCommand bs sys = go (getBuilder bs)
+ where
+ go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
+ go Stack = "if ! stack --version >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
--- Install build dependencies of propellor.
---
--- First, try to install ghc, cabal, gnupg, and all haskell libraries that
--- propellor uses from OS packages.
+-- Install build dependencies of propellor, using the specified
+-- Bootstrapper.
--
+-- When bootstrapping Robustly, first try to install the builder,
+-- and all haskell libraries that propellor uses from OS packages.
-- Some packages may not be available in some versions of Debian
-- (eg, Debian wheezy lacks async), or propellor may need a newer version.
--- So, as a second step, cabal is used to install all dependencies.
+-- So, as a second step, any other dependencies are installed from source
+-- using the builder.
--
-- Note: May succeed and leave some deps not installed.
-depsCommand :: Maybe System -> ShellCommand
-depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true"
+depsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true"
where
- osinstall = case msys of
- Just (System (FreeBSD _) _) -> map pkginstall fbsddeps
- Just (System (ArchLinux) _) -> map pacmaninstall archlinuxdeps
- Just (System (Debian _ _) _) -> useapt
- Just (System (Buntish _) _) -> useapt
- -- assume a debian derived system when not specified
- Nothing -> useapt
-
- useapt = "apt-get update" : map aptinstall debdeps
-
- cabalinstall =
+ go (Robustly Cabal) = osinstall Cabal ++
[ "cabal update"
, "cabal install --only-dependencies"
+ ]
+ go (Robustly Stack) = osinstall Stack ++
+ [ "stack setup"
+ , "stack build --only-dependencies :propellor-config"
]
+ go OSOnly = osinstall Cabal
+
+ osinstall builder = case msys of
+ Just (System (FreeBSD _) _) -> map pkginstall (fbsddeps builder)
+ Just (System (ArchLinux) _) -> map pacmaninstall (archlinuxdeps builder)
+ Just (System (Debian _ _) _) -> useapt builder
+ Just (System (Buntish _) _) -> useapt builder
+ -- assume a Debian derived system when not specified
+ Nothing -> useapt builder
+
+ useapt builder = "apt-get update" : map aptinstall (debdeps builder)
aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
pacmaninstall p = "pacman -S --noconfirm --needed " ++ p
-- This is the same deps listed in debian/control.
- debdeps =
+ debdeps Cabal =
[ "gnupg"
, "ghc"
, "cabal-install"
@@ -98,7 +151,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "libghc-text-dev"
, "libghc-hashable-dev"
]
- fbsddeps =
+ debdeps Stack =
+ [ "gnupg"
+ , "haskell-stack"
+ ]
+
+ fbsddeps Cabal =
[ "gnupg"
, "ghc"
, "hs-cabal-install"
@@ -116,7 +174,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "hs-text"
, "hs-hashable"
]
- archlinuxdeps =
+ fbsddeps Stack =
+ [ "gnupg"
+ , "stack"
+ ]
+
+ archlinuxdeps Cabal =
[ "gnupg"
, "ghc"
, "cabal-install"
@@ -135,6 +198,10 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "haskell-text"
, "hashell-hashable"
]
+ archlinuxdeps Stack =
+ [ "gnupg"
+ , "stack"
+ ]
installGitCommand :: Maybe System -> ShellCommand
installGitCommand msys = case msys of
@@ -155,22 +222,28 @@ installGitCommand msys = case msys of
, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
]
+-- Build propellor, and symlink the built binary to ./propellor.
+--
+-- When the Host has a Buildsystem specified it is used. If none is
+-- specified, look at git config propellor.buildsystem.
buildPropellor :: Maybe Host -> IO ()
-buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $
+buildPropellor mh = unlessM (actionMessage "Propellor build" build) $
errorMessage "Propellor build failed!"
where
msys = case fmap (fromInfo . hostInfo) mh of
Just (InfoVal sys) -> Just sys
_ -> Nothing
--- Build propellor using cabal or stack, and symlink propellor to the
--- built binary.
-build :: Maybe System -> IO Bool
-build msys = catchBoolIO $ do
- bs <- getGitConfigValue "propellor.buildsystem"
- case bs of
- Just "stack" -> stackBuild msys
- _ -> cabalBuild msys
+ build = catchBoolIO $ do
+ case fromInfo (maybe mempty hostInfo mh) of
+ NoInfoVal -> do
+ bs <- getGitConfigValue "propellor.buildsystem"
+ case bs of
+ Just "stack" -> stackBuild msys
+ _ -> cabalBuild msys
+ InfoVal bs -> case getBuilder bs of
+ Cabal -> cabalBuild msys
+ Stack -> stackBuild msys
-- For speed, only runs cabal configure when it's not been run before.
-- If the build fails cabal may need to have configure re-run.
@@ -203,7 +276,7 @@ cabalBuild msys = do
, case msys of
Nothing -> return False
Just sys ->
- boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
+ boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))]
<&&> cabal ["configure"]
)
cabal_build = cabal ["build", "propellor-config"]
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
index 767d6ef7..93529c14 100644
--- a/src/Propellor/Property/Bootstrap.hs
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -1,12 +1,39 @@
-module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where
+-- | This module contains properties that configure how Propellor
+-- bootstraps to run itself on a Host.
+
+module Propellor.Property.Bootstrap (
+ Bootstrapper(..),
+ bootstrapWith,
+ RepoSource(..),
+ bootstrappedFrom,
+ clonedFrom
+) where
import Propellor.Base
import Propellor.Bootstrap
+import Propellor.Types.Info
import Propellor.Property.Chroot
import Data.List
import qualified Data.ByteString as B
+-- | This property can be used to configure the `Bootstrapper` that is used
+-- to bootstrap propellor on a Host. For example, if you want to use
+-- stack:
+--
+-- > host "example.com" $ props
+-- > & bootstrapWith (Robustly Stack)
+--
+-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`,
+-- this property can also be added to the chroot to configure it.
+bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
+bootstrapWith b = pureInfoProperty desc (InfoVal b)
+ where
+ desc = "bootstrapped with " ++ case b of
+ Robustly Stack -> "stack"
+ Robustly Cabal -> "cabal"
+ OSOnly -> "OS packages only"
+
-- | Where a propellor repository should be bootstrapped from.
data RepoSource
= GitRepoUrl String
@@ -17,14 +44,17 @@ data RepoSource
-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
--- This property only does anything when used inside a chroot.
--- This is particularly useful inside a chroot used to build a
+-- Normally, propellor is bootstrapped by eg, using propellor --spin,
+-- and so this property is not generally needed.
+--
+-- This property only does anything when used inside a Chroot or other
+-- Container. This is particularly useful inside a chroot used to build a
-- disk image, to make the disk image have propellor installed.
--
-- The git repository is cloned (or pulled to update if it already exists).
--
-- All build dependencies are installed, using distribution packages
--- or falling back to using cabal.
+-- or falling back to using cabal or stack.
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom reposource = check inChroot $
go `requires` clonedFrom reposource
@@ -32,14 +62,15 @@ bootstrappedFrom reposource = check inChroot $
go :: Property Linux
go = property "Propellor bootstrapped" $ do
system <- getOS
+ bootstrapper <- getBootstrapper
assumeChange $ exposeTrueLocaldir $ const $
runShellCommand $ buildShellCommand
[ "cd " ++ localdir
- , checkDepsCommand system
- , buildCommand
+ , checkDepsCommand bootstrapper system
+ , buildCommand bootstrapper
]
--- | Clones the propellor repeository into /usr/local/propellor/
+-- | Clones the propellor repository into /usr/local/propellor/
--
-- If the propellor repo has already been cloned, pulls to get it
-- up-to-date.
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 0966a7e5..ab700a9d 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -80,7 +80,8 @@ niceJob desc times user cddir command = job desc times user cddir
-- | Installs a cron job to run propellor.
runPropellor :: Times -> Property UnixLike
-runPropellor times = withOS "propellor cron job" $ \w o ->
+runPropellor times = withOS "propellor cron job" $ \w o -> do
+ bootstrapper <- getBootstrapper
ensureProperty w $
niceJob "propellor" times (User "root") localdir
- (bootstrapPropellorCommand o ++ "; ./propellor")
+ (bootstrapPropellorCommand bootstrapper o ++ "; ./propellor")
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index ae7e0404..e90155f3 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -53,11 +53,7 @@ sendMarked' h marker s = do
hFlush h
getMarked :: Handle -> Marker -> IO (Maybe String)
-getMarked h marker = do
- -- Avoid buffering anything in Handle, so that the data after
- -- the marker will be available to be read from the underlying Fd.
- hSetBuffering stdin NoBuffering
- go =<< catchMaybeIO (hGetLine h)
+getMarked h marker = go =<< catchMaybeIO (hGetLine h)
where
go Nothing = return Nothing
go (Just l) = case fromMarked marker l of
@@ -69,8 +65,8 @@ getMarked h marker = do
debug ["received marked", marker]
return (Just v)
-reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
-reqMarked stage marker a = do
+req :: Stage -> Marker -> (String -> IO ()) -> IO ()
+req stage marker a = do
debug ["requested marked", marker]
sendMarked' stdout statusMarker (show stage)
maybe noop a =<< getMarked stdin marker
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index cd964e16..aeaa4643 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -93,6 +93,9 @@ spin' mprivdata relay target hst = do
sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
+ bootstrapper = case fromInfo (hostInfo hst) of
+ NoInfoVal -> defaultBootstrapper
+ InfoVal bs -> bs
relaying = relay == Just target
viarelay = isJust relay && not relaying
@@ -109,7 +112,7 @@ spin' mprivdata relay target hst = do
updatecmd = intercalate " && "
[ "cd " ++ localdir
- , bootstrapPropellorCommand sys
+ , bootstrapPropellorCommand bootstrapper sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
@@ -178,11 +181,11 @@ getSshTarget target hst
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
- reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
+ req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
- reqMarked NeedPrivData privDataMarker $
+ req NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
@@ -350,18 +353,30 @@ spinCommitMessage = "propellor spin"
-- Request that it run git upload-pack, and connect that up to a git fetch
-- to receive the data.
gitPullFromUpdateServer :: IO ()
-gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do
- -- Note that this relies on data not being buffered in the stdin
- -- Handle, since such buffered data would not be available in the
- -- FD passed to git fetch.
- hin <- dup stdInput
+gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do
+ -- IO involving stdin can cause data to be buffered in the Handle
+ -- (even when it's set NoBuffering), but we need to pass a FD to
+ -- git fetch containing all of stdin after the gitPushMarker,
+ -- including any that has been buffered.
+ --
+ -- To do so, create a pipe, and forward stdin, including any
+ -- buffered part, through it.
+ (pread, pwrite) <- System.Posix.IO.createPipe
+ -- Note that there is a race between the createPipe and setting
+ -- CloseOnExec. Another processess forked here would inherit
+ -- pwrite and perhaps keep it open. However, propellor is not
+ -- running concurrent threads at this point, so this is ok.
+ setFdOption pwrite CloseOnExec True
+ hwrite <- fdToHandle pwrite
+ forwarder <- async $ stdin *>* hwrite
+ let hin = pread
hout <- dup stdOutput
- hClose stdin
hClose stdout
-- Not using git pull because git 2.5.0 badly
-- broke its option parser.
unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
errorMessage "git fetch from client failed"
+ wait forwarder
unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where