summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2018-12-30 15:08:00 -0400
committerJoey Hess2018-12-30 15:08:00 -0400
commit84330a9a6dcd1dd2f2afa3f0ad5a8f07bd26f9d5 (patch)
tree8d31499a1ae4245a8098fcaa56f7107434b18de6
parent287887cff4e43b64a592121aaa7bc371433dd686 (diff)
parentf0a3ad02488ea89088cc06d112194d9db3b751e3 (diff)
Merge branch 'master' into joeyconfig
l---------config.hs2
-rw-r--r--debian/changelog4
-rw-r--r--debian/control6
-rw-r--r--doc/README.mdwn6
-rw-r--r--doc/forum/compiling_5.5.0_fails_with_lts_13.0.mdwn74
-rw-r--r--doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_1_58051e973d4b4c269b1fa90517a3adc6._comment11
-rw-r--r--doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_2_c96da2520b700b2c39769d53febc3ae8._comment7
-rw-r--r--doc/forum/installing_apt_packages_without_running_new_services.mdwn3
-rw-r--r--doc/forum/installing_apt_packages_without_running_new_services/comment_1_7c64eb0d72d9f84ecc62136b0367ef3d._comment16
-rw-r--r--doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid.mdwn7
-rw-r--r--doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid/comment_1_dbb0a50414b1ac58cad8584a7c99078e._comment17
-rw-r--r--doc/todo/support_for_libvirt_KVM_VMs/comment_13_066d41df795b69e096487ae7334824d0._comment8
-rw-r--r--doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network.mdwn9
-rw-r--r--doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network/comment_1_9469ea9eaf70e57ba1b36891978725cf._comment11
-rw-r--r--privdata/relocate1
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Bootstrap.hs42
-rw-r--r--src/Propellor/Property/DiskImage.hs24
-rw-r--r--src/Propellor/Property/Libvirt.hs210
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs1
-rw-r--r--src/Propellor/Types.hs1
-rw-r--r--src/Propellor/Types/OS.hs2
-rw-r--r--src/Utility/Process.hs11
23 files changed, 434 insertions, 40 deletions
diff --git a/config.hs b/config.hs
index 97d90636..ec313725 120000
--- a/config.hs
+++ b/config.hs
@@ -1 +1 @@
-joeyconfig.hs \ No newline at end of file
+config-simple.hs \ No newline at end of file
diff --git a/debian/changelog b/debian/changelog
index e9c8bb00..c870e48a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,6 +1,10 @@
propellor (5.5.1) UNRELEASED; urgency=medium
* Some openbsd portability fixes. Thanks, rsiddharth.
+ * Added Libvirt module. Thanks, Sean Whitton.
+ * When bootstrapping on Debian, libghc-stm-dev may not be available,
+ as it's become part of ghc, so check before trying to install it.
+ * Fix build with ghc 8.6.3.
-- Joey Hess <id@joeyh.name> Tue, 23 Oct 2018 11:37:16 -0400
diff --git a/debian/control b/debian/control
index 0a8701a0..5a46822f 100644
--- a/debian/control
+++ b/debian/control
@@ -4,7 +4,7 @@ Priority: optional
Build-Depends:
debhelper (>= 9),
git (>= 2.0),
- ghc (>= 7.6),
+ ghc (>= 8.4.3),
cabal-install,
libghc-async-dev,
libghc-split-dev,
@@ -16,7 +16,6 @@ Build-Depends:
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
- libghc-stm-dev,
libghc-text-dev,
libghc-hashable-dev,
Maintainer: Joey Hess <id@joeyh.name>
@@ -28,7 +27,7 @@ Package: propellor
Architecture: any
Section: admin
Depends: ${misc:Depends}, ${shlibs:Depends},
- ghc (>= 7.4),
+ ghc (>= 8.4.3),
cabal-install,
libghc-async-dev,
libghc-split-dev,
@@ -40,7 +39,6 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
- libghc-stm-dev,
libghc-text-dev,
libghc-hashable-dev,
git (>= 2.0),
diff --git a/doc/README.mdwn b/doc/README.mdwn
index 88726a6d..76d05255 100644
--- a/doc/README.mdwn
+++ b/doc/README.mdwn
@@ -37,11 +37,11 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
## quick start
1. Get propellor installed on your development machine (ie, laptop).
- `cabal install propellor`
+ `apt-get install propellor`
or
- `stack install propellor`
+ `cabal install propellor`
or
- `apt-get install propellor`
+ `cabal unpack propellor; cd propellor-version; stack install`
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.
diff --git a/doc/forum/compiling_5.5.0_fails_with_lts_13.0.mdwn b/doc/forum/compiling_5.5.0_fails_with_lts_13.0.mdwn
new file mode 100644
index 00000000..7b543f7f
--- /dev/null
+++ b/doc/forum/compiling_5.5.0_fails_with_lts_13.0.mdwn
@@ -0,0 +1,74 @@
+Running `stack install propellor` today fails in two ways:
+
+First up:
+
+ In the dependencies for propellor-5.5.0:
+ IfElse needed, but the stack configuration has no specified version (latest
+ matching version is 0.85) needed since propellor is a build target.
+
+ Some different approaches to resolving this:
+
+ * Consider trying 'stack solver', which uses the cabal-install solver to
+ attempt to find some working build configuration. This can be convenient
+ when dealing with many complicated constraint errors, but results may be
+ unpredictable.
+
+ * Recommended action: try adding the following to your extra-deps
+ in /Users/thom/.stack/global-project/stack.yaml:
+
+ IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2
+
+
+Once that's added, propellor fails to compile with:
+
+
+ [ 39 of 174] Compiling Propellor.Types ( src/Propellor/Types.hs, .stack-work/dist/x86_64-osx/Cabal-2.4.0.1/build/Propellor/Types.o )
+
+ /private/var/folders/0v/w1nt655j39q9954g7y_2_jlh0000gn/T/stack8634/propellor-5.5.0/src/Propellor/Types.hs:187:10: error:
+ • Illegal nested constraint ‘SingI (Combine x y)’
+ (Use UndecidableInstances to permit this)
+ • In the instance declaration for
+ ‘Combines (Property (MetaTypes x)) (Property (MetaTypes y))’
+ |
+ 187 | instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
+ | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ /private/var/folders/0v/w1nt655j39q9954g7y_2_jlh0000gn/T/stack8634/propellor-5.5.0/src/Propellor/Types.hs:190:10: error:
+ • Illegal nested constraint ‘SingI (Combine x y)’
+ (Use UndecidableInstances to permit this)
+ • In the instance declaration for
+ ‘Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y'))’
+ |
+ 190 | instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+ | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ /private/var/folders/0v/w1nt655j39q9954g7y_2_jlh0000gn/T/stack8634/propellor-5.5.0/src/Propellor/Types.hs:190:10: error:
+ • Illegal nested constraint ‘SingI (Combine x' y')’
+ (Use UndecidableInstances to permit this)
+ • In the instance declaration for
+ ‘Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y'))’
+ |
+ 190 | instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+ | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ /private/var/folders/0v/w1nt655j39q9954g7y_2_jlh0000gn/T/stack8634/propellor-5.5.0/src/Propellor/Types.hs:195:10: error:
+ • Illegal nested constraint ‘SingI (Combine x y)’
+ (Use UndecidableInstances to permit this)
+ • In the instance declaration for
+ ‘Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y))’
+ |
+ 195 | instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
+ | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ /private/var/folders/0v/w1nt655j39q9954g7y_2_jlh0000gn/T/stack8634/propellor-5.5.0/src/Propellor/Types.hs:197:10: error:
+ • Illegal nested constraint ‘SingI (Combine x y)’
+ (Use UndecidableInstances to permit this)
+ • In the instance declaration for
+ ‘Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y'))’
+ |
+ 197 | instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+ | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+
+I can reproduce this by bumping the lts version to 13.0 in master's stack.yaml and uttering `stack build`.
diff --git a/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_1_58051e973d4b4c269b1fa90517a3adc6._comment b/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_1_58051e973d4b4c269b1fa90517a3adc6._comment
new file mode 100644
index 00000000..5227cf3d
--- /dev/null
+++ b/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_1_58051e973d4b4c269b1fa90517a3adc6._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2018-12-30T17:10:47Z"
+ content="""
+Unfortunately `stack install propellor` ignores the working stack.yaml
+shipped with propellor, and tries to use the default resolver and package
+set.
+
+I've adjusted the README to not suggest using that broken command.
+"""]]
diff --git a/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_2_c96da2520b700b2c39769d53febc3ae8._comment b/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_2_c96da2520b700b2c39769d53febc3ae8._comment
new file mode 100644
index 00000000..f02ef69b
--- /dev/null
+++ b/doc/forum/compiling_5.5.0_fails_with_lts_13.0/comment_2_c96da2520b700b2c39769d53febc3ae8._comment
@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2018-12-30T18:38:51Z"
+ content="""
+I've made the necessary changes to support ghc 8.6.3.
+"""]]
diff --git a/doc/forum/installing_apt_packages_without_running_new_services.mdwn b/doc/forum/installing_apt_packages_without_running_new_services.mdwn
new file mode 100644
index 00000000..d044ef05
--- /dev/null
+++ b/doc/forum/installing_apt_packages_without_running_new_services.mdwn
@@ -0,0 +1,3 @@
+How would one create a Property that installs a package without starting the corresponding service?
+
+I'm asking because sometimes the default config is broken, so you need to fix it before starting the service.
diff --git a/doc/forum/installing_apt_packages_without_running_new_services/comment_1_7c64eb0d72d9f84ecc62136b0367ef3d._comment b/doc/forum/installing_apt_packages_without_running_new_services/comment_1_7c64eb0d72d9f84ecc62136b0367ef3d._comment
new file mode 100644
index 00000000..41fa4078
--- /dev/null
+++ b/doc/forum/installing_apt_packages_without_running_new_services/comment_1_7c64eb0d72d9f84ecc62136b0367ef3d._comment
@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2018-12-01T21:39:14Z"
+ content="""
+One way is to enable Propellor.Property.Service.noServices
+during the install and revert it afterwards, but that does prevent any
+services being started while it's enabled.
+
+I don't know of a very good way to do this on a Debian system. If you can
+find one, I'm sure propellor can use it.
+
+It might be possible, when systemd is used, to first apply
+Propellor.Property.Systemd.disabled on the service that has not been
+installed yet. I have not checked if that works.
+"""]]
diff --git a/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid.mdwn b/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid.mdwn
new file mode 100644
index 00000000..4305e396
--- /dev/null
+++ b/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid.mdwn
@@ -0,0 +1,7 @@
+haskell-stm is included with ghc and won't be shipped as an installable package in Debian buster.
+
+Propellor needs to stop trying to install haskell-stm on Debian buster or newer (and it should also be dropped from debian/control of course, but that can happen on the Debian side).
+
+--spwhitton
+
+> [[done]] --[[Joey]]
diff --git a/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid/comment_1_dbb0a50414b1ac58cad8584a7c99078e._comment b/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid/comment_1_dbb0a50414b1ac58cad8584a7c99078e._comment
new file mode 100644
index 00000000..a53a144a
--- /dev/null
+++ b/doc/todo/haskell-stm_now_bundled_with_ghc_in_Debian_sid/comment_1_dbb0a50414b1ac58cad8584a7c99078e._comment
@@ -0,0 +1,17 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2018-12-04T18:58:48Z"
+ content="""
+Bootstrap's package installation ignores errors, so if the package is not
+available, it will at worst display an error message and continue.
+
+However, I went ahead and made it check with apt-cache if the package is
+available, to avoid the user seeing an apt error here.
+
+I suppose users of Arch and FreeBSD may want to make similar changes, if
+their package managers also display errors; I don't know if they do or even
+if this change is going to affect those distributions.
+Probably better to let those users deal with it if similar changes are made
+to those distributions, so I'm going to close this.
+"""]]
diff --git a/doc/todo/support_for_libvirt_KVM_VMs/comment_13_066d41df795b69e096487ae7334824d0._comment b/doc/todo/support_for_libvirt_KVM_VMs/comment_13_066d41df795b69e096487ae7334824d0._comment
new file mode 100644
index 00000000..07b32566
--- /dev/null
+++ b/doc/todo/support_for_libvirt_KVM_VMs/comment_13_066d41df795b69e096487ae7334824d0._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 13"""
+ date="2018-11-11T20:58:35Z"
+ content="""
+I've merged the branch, unsure if this should remain open for anything
+discussed above, so leaving it for now.
+"""]]
diff --git a/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network.mdwn b/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network.mdwn
new file mode 100644
index 00000000..831dc1e0
--- /dev/null
+++ b/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network.mdwn
@@ -0,0 +1,9 @@
+I don't have `Cron.runPropellor` on my laptop because it is often offline. But I would like a cronjob that tries to spin the host if it's online. Mainly to keep sbuild chroots up-to-date.
+
+I was wondering what the cleanest way to implement this would be. `Cron.runPropellor` could be split into `Cron.runPropellor` and `Cron.runPropellorWhenOnline`, the latter of which does `wget http://google.com >/dev/null` and exits if that command fails.
+
+Or there could be some kind of property which, when set on a host, causes all spins to abort if the host if offline.
+
+And is wgetting Google's homepage the right way to check that we have Internet access?
+
+--spwhitton
diff --git a/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network/comment_1_9469ea9eaf70e57ba1b36891978725cf._comment b/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network/comment_1_9469ea9eaf70e57ba1b36891978725cf._comment
new file mode 100644
index 00000000..638a8d6b
--- /dev/null
+++ b/doc/todo/want_Cron.runPropellor_that_does_nothing_if_no_network/comment_1_9469ea9eaf70e57ba1b36891978725cf._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2018-12-08T16:15:43Z"
+ content="""
+Perhaps runPropellor could be parameterized in some way, so
+you can provide whatever check you decide you want.
+
+This is where [[todo/integrate_shell-monad]] would come in handy, to
+build up and manipulate the shell script for the cron job.
+"""]]
diff --git a/privdata/relocate b/privdata/relocate
deleted file mode 100644
index 271692d8..00000000
--- a/privdata/relocate
+++ /dev/null
@@ -1 +0,0 @@
-.joeyconfig
diff --git a/propellor.cabal b/propellor.cabal
index 0454fc92..d021a300 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -101,6 +101,7 @@ Library
Propellor.Property.Kerberos
Propellor.Property.Laptop
Propellor.Property.LetsEncrypt
+ Propellor.Property.Libvirt
Propellor.Property.List
Propellor.Property.LightDM
Propellor.Property.Locale
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 66e6e1ff..6ca133cb 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -95,6 +95,8 @@ checkDepsCommand bs sys = go (getBuilder bs)
go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
+data Dep = Dep String | OldDep String
+
-- Install build dependencies of propellor, using the specified
-- Bootstrapper.
--
@@ -128,32 +130,34 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true"
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
+ aptinstall (Dep p) = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
+ aptinstall (OldDep p) = "if LANG=C apt-cache policy " ++ p ++ "| grep -q Candidate:; then " ++ aptinstall (Dep p) ++ "; fi"
pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
pacmaninstall p = "pacman -S --noconfirm --needed " ++ p
debdeps Cabal =
- [ "gnupg"
+ [ Dep "gnupg"
-- Below are the same deps listed in debian/control.
- , "ghc"
- , "cabal-install"
- , "libghc-async-dev"
- , "libghc-split-dev"
- , "libghc-hslogger-dev"
- , "libghc-unix-compat-dev"
- , "libghc-ansi-terminal-dev"
- , "libghc-ifelse-dev"
- , "libghc-network-dev"
- , "libghc-mtl-dev"
- , "libghc-transformers-dev"
- , "libghc-exceptions-dev"
- , "libghc-stm-dev"
- , "libghc-text-dev"
- , "libghc-hashable-dev"
+ , Dep "ghc"
+ , Dep "cabal-install"
+ , Dep "libghc-async-dev"
+ , Dep "libghc-split-dev"
+ , Dep "libghc-hslogger-dev"
+ , Dep "libghc-unix-compat-dev"
+ , Dep "libghc-ansi-terminal-dev"
+ , Dep "libghc-ifelse-dev"
+ , Dep "libghc-network-dev"
+ , Dep "libghc-mtl-dev"
+ , Dep "libghc-transformers-dev"
+ , Dep "libghc-exceptions-dev"
+ , Dep "libghc-text-dev"
+ , Dep "libghc-hashable-dev"
+ -- Deps that are only needed on old systems.
+ , OldDep "libghc-stm-dev"
]
debdeps Stack =
- [ "gnupg"
- , "haskell-stack"
+ [ Dep "gnupg"
+ , Dep "haskell-stack"
]
fbsddeps Cabal =
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index fa41808e..29bc2d1c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -17,6 +17,7 @@ module Propellor.Property.DiskImage (
imageRebuiltFor,
imageBuiltFrom,
imageExists,
+ imageChrootNotPresent,
GrubTarget(..),
noBootloader,
) where
@@ -200,14 +201,13 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
`describe` desc
where
desc = "built disk image " ++ describeDiskImage img
- RawDiskImage imgfile = rawDiskImage img
cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
- chrootdir = imgfile ++ ".chroot"
+ chrootdir = imageChroot img
chroot =
let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
@@ -378,7 +378,7 @@ imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixL
imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
where
desc = "disk image exists " ++ img
- parttablefile = img ++ ".parttable"
+ parttablefile = imageParttableFile dest
setup = property' desc $ \w -> do
oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
res <- ensureProperty w $ imageExists dest (partTableSize parttable)
@@ -488,6 +488,24 @@ noBootloader = pureInfoProperty "no bootloader" [NoBootloader]
noBootloaderFinalized :: Finalization
noBootloaderFinalized _img _mnt _loopDevs = doNothing
+imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
+imageChrootNotPresent img = check (doesDirectoryExist dir) $
+ property "destroy the chroot used to build the image" $ makeChange $ do
+ removeChroot dir
+ nukeFile $ imageParttableFile img
+ where
+ dir = imageChroot img
+
+imageChroot :: DiskImage d => d -> FilePath
+imageChroot img = imgfile <.> "chroot"
+ where
+ RawDiskImage imgfile = rawDiskImage img
+
+imageParttableFile :: DiskImage d => d -> FilePath
+imageParttableFile img = imgfile <.> "parttable"
+ where
+ RawDiskImage imgfile = rawDiskImage img
+
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/Libvirt.hs b/src/Propellor/Property/Libvirt.hs
new file mode 100644
index 00000000..525dd68a
--- /dev/null
+++ b/src/Propellor/Property/Libvirt.hs
@@ -0,0 +1,210 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Libvirt (
+ NumVCPUs(..),
+ MiBMemory(..),
+ AutoStart(..),
+ DiskImageType(..),
+ installed,
+ defaultNetworkAutostarted,
+ defaultNetworkStarted,
+ defined,
+) where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Property.Chroot
+import Propellor.Property.DiskImage
+import qualified Propellor.Property.Apt as Apt
+
+import Utility.Split
+
+-- | The number of virtual CPUs to assign to the virtual machine
+newtype NumVCPUs = NumVCPUs Int
+
+-- | The number of MiB of memory to assign to the virtual machine
+newtype MiBMemory = MiBMemory Int
+
+-- | Whether the virtual machine should be started after it is defined, and at
+-- host system boot
+data AutoStart = AutoStart | NoAutoStart
+
+-- | Which type of disk image to build for the virtual machine
+data DiskImageType = Raw -- | QCow2
+
+-- | Install basic libvirt components
+installed :: Property DebianLike
+installed = Apt.installed ["libvirt-clients", "virtinst"]
+
+-- | Ensure that the default libvirt network is set to autostart, and start it.
+--
+-- On Debian, it is not started by default after installation of libvirt.
+defaultNetworkAutostarted :: Property DebianLike
+defaultNetworkAutostarted = autostarted
+ `requires` installed
+ `before` defaultNetworkStarted
+ where
+ autostarted = check (not <$> doesFileExist autostartFile) $
+ cmdProperty "virsh" ["net-autostart", "default"]
+ autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml"
+
+-- | Ensure that the default libvirt network is started.
+defaultNetworkStarted :: Property DebianLike
+defaultNetworkStarted = go `requires` installed
+ where
+ go :: Property UnixLike
+ go = property "start libvirt's default network" $ do
+ runningNetworks <- liftIO $ virshGetColumns ["net-list"]
+ if ["default"] `elem` (take 1 <$> runningNetworks)
+ then noChange
+ else makeChange $ unlessM startIt $
+ errorMessage "failed to start default network"
+ startIt = boolSystem "virsh" [Param "net-start", Param "default"]
+
+
+-- | Builds a disk image with the properties of the given Host, installs a
+-- libvirt configuration file to boot the image, and if it is set to autostart,
+-- start the VM.
+--
+-- Note that building the disk image happens only once. So if you change the
+-- properties of the given Host, this property will not modify the disk image.
+-- In order to later apply properties to the VM, you should spin it directly, or
+-- arrange to have it spun with a property like 'Cron.runPropellor', or use
+-- 'Propellor.Property.Conductor' from the VM host.
+--
+-- Suggested usage in @config.hs@:
+--
+-- > mybox = host "mybox.example.com" $ props
+-- > & osDebian (Stable "stretch") X86_64
+-- > & Libvirt.defaultNetworkAutostarted
+-- > & Libvirt.defined Libvirt.Raw
+-- > (Libvirt.MiBMemory 2048) (Libvirt.NumVCPUs 2)
+-- > Libvirt.NoAutoStart subbox
+-- >
+-- > subbox = host "subbox.mybox.example.com" $ props
+-- > & osDebian Unstable X86_64
+-- > & hasPartition
+-- > ( partition EXT4
+-- > `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 10240
+-- > )
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- >
+-- > & ipv4 "192.168.122.31"
+-- > & Network.static "ens3" (IPv4 "192.168.122.31")
+-- > (Just (Network.Gateway (IPv4 "192.168.122.1")))
+-- > `requires` Network.cleanInterfacesFile
+-- > & Hostname.sane
+defined
+ :: DiskImageType
+ -> MiBMemory
+ -> NumVCPUs
+ -> AutoStart
+ -> Host
+ -> Property (HasInfo + DebianLike)
+defined imageType (MiBMemory mem) (NumVCPUs cpus) auto h =
+ (built `before` nuked `before` xmlDefined `before` started)
+ `requires` installed
+ where
+ built :: Property (HasInfo + DebianLike)
+ built = check (not <$> doesFileExist imageLoc) $
+ setupRevertableProperty $ imageBuiltFor h
+ (image) (Debootstrapped mempty)
+
+ nuked :: Property UnixLike
+ nuked = imageChrootNotPresent image
+
+ xmlDefined :: Property UnixLike
+ xmlDefined = check (not <$> doesFileExist conf) $
+ property "define the libvirt VM" $
+ withTmpFile (hostName h) $ \t fh -> do
+ xml <- liftIO $ readProcess "virt-install" $
+ [ "-n", hostName h
+ , "--memory=" ++ show mem
+ , "--vcpus=" ++ show cpus
+ , "--disk"
+ , "path=" ++ imageLoc
+ ++ ",device=disk,bus=virtio"
+ , "--print-xml"
+ ] ++ autoStartArg ++ osVariantArg
+ liftIO $ hPutStrLn fh xml
+ liftIO $ hClose fh
+ makeChange $ unlessM (defineIt t) $
+ errorMessage "failed to define VM"
+ where
+ defineIt t = boolSystem "virsh" [Param "define", Param t]
+
+ started :: Property UnixLike
+ started = case auto of
+ AutoStart -> property "start the VM" $ do
+ runningVMs <- liftIO $ virshGetColumns ["list"]
+ -- From the point of view of `virsh start`, the "State"
+ -- column in the output of `virsh list` is not relevant.
+ -- So long as the VM is listed, it's considered started.
+ if [hostName h] `elem` (take 1 . drop 1 <$> runningVMs)
+ then noChange
+ else makeChange $ unlessM startIt $
+ errorMessage "failed to start VM"
+ NoAutoStart -> doNothing
+ where
+ startIt = boolSystem "virsh" [Param "start", Param $ hostName h]
+
+ image = case imageType of
+ Raw -> RawDiskImage imageLoc
+ imageLoc =
+ "/var/lib/libvirt/images" </> hostName h <.> case imageType of
+ Raw -> "img"
+ conf = "/etc/libvirt/qemu" </> hostName h <.> "xml"
+
+ osVariantArg = maybe [] (\v -> ["--os-variant=" ++ v]) $ osVariant h
+ autoStartArg = case auto of
+ AutoStart -> ["--autostart"]
+ NoAutoStart -> []
+
+-- ==== utility functions ====
+
+-- The --os-variant property is optional, per virt-install(1), so return Nothing
+-- if there isn't a known correct value. The VM will still be defined. Pass
+-- the value if we can, though, to optimise the generated XML for the host's OS
+osVariant :: Host -> Maybe String
+osVariant h = hostSystem h >>= \s -> case s of
+ System (Debian _ (Stable "jessie")) _ -> Just "debian8"
+ System (Debian _ (Stable "stretch")) _ -> Just "debian9"
+ System (Debian _ Testing) _ -> Just "debiantesting"
+ System (Debian _ Unstable) _ -> Just "debiantesting"
+
+ System (Buntish "trusty") _ -> Just "ubuntu14.04"
+ System (Buntish "utopic") _ -> Just "ubuntu14.10"
+ System (Buntish "vivid") _ -> Just "ubuntu15.04"
+ System (Buntish "wily") _ -> Just "ubuntu15.10"
+ System (Buntish "xenial") _ -> Just "ubuntu16.04"
+ System (Buntish "yakkety") _ -> Just "ubuntu16.10"
+ System (Buntish "zesty") _ -> Just "ubuntu17.04"
+ System (Buntish "artful") _ -> Just "ubuntu17.10"
+ System (Buntish "bionic") _ -> Just "ubuntu18.04"
+
+ System (FreeBSD (FBSDProduction FBSD101)) _ -> Just "freebsd10.1"
+ System (FreeBSD (FBSDProduction FBSD102)) _ -> Just "freebsd10.2"
+ System (FreeBSD (FBSDProduction FBSD093)) _ -> Just "freebsd9.3"
+ System (FreeBSD (FBSDLegacy FBSD101)) _ -> Just "freebsd10.1"
+ System (FreeBSD (FBSDLegacy FBSD102)) _ -> Just "freebsd10.2"
+ System (FreeBSD (FBSDLegacy FBSD093)) _ -> Just "freebsd9.3"
+
+ -- libvirt doesn't have an archlinux variant yet, it seems
+ System ArchLinux _ -> Nothing
+
+ -- other stable releases that we don't know about (since there are
+ -- infinitely many possible stable release names, as it is a freeform
+ -- string, we need this to avoid a compiler warning)
+ System (Debian _ _) _ -> Nothing
+ System (Buntish _) _ -> Nothing
+
+-- Run a virsh command with the given list of arguments, that is expected to
+-- yield tabular output, and return the rows
+virshGetColumns :: [String] -> IO [[String]]
+virshGetColumns args = map (filter (not . null) . split " ") . drop 2 . lines
+ <$> readProcess "virsh" args
+
+hostSystem :: Host -> Maybe System
+hostSystem = fromInfoVal . fromInfo . hostInfo
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index ce0e0ccd..07787705 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -954,7 +954,6 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
`requires` Apt.installed
[ "ghc", "cabal-install", "make"
, "libghc-http-types-dev"
- , "libghc-stm-dev"
, "libghc-aeson-dev"
, "libghc-wai-dev"
, "libghc-warp-dev"
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index e10e0f5b..7052bf92 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 01d777a4..34ea4272 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -23,7 +23,7 @@ module Propellor.Types.OS (
import Propellor.Types.ConfigurableValue
-import Network.BSD (HostName)
+import Network.Socket (HostName)
import Data.Typeable
import Data.String
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 6d981cb5..48e03f41 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -248,13 +248,10 @@ withHandle h creator p a = creator p' $ a . select
, std_out = Inherit
, std_err = Inherit
}
- (select, p')
- | h == StdinHandle =
- (stdinHandle, base { std_in = CreatePipe })
- | h == StdoutHandle =
- (stdoutHandle, base { std_out = CreatePipe })
- | h == StderrHandle =
- (stderrHandle, base { std_err = CreatePipe })
+ (select, p') = case h of
+ StdinHandle -> (stdinHandle, base { std_in = CreatePipe })
+ StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })
+ StderrHandle -> (stderrHandle, base { std_err = CreatePipe })
-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles