summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--config-freebsd.hs8
-rw-r--r--config-simple.hs2
-rw-r--r--debian/changelog29
-rw-r--r--doc/forum/Apt.install_return_ok_even_if_asked_something_impossible.mdwn14
-rw-r--r--doc/forum/cabal:_Unrecognised_flags:_propellor-config/comment_4_7ee19c190d1acb8106079871dda7f521._comment8
-rw-r--r--doc/haskell_newbie.mdwn4
-rw-r--r--doc/news/version_2.15.4.mdwn15
-rw-r--r--doc/news/version_2.16.0.mdwn18
-rw-r--r--doc/news/version_2.17.0.mdwn30
-rw-r--r--doc/news/version_2.17.1.mdwn8
-rw-r--r--doc/news/version_2.17.2.mdwn8
-rw-r--r--doc/todo/integrate_shell-monad/comment_1_202c24d0a757d5086f65721fc2779131._comment11
-rw-r--r--doc/todo/integrate_shell-monad/comment_2_4e82a5994b4647b4483c92c7785ee905._comment39
-rw-r--r--doc/todo/integrate_shell-monad/comment_3_155d4af99bbbd8681a9924198aa7da73._comment11
-rw-r--r--doc/todo/integrate_shell-monad/comment_4_4914d37a548e1a19733156fbd77142a6._comment20
-rw-r--r--doc/todo/merge_request:_Sbuild.keypairInsecurelyGenerated.mdwn2
-rw-r--r--doc/todo/merge_request:_changes_to_Reboot.hs/comment_1_766444e44fe64a66d57596b1ea9d416d._comment26
-rw-r--r--doc/todo/merge_request:_changes_to_Reboot.hs/comment_2_736788cdf9afc98da3dfd5a120e7978b._comment11
-rw-r--r--doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_4466bc58fd3e69938c184c817ddbb3e6._comment23
-rw-r--r--doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_6460a7f85249bd8b9a83f2e145a25d62._comment29
-rw-r--r--doc/todo/merge_request:_changes_to_Reboot.hs/comment_4_b39af83b7f793013a7d63f340ee8de6d._comment29
-rw-r--r--joeyconfig.hs34
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Bootstrap.hs8
-rw-r--r--src/Propellor/DotDir.hs14
-rw-r--r--src/Propellor/Exception.hs25
-rw-r--r--src/Propellor/Info.hs10
-rw-r--r--src/Propellor/Message.hs20
-rw-r--r--src/Propellor/Property/Apt.hs6
-rw-r--r--src/Propellor/Property/Borg.hs2
-rw-r--r--src/Propellor/Property/Ccache.hs3
-rw-r--r--src/Propellor/Property/Chroot.hs4
-rw-r--r--src/Propellor/Property/DebianMirror.hs2
-rw-r--r--src/Propellor/Property/Debootstrap.hs4
-rw-r--r--src/Propellor/Property/DiskImage.hs38
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs11
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs27
-rw-r--r--src/Propellor/Property/HostingProvider/Exoscale.hs37
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs4
-rw-r--r--src/Propellor/Property/Mount.hs2
-rw-r--r--src/Propellor/Property/OS.hs26
-rw-r--r--src/Propellor/Property/Reboot.hs116
-rw-r--r--src/Propellor/Property/Sbuild.hs40
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs30
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs36
-rw-r--r--src/Propellor/Property/Systemd.hs10
-rw-r--r--src/Propellor/Types/Exception.hs21
-rw-r--r--src/Propellor/Types/OS.hs61
48 files changed, 684 insertions, 254 deletions
diff --git a/config-freebsd.hs b/config-freebsd.hs
index 3ee3f27c..80abb89d 100644
--- a/config-freebsd.hs
+++ b/config-freebsd.hs
@@ -28,11 +28,11 @@ hosts =
-- An example freebsd host.
freebsdbox :: Host
freebsdbox = host "freebsdbox.example.com" $ props
- & osFreeBSD (FBSDProduction FBSD102) "amd64"
+ & osFreeBSD (FBSDProduction FBSD102) X86_64
& Pkg.update
& Pkg.upgrade
& Poudriere.poudriere poudriereZFS
- & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromString "amd64"))
+ & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromArchitecture X86_64))
poudriereZFS :: Poudriere.Poudriere
poudriereZFS = Poudriere.defaultConfig
@@ -44,7 +44,7 @@ poudriereZFS = Poudriere.defaultConfig
-- An example linux host.
linuxbox :: Host
linuxbox = host "linuxbox.example.com" $ props
- & osDebian Unstable "amd64"
+ & osDebian' KFreeBSD Unstable X86_64
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& Apt.installed ["etckeeper"]
@@ -59,7 +59,7 @@ linuxbox = host "linuxbox.example.com" $ props
-- A generic webserver in a Docker container.
webserverContainer :: Docker.Container
webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props
- & osDebian (Stable "jessie") "amd64"
+ & osDebian' KFreeBSD (Stable "jessie") X86_64
& Apt.stdSourcesList
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
diff --git a/config-simple.hs b/config-simple.hs
index 42b3d838..11a3c3a4 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -19,7 +19,7 @@ hosts =
-- An example host.
mybox :: Host
mybox = host "mybox.example.com" $ props
- & osDebian Unstable "amd64"
+ & osDebian Unstable X86_64
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& Apt.installed ["etckeeper"]
diff --git a/debian/changelog b/debian/changelog
index 763cecc6..af8585d2 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,32 @@
+propellor (3.1.0) UNRELEASED; urgency=medium
+
+ * Switch letsencrypt to certbot package name.
+ * Sbuild: Add keyringInsecurelyGenerated which is useful on throwaway
+ build VMs.
+ Thanks, Sean Whitton
+ * Added Propellor.Property.SiteSpecific.Exoscale.
+ Thanks, Sean Whitton
+ * Property.Reboot: Added toDistroKernel and toKernelNewerThan.
+ Thanks, Sean Whitton
+ * Architecture changed from String to an ADT. (API Change)
+ Transition guide: Change "amd64" to X86_64, "i386" to X86_32,
+ "armel" to ARMEL, etc.
+ Thanks, Félix Sipma.
+ * The Debian data type now includes a DebianKernel. (API Change)
+ This won't affect most config.hs, as osDebian defaults to
+ Linux. Added osDebian' can be used to specify a different kernel.
+ Thanks, Félix Sipma.
+ * Improve exception handling. A property that threw a non-IOException
+ used to stop the whole propellor run. Now, all non-async exceptions
+ only make the property that threw them fail. (Implicit API change)
+ * Added StopPropellorException and stopPropellorMessage which can be
+ used in the unusual case where a failure of one property should stop
+ propellor from trying to ensure any other properties.
+ * tryPropellor returns Either SomeException instead of Either IOException
+ (API change)
+
+ -- Joey Hess <id@joeyh.name> Fri, 10 Jun 2016 14:59:44 -0400
+
propellor (3.0.5) unstable; urgency=medium
* Modules added for Sbuild and Ccache.
diff --git a/doc/forum/Apt.install_return_ok_even_if_asked_something_impossible.mdwn b/doc/forum/Apt.install_return_ok_even_if_asked_something_impossible.mdwn
new file mode 100644
index 00000000..2858a75a
--- /dev/null
+++ b/doc/forum/Apt.install_return_ok_even_if_asked_something_impossible.mdwn
@@ -0,0 +1,14 @@
+Hello joey
+
+here the result of the Apt.installed [ "dgit", "pypi2dsc" ]
+
+ apt installed dgit pypi2dsc ... ok
+
+
+BUT
+
+pypi2dsc does not exist (it is pypi2deb)
+
+So there is something wrong with the installed property :)
+
+Cheers
diff --git a/doc/forum/cabal:_Unrecognised_flags:_propellor-config/comment_4_7ee19c190d1acb8106079871dda7f521._comment b/doc/forum/cabal:_Unrecognised_flags:_propellor-config/comment_4_7ee19c190d1acb8106079871dda7f521._comment
new file mode 100644
index 00000000..83ebf6ec
--- /dev/null
+++ b/doc/forum/cabal:_Unrecognised_flags:_propellor-config/comment_4_7ee19c190d1acb8106079871dda7f521._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="craige@a46118dff5bc0fad85259759970d8b4b9fc377d7"
+ nickname="craige"
+ subject="Resolved"
+ date="2016-06-13T23:35:40Z"
+ content="""
+Cracked enough heads to get the box upgraded and the issue unsurpisingly vanished :-)
+"""]]
diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn
index bd343cd6..d6e339ed 100644
--- a/doc/haskell_newbie.mdwn
+++ b/doc/haskell_newbie.mdwn
@@ -48,12 +48,12 @@ Finally, you need to define the configuration for each host in the list:
[[!format haskell """
mylaptop :: Host
mylaptop = host "mylaptop.example.com"
- & osDebian Unstable "amd64"
+ & osDebian Unstable X86_64
& Apt.stdSourcesList
myserver :: Host
myserver = host "server.example.com"
- & osDebian (Stable "jessie") "amd64"
+ & osDebian (Stable "jessie") X86_64
& Apt.stdSourcesList
& Apt.installed ["ssh"]
"""]]
diff --git a/doc/news/version_2.15.4.mdwn b/doc/news/version_2.15.4.mdwn
deleted file mode 100644
index 4e20bcc9..00000000
--- a/doc/news/version_2.15.4.mdwn
+++ /dev/null
@@ -1,15 +0,0 @@
-propellor 2.15.4 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Build /usr/src/propellor/propellor.git reproducibly,
- which makes the whole Debian package build reproducibly.
- Thanks, Sean Whitton.
- * Obnam: To cause old generations to be forgotten, keepParam can be
- passed to a backup property; this causes obnam forget to be run.
- * Delete /etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist when
- unattended-upgrades is installed, to work around #812380 which results
- in many warnings from apt, including in cron mails.
- * Added Propellor.Property.LetsEncrypt
- * Apache.httpsVirtualHost: New property, setting up a https vhost
- with the certificate automatically obtained using letsencrypt.
- * Allow using combineProperties and propertyList with lists of
- RevertableProperty."""]] \ No newline at end of file
diff --git a/doc/news/version_2.16.0.mdwn b/doc/news/version_2.16.0.mdwn
deleted file mode 100644
index b7527f05..00000000
--- a/doc/news/version_2.16.0.mdwn
+++ /dev/null
@@ -1,18 +0,0 @@
-propellor 2.16.0 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Obnam: Only let one backup job run at a time when a host has multiple
- different backup properties, to avoid concurrent jobs fighting over
- scarce resources (particularly memory). Other jobs block on a lock
- file.
- * Removed references to a Debian derivative from code and documentation
- because of an unfortunate trademark use policy.
- http://joeyh.name/blog/entry/trademark\_nonsense/
- * That included changing a data constructor to "Buntish", an API change.
- * Firewall.rule: Now takes a Table parameter. (API change)
- * Firewall: add InIFace/OutIFace Rules, add Source/Destination Rules,
- add CustomTarget, and more improvements.
- Thanks, Félix Sipma.
- * Ssh.authorizedKey: Fix bug preventing it from working when the
- authorized\_keys file does not yet exist.
- * Removed Ssh.unauthorizedKey and made Ssh.authorizedKey revertable.
- (API change)"""]] \ No newline at end of file
diff --git a/doc/news/version_2.17.0.mdwn b/doc/news/version_2.17.0.mdwn
deleted file mode 100644
index 4149dbab..00000000
--- a/doc/news/version_2.17.0.mdwn
+++ /dev/null
@@ -1,30 +0,0 @@
-propellor 2.17.0 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Added initial support for FreeBSD.
- Thanks, Evan Cofsky.
- * Added Propellor.Property.ZFS.
- Thanks, Evan Cofsky.
- * Firewall: Reorganized Chain data type. (API change)
- Thanks, Félix Sipma.
- * Firewall: Separated Table and Target (API change)
- Thanks, Félix Sipma.
- * Ssh: change type of listenPort from Int to Port (API change)
- Thanks, Félix Sipma.
- * Firewall: add TCPFlag, Frequency, TCPSyn, ICMPTypeMatch, NatDestination
- Thanks, Félix Sipma.
- * Network: Filter out characters not allowed in interfaces.d files.
- Thanks, Félix Sipma.
- * Apt.upgrade: Run dpkg --configure -a first, to recover from
- interrupted upgrades.
- * Apt: Add safeupgrade.
- * Force ssh, scp, and git commands to be run in the foreground.
- Should fix intermittent hangs of propellor --spin.
- * Avoid repeated re-building on systems such as FreeBSD where building
- re-links the binary even when there are no changes.
- * Locale.available: Run locale-gen, instead of dpkg-reconfigure locales,
- which modified the locale.gen file and sometimes caused the property to
- need to make changes every time.
- * Speed up propellor's build of itself, by asking cabal to only build
- the propellor-config binary and not all the libraries.
- * Tor.named: Fix bug that sometimes caused the property to fail the first
- time, though retrying succeeded."""]] \ No newline at end of file
diff --git a/doc/news/version_2.17.1.mdwn b/doc/news/version_2.17.1.mdwn
deleted file mode 100644
index 22727666..00000000
--- a/doc/news/version_2.17.1.mdwn
+++ /dev/null
@@ -1,8 +0,0 @@
-propellor 2.17.1 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Avoid generating excessively long paths to the unix socket file
- used for ssh connection caching. Mostly. Can still generate a too long
- one if $HOME is longer than 60 bytes.
- * Uwsgi: add ".ini" extension to app config files.
- Files without extensions were ignored by uwsgi.
- Thanks, Félix Sipma."""]] \ No newline at end of file
diff --git a/doc/news/version_2.17.2.mdwn b/doc/news/version_2.17.2.mdwn
deleted file mode 100644
index 3b11ec89..00000000
--- a/doc/news/version_2.17.2.mdwn
+++ /dev/null
@@ -1,8 +0,0 @@
-propellor 2.17.2 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * When new dependencies are added to propellor or the propellor config,
- try harder to get them installed. In particular, this makes
- propellor --spin work when the remote host needs to get dependencies
- installed in order to build the updated config.
- * Apt.update: Also run dpkg --configure -a here as apt for some reason
- won't even update if dpkg was interrupted."""]] \ No newline at end of file
diff --git a/doc/todo/integrate_shell-monad/comment_1_202c24d0a757d5086f65721fc2779131._comment b/doc/todo/integrate_shell-monad/comment_1_202c24d0a757d5086f65721fc2779131._comment
new file mode 100644
index 00000000..bfa5e3b1
--- /dev/null
+++ b/doc/todo/integrate_shell-monad/comment_1_202c24d0a757d5086f65721fc2779131._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="gueux"
+ subject="comment 1"
+ date="2016-06-13T17:31:37Z"
+ content="""
+How would you see the integration of shell-monad or turtle?
+
+Do you have a preference?
+
+I actually use turtle and it is great! It may be more complete than shell-monad which may be an advantage or a disadvantage...
+"""]]
diff --git a/doc/todo/integrate_shell-monad/comment_2_4e82a5994b4647b4483c92c7785ee905._comment b/doc/todo/integrate_shell-monad/comment_2_4e82a5994b4647b4483c92c7785ee905._comment
new file mode 100644
index 00000000..0779c49f
--- /dev/null
+++ b/doc/todo/integrate_shell-monad/comment_2_4e82a5994b4647b4483c92c7785ee905._comment
@@ -0,0 +1,39 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2016-06-13T20:23:37Z"
+ content="""
+One easy way would be something like:
+
+ shellMonadProperty :: Control.Monad.Shell.Script Result -> Property UnixLike
+
+But, I don't know if that would really be useful. The better use case for
+shell-monad seems to be where things like `userScriptProperty` take a
+`Script`, that is currently an alias for `String`. Since shell-monad can
+generate a shell script, it would be easy to write:
+
+ shellMonad :: Control.Monad.Shell.Script () -> Script
+
+Or, perhaps change userScriptProperty to accept either a stringy-Script or
+a shell monad Script, via a type class. Then it could be used like this:
+
+ userScriptProperty (User "joey") $ do
+ cmd "echo" "hello"
+ cmd "rm" "/home/joey/something"
+
+Turtle seems to not have its own monad but simply uses MonadIO. So seems
+you can use Turtle in the implementation of propellor properties the same as
+other IO actions. Which is great, it should be easy to use it if you want
+to. Something like:
+
+ import Turtle.Prelude
+
+ myProperty :: Property UnixLike
+ myProperty = property "my property using turtle" $ liftIO $ do
+ echo "hello"
+ rm "/something"
+ return NoChange
+
+But I don't think turtle can generate shell scripts like used by
+`userScriptProperty`.
+"""]]
diff --git a/doc/todo/integrate_shell-monad/comment_3_155d4af99bbbd8681a9924198aa7da73._comment b/doc/todo/integrate_shell-monad/comment_3_155d4af99bbbd8681a9924198aa7da73._comment
new file mode 100644
index 00000000..48d25d7f
--- /dev/null
+++ b/doc/todo/integrate_shell-monad/comment_3_155d4af99bbbd8681a9924198aa7da73._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="gueux"
+ subject="comment 3"
+ date="2016-06-14T10:56:04Z"
+ content="""
+I've posted a question on https://github.com/Gabriel439/Haskell-Turtle-Library/issues/157
+
+Probably Gabriel will have a good idea for this :-). Maybe another solution would be to generate executables instead of shell scripts?
+
+
+"""]]
diff --git a/doc/todo/integrate_shell-monad/comment_4_4914d37a548e1a19733156fbd77142a6._comment b/doc/todo/integrate_shell-monad/comment_4_4914d37a548e1a19733156fbd77142a6._comment
new file mode 100644
index 00000000..77f30917
--- /dev/null
+++ b/doc/todo/integrate_shell-monad/comment_4_4914d37a548e1a19733156fbd77142a6._comment
@@ -0,0 +1,20 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2016-06-14T17:11:09Z"
+ content="""
+We already have /usr/local/bin/propellor executable, so the cron job or
+whatever could be made to run it with a parameter that runs the turtle IO
+action. (Or generally, any IO action.. Being able to run arbitrary haskell
+IO code as a cron job would be great!)
+
+This would need some way to get a `UniqueId` for an IO action, that is
+stable across runs of propellor, and a way to build up a` Map UniqueId (IO ())` of such
+actions. The Info interface could be used to build up that Map.
+
+----
+
+Some of the places I'd like to use shell-monad though are where propellor
+is bootstrapping itself on a host and all it can easily run at that point
+is shell script.
+"""]]
diff --git a/doc/todo/merge_request:_Sbuild.keypairInsecurelyGenerated.mdwn b/doc/todo/merge_request:_Sbuild.keypairInsecurelyGenerated.mdwn
index c8f3a195..7a22e976 100644
--- a/doc/todo/merge_request:_Sbuild.keypairInsecurelyGenerated.mdwn
+++ b/doc/todo/merge_request:_Sbuild.keypairInsecurelyGenerated.mdwn
@@ -1,3 +1,5 @@
Please consider merging branch `insecure-sbuild-keygen` from repo `https://git.spwhitton.name/propellor`.
- Adds `Sbuild.keyringInsecurelyGenerated` which is useful on throwaway build VMs
+
+> [[merged|done]] --[[Joey]]
diff --git a/doc/todo/merge_request:_changes_to_Reboot.hs/comment_1_766444e44fe64a66d57596b1ea9d416d._comment b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_1_766444e44fe64a66d57596b1ea9d416d._comment
new file mode 100644
index 00000000..a1a72054
--- /dev/null
+++ b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_1_766444e44fe64a66d57596b1ea9d416d._comment
@@ -0,0 +1,26 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2016-06-13T22:59:56Z"
+ content="""
+While I've merged this, I am unsure if Reboot.toKernelNewerThan
+should stop propellor from ensuring any subsequent properties.
+
+That works if we have:
+
+ & toKernelNewerThan foo
+ & Sbuild.built
+
+But not if the two properties are flipped. So, doesn't it follow
+that Sbuild.built is a buggy property?
+
+If Sbuild.built needs a particular kernel version running,
+it could requires toKernelNewerThan. Then any use of Sbuild.built
+would make sure the right kernel is running, rebooting into it if
+necessary.
+
+And, if toKernelNewerThan failed due to the right kernel version not being
+installed, Sbuild.built would be prevented from running. In which case, it
+would be fine for propellor to continue on with ensuring other unrelated
+properties.
+"""]]
diff --git a/doc/todo/merge_request:_changes_to_Reboot.hs/comment_2_736788cdf9afc98da3dfd5a120e7978b._comment b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_2_736788cdf9afc98da3dfd5a120e7978b._comment
new file mode 100644
index 00000000..fa1048a3
--- /dev/null
+++ b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_2_736788cdf9afc98da3dfd5a120e7978b._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2016-06-13T23:13:28Z"
+ content="""
+readVersionMaybe was buggy; for "4.1.2" it yielded
+`Just (Version {versionBranch = [4], versionTags = []})`
+which is lacking anything but the major.
+
+I fixed it by taking the maximum of the list of all possible parses.
+"""]]
diff --git a/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_4466bc58fd3e69938c184c817ddbb3e6._comment b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_4466bc58fd3e69938c184c817ddbb3e6._comment
new file mode 100644
index 00000000..4fa14683
--- /dev/null
+++ b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_4466bc58fd3e69938c184c817ddbb3e6._comment
@@ -0,0 +1,23 @@
+[[!comment format=mdwn
+ username="spwhitton"
+ subject="comment 3"
+ date="2016-06-14T03:16:18Z"
+ content="""
+Thanks for taking a look at my branch, and especially for fixing my inadequately-tested `readVersionMaybe`.
+
+`Sbuild.built` does not *require* a particular version of the kernel. It is just that the file that it generates in `/etc/schroot/chroot.d` can vary depending on the kernel version running at the time that `Sbuild.built` is first ensured. In particular, if the running kernel does not support overlayfs (as jessie's kernel doesn't), the line `union-type=overlay` will be omitted from the file in `/etc/schroot/chroot.d`. This renders `Schroot.overlaysInTmpfs` useless.
+
+I think it should be up to the user to apply a property like
+
+ & Sbuild.built foo `requires` Reboot.toKernelNewerThan bar
+
+to individual hosts, because it depends on whether they actually care about using an overlay chroot. Perhaps on an old machine they don't intend to use overlays. In my config, I do something like this:
+
+ & osDebian Testing \"i386\"
+ & Apt.stdSourcesList `onChange` (Apt.upgraded `before` Apt.cacheCleaned `before` Reboot.toKernelNewerThan \"4\")
+ & Sbuilt.builtFor ...
+
+The idea is that if I reinstall my machine from a jessie installation CD, propellor will upgrade to testing and boot to the new kernel before it builds the chroot, so I get the `union-type=overlay` line in my config.
+
+I could prepare a patch to add this information to the haddock of Sbuild.hs?
+"""]]
diff --git a/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_6460a7f85249bd8b9a83f2e145a25d62._comment b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_6460a7f85249bd8b9a83f2e145a25d62._comment
new file mode 100644
index 00000000..3d842ac3
--- /dev/null
+++ b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_3_6460a7f85249bd8b9a83f2e145a25d62._comment
@@ -0,0 +1,29 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 3"""
+ date="2016-06-14T04:04:50Z"
+ content="""
+It might also be worth making the Sbuild properties know
+whether overlays are desired. Then they could make sure to set up the
+config file with the needed lines, even if the wrong kernel is running.
+
+I assume schroot fails to work in that configuration, so the properties
+for it would fail and then the user would notice they need to add a
+property to get a new enough kernel version..
+
+It could be specified with another parameter to the Sbuild properties.
+Or, you could add a pure Info property `useOverlays` and have the
+Sbuild properties check if the Info has that set. This would also
+let Schroot.overlaysInTmpfs require useOverlays and auto-enable them.
+
+Most of the implementation of that:
+
+ useOverlays :: Property (HasInfo + UnixLike)
+ useOverlays = pureInfoProperty "use schroot overlays" (InfoVal UseOverlays)
+
+ data UseOverlays = UseOverlays
+
+ useOverlays :: Propellor Bool
+ useOverlays = isJust . fromInfoVal
+ <$> (askInfo :: Propellor (InfoVal UseOverlays))
+"""]]
diff --git a/doc/todo/merge_request:_changes_to_Reboot.hs/comment_4_b39af83b7f793013a7d63f340ee8de6d._comment b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_4_b39af83b7f793013a7d63f340ee8de6d._comment
new file mode 100644
index 00000000..148f8efb
--- /dev/null
+++ b/doc/todo/merge_request:_changes_to_Reboot.hs/comment_4_b39af83b7f793013a7d63f340ee8de6d._comment
@@ -0,0 +1,29 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2016-06-14T03:41:53Z"
+ content="""
+When `requires` is used as in your first example, Reboot.toKernelNewerThan
+does not need to throw an exception. It could just return FailedChange
+and then Sbuild.builtFor wouldn't get run.
+
+Your second example, as written is actually buggy. If Apt.upgraded
+fails for some reason, then Reboot.toKernelNewerThan never gets run,
+and then Sbuilt.builtFor can still run with the wrong kernel version.
+
+The second example could instead be written thus:
+
+ & osDebian Testing "i386"
+ & combineProperties "sbuild setup"
+ ( props
+ & Apt.stdSourcesList `onChange` (Apt.upgraded `before` Apt.cacheCleaned `before` Reboot.toKernelNewerThan "4")
+ & Sbuilt.builtFor ...
+ )
+
+Then if any part of the upgrade fails the following properties don't run
+thanks to `combineProperties`. And here too Reboot.toKernelNewerThan does
+not need to thow an exception.
+
+So, I'm not seeing any good use cases for it throwing an exception in these
+examples.
+"""]]
diff --git a/joeyconfig.hs b/joeyconfig.hs
index 98c565c5..364882b2 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -45,7 +45,7 @@ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.'
hosts :: [Host] -- * \ | | '--------'
hosts = -- (o) `
[ darkstar
- , gnu
+ , gnu
, clam
, mayfly
, oyster
@@ -60,7 +60,7 @@ hosts = -- (o) `
testvm :: Host
testvm = host "testvm.kitenet.net" $ props
- & osDebian Unstable "amd64"
+ & osDebian Unstable X86_64
& OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net")
`onChange` postinstall
& Hostname.sane
@@ -98,7 +98,7 @@ darkstar = host "darkstar.kitenet.net" $ props
]
where
c d = Chroot.debootstrapped mempty d $ props
- & osDebian Unstable "amd64"
+ & osDebian Unstable X86_64
& Hostname.setTo "demo"
& Apt.installed ["linux-image-amd64"]
& User "root" `User.hasInsecurePassword` "root"
@@ -112,7 +112,7 @@ gnu = host "gnu.kitenet.net" $ props
clam :: Host
clam = host "clam.kitenet.net" $ props
- & standardSystem Unstable "amd64"
+ & standardSystem Unstable X86_64
["Unreliable server. Anything here may be lost at any time!" ]
& ipv4 "167.88.41.194"
@@ -145,7 +145,7 @@ clam = host "clam.kitenet.net" $ props
mayfly :: Host
mayfly = host "mayfly.kitenet.net" $ props
- & standardSystem (Stable "jessie") "amd64"
+ & standardSystem (Stable "jessie") X86_64
[ "Scratch VM. Contents can change at any time!" ]
& ipv4 "167.88.36.193"
@@ -161,7 +161,7 @@ mayfly = host "mayfly.kitenet.net" $ props
oyster :: Host
oyster = host "oyster.kitenet.net" $ props
- & standardSystem Unstable "amd64"
+ & standardSystem Unstable X86_64
[ "Unreliable server. Anything here may be lost at any time!" ]
& ipv4 "104.167.117.109"
@@ -185,7 +185,7 @@ oyster = host "oyster.kitenet.net" $ props
orca :: Host
orca = host "orca.kitenet.net" $ props
- & standardSystem Unstable "amd64" [ "Main git-annex build box." ]
+ & standardSystem Unstable X86_64 [ "Main git-annex build box." ]
& ipv4 "138.38.108.179"
& Apt.unattendedUpgrades
@@ -195,19 +195,19 @@ orca = host "orca.kitenet.net" $ props
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
- Unstable "amd64" Nothing (Cron.Times "15 * * * *") "2h")
+ Unstable X86_64 Nothing (Cron.Times "15 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
- Unstable "i386" Nothing (Cron.Times "30 * * * *") "2h")
+ Unstable X86_32 Nothing (Cron.Times "30 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.stackAutoBuilder
- (Stable "jessie") "i386" (Just "ancient") (Cron.Times "45 * * * *") "2h")
+ (Stable "jessie") X86_32 (Just "ancient") (Cron.Times "45 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
(Cron.Times "1 1 * * *") "3h")
honeybee :: Host
honeybee = host "honeybee.kitenet.net" $ props
- & standardSystem Testing "armhf" [ "Arm git-annex build box." ]
+ & standardSystem Testing ARMHF [ "Arm git-annex build box." ]
-- I have to travel to get console access, so no automatic
-- upgrades, and try to be robust.
@@ -234,14 +234,14 @@ honeybee = host "honeybee.kitenet.net" $ props
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.armAutoBuilder
- Unstable "armel" Nothing Cron.Daily "22h")
+ Unstable ARMEL Nothing Cron.Daily "22h")
-- This is not a complete description of kite, since it's a
-- multiuser system with eg, user passwords that are not deployed
-- with propellor.
kite :: Host
kite = host "kite.kitenet.net" $ props
- & standardSystemUnhardened Testing "amd64" [ "Welcome to kite!" ]
+ & standardSystemUnhardened Testing X86_64 [ "Welcome to kite!" ]
& ipv4 "66.228.36.95"
& ipv6 "2600:3c03::f03c:91ff:fe73:b0d2"
& alias "kitenet.net"
@@ -356,7 +356,7 @@ kite = host "kite.kitenet.net" $ props
elephant :: Host
elephant = host "elephant.kitenet.net" $ props
- & standardSystem Unstable "amd64"
+ & standardSystem Unstable X86_64
[ "Storage, big data, and backups, omnomnom!"
, "(Encrypt all data stored here.)"
]
@@ -457,7 +457,7 @@ iabak :: Host
iabak = host "iabak.archiveteam.org" $ props
& ipv4 "124.6.40.227"
& Hostname.sane
- & osDebian Testing "amd64"
+ & osDebian Testing X86_64
& Systemd.persistentJournal
& Cron.runPropellor (Cron.Times "30 * * * *")
& Apt.stdSourcesList `onChange` Apt.upgrade
@@ -539,7 +539,7 @@ type Motd = [String]
-- This is my standard system setup.
standardSystem :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian)
-standardSystem suite arch motd =
+standardSystem suite arch motd =
standardSystemUnhardened suite arch motd
`before` Ssh.noPasswords
@@ -571,7 +571,7 @@ standardSystemUnhardened suite arch motd = propertyList "standard system" $ prop
-- This is my standard container setup, Featuring automatic upgrades.
standardContainer :: DebianSuite -> Property (HasInfo + Debian)
standardContainer suite = propertyList "standard container" $ props
- & osDebian suite "amd64"
+ & osDebian suite X86_64
& Apt.stdSourcesList `onChange` Apt.upgrade
& Apt.unattendedUpgrades
& Apt.cacheCleaned
diff --git a/propellor.cabal b/propellor.cabal
index dd71ab05..dd14fcc0 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -145,6 +145,7 @@ Library
Propellor.Property.ZFS.Properties
Propellor.Property.HostingProvider.CloudAtCost
Propellor.Property.HostingProvider.DigitalOcean
+ Propellor.Property.HostingProvider.Exoscale
Propellor.Property.HostingProvider.Linode
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
@@ -170,6 +171,7 @@ Library
Propellor.Types.Docker
Propellor.Types.Dns
Propellor.Types.Empty
+ Propellor.Types.Exception
Propellor.Types.Info
Propellor.Types.MetaTypes
Propellor.Types.OS
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 29175a67..2c8fa95a 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -60,7 +60,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
where
osinstall = case msys of
Just (System (FreeBSD _) _) -> map pkginstall fbsddeps
- Just (System (Debian _) _) -> useapt
+ Just (System (Debian _ _) _) -> useapt
Just (System (Buntish _) _) -> useapt
-- assume a debian derived system when not specified
Nothing -> useapt
@@ -115,7 +115,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
installGitCommand :: Maybe System -> ShellCommand
installGitCommand msys = case msys of
- (Just (System (Debian _) _)) -> use apt
+ (Just (System (Debian _ _) _)) -> use apt
(Just (System (Buntish _) _)) -> use apt
(Just (System (FreeBSD _) _)) -> use
[ "ASSUME_ALWAYS_YES=yes pkg update"
@@ -125,7 +125,7 @@ installGitCommand msys = case msys of
Nothing -> use apt
where
use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi"
- apt =
+ apt =
[ "apt-get update"
, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
]
@@ -177,7 +177,7 @@ cabalBuild msys = do
( return True
, case msys of
Nothing -> return False
- Just sys ->
+ Just sys ->
boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
<&&> cabal ["configure"]
)
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index 79b0b43f..c73420b0 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -166,7 +166,7 @@ setup = do
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."
@@ -273,7 +273,7 @@ minimalConfig = do
, " Extensions: TypeOperators"
, " Build-Depends: propellor >= 3.0, base >= 3"
]
- configcontent =
+ configcontent =
[ "-- This is the main configuration file for Propellor, and is used to build"
, "-- the propellor program. https://propellor.branchable.com/"
, ""
@@ -295,7 +295,7 @@ minimalConfig = do
, "-- An example host."
, "mybox :: Host"
, "mybox = host \"mybox.example.com\" $ props"
- , " & osDebian Unstable \"amd64\""
+ , " & osDebian Unstable X86_64"
, " & Apt.stdSourcesList"
, " & Apt.unattendedUpgrades"
, " & Apt.installed [\"etckeeper\"]"
@@ -354,7 +354,7 @@ checkRepoUpToDate :: IO ()
checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do
headrev <- takeWhile (/= '\n') <$> readFile disthead
changeWorkingDirectory =<< dotPropellor
- headknown <- catchMaybeIO $
+ headknown <- catchMaybeIO $
withQuietOutput createProcessSuccess $
proc "git" ["log", headrev]
if (headknown == Nothing)
@@ -397,19 +397,19 @@ setupUpstreamMaster newref = do
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"]
-
+
void $ 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
diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs
index 2b38af0c..3ab783bf 100644
--- a/src/Propellor/Exception.hs
+++ b/src/Propellor/Exception.hs
@@ -1,18 +1,31 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Propellor.Exception where
import Propellor.Types
+import Propellor.Types.Exception
import Propellor.Message
import Utility.Exception
-import Control.Exception (IOException)
+import Control.Exception (AsyncException)
+import Control.Monad.Catch
+import Control.Monad.IO.Class (MonadIO)
--- | Catches IO exceptions and returns FailedChange.
-catchPropellor :: Propellor Result -> Propellor Result
+-- | Catches all exceptions (except for `StopPropellorException` and
+-- `AsyncException`) and returns FailedChange.
+catchPropellor :: (MonadIO m, MonadCatch m) => m Result -> m Result
catchPropellor a = either err return =<< tryPropellor a
where
err e = warningMessage (show e) >> return FailedChange
-tryPropellor :: Propellor a -> Propellor (Either IOException a)
-tryPropellor = try
+catchPropellor' :: MonadCatch m => m a -> (SomeException -> m a) -> m a
+catchPropellor' a onerr = a `catches`
+ [ Handler (\ (e :: AsyncException) -> throwM e)
+ , Handler (\ (e :: StopPropellorException) -> throwM e)
+ , Handler (\ (e :: SomeException) -> onerr e)
+ ]
+
+-- | Catches all exceptions (except for `StopPropellorException` and
+-- `AsyncException`).
+tryPropellor :: MonadCatch m => m a -> m (Either SomeException a)
+tryPropellor a = (Right <$> a) `catchPropellor'` (pure . Left)
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index b87369c3..e9218291 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -77,9 +77,15 @@ askInfo = asks (fromInfo . hostInfo)
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
--- > & osDebian (Stable "jessie") "amd64"
+-- > & osDebian (Stable "jessie") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
-osDebian suite arch = tightenTargets $ os (System (Debian suite) arch)
+osDebian = osDebian' Linux
+
+-- Use to specify a different `DebianKernel` than the default `Linux`
+--
+-- > & osDebian' KFreeBSD (Stable "jessie") X86_64
+osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
+osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
-- | Specifies that a host's operating system is a well-known Debian
-- derivative founded by a space tourist.
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 32625e6a..f728e143 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -13,6 +13,7 @@ module Propellor.Message (
warningMessage,
infoMessage,
errorMessage,
+ stopPropellorMessage,
processChainOutput,
messagesDone,
createProcessConcurrent,
@@ -29,6 +30,7 @@ import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.Exception
import Utility.PartialPrelude
import Utility.Monad
import Utility.Exception
@@ -105,11 +107,29 @@ warningMessage s = liftIO $
infoMessage :: MonadIO m => [String] -> m ()
infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
+-- | Displays the error message in red, and throws an exception.
+--
+-- When used inside a property, the exception will make the current
+-- property fail. Propellor will continue to the next property.
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+ -- Normally this exception gets caught and is not displayed,
+ -- and propellor continues. So it's only displayed if not
+ -- caught, and so we say, cannot continue.
error "Cannot continue!"
+-- | Like `errorMessage`, but throws a `StopPropellorException`,
+-- preventing propellor from continuing to the next property.
+--
+-- Think twice before using this. Is the problem so bad that propellor
+-- cannot try to ensure other properties? If not, use `errorMessage`
+-- instead.
+stopPropellorMessage :: MonadIO m => String -> m a
+stopPropellorMessage s = liftIO $ do
+ outputConcurrent =<< colorLine Vivid Red ("** fatal error: " ++ s)
+ throwM $ StopPropellorException "Cannot continue!"
+
colorLine :: ColorIntensity -> Color -> String -> IO String
colorLine intensity color msg = concat <$> sequence
[ whenConsole $
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 5e185a0e..a99fbefa 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -82,7 +82,7 @@ securityUpdates suite
-- kernel.org.
stdSourcesList :: Property Debian
stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
- (Just (System (Debian suite) _)) ->
+ (Just (System (Debian _ suite) _)) ->
ensureProperty w $ stdSourcesListFor suite
_ -> unsupportedOS'
@@ -161,7 +161,7 @@ installed' params ps = robustly $ check (isInstallable ps) go
installedBackport :: [Package] -> Property Debian
installedBackport ps = withOS desc $ \w o -> case o of
- (Just (System (Debian suite) _)) -> case backportSuite suite of
+ (Just (System (Debian _ suite) _)) -> case backportSuite suite of
Nothing -> unsupportedOS'
Just bs -> ensureProperty w $
runApt (["install", "-t", bs, "-y"] ++ ps)
@@ -257,7 +257,7 @@ unattendedUpgrades = enable <!> disable
enableupgrading = withOS "unattended upgrades configured" $ \w o ->
case o of
-- the package defaults to only upgrading stable
- (Just (System (Debian suite) _))
+ (Just (System (Debian _ suite) _))
| not (isStable suite) -> ensureProperty w $
unattendedconfig
`File.containsLine`
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
index f5842115..16030562 100644
--- a/src/Propellor/Property/Borg.hs
+++ b/src/Propellor/Property/Borg.hs
@@ -23,7 +23,7 @@ type BorgRepo = FilePath
installed :: Property DebianLike
installed = withOS desc $ \w o -> case o of
- (Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $
+ (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
Apt.installedBackport ["borgbackup"]
_ -> ensureProperty w $
Apt.installed ["borgbackup"]
diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs
index f2246fe1..34ed6761 100644
--- a/src/Propellor/Property/Ccache.hs
+++ b/src/Propellor/Property/Ccache.hs
@@ -66,8 +66,7 @@ path `hasLimits` limit = go `requires` installed
cmdPropertyEnv "ccache" params' [("CCACHE_DIR", path)]
`changesFileContent` (path </> "ccache.conf")
| otherwise = property "couldn't parse ccache limits" $
- sequence_ (errorMessage <$> errors)
- >> return FailedChange
+ errorMessage $ unlines errors
params = limitToParams limit
(errors, params') = partitionEithers params
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 09047ce5..cb693a73 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -91,7 +91,7 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
- (Just s@(System (Debian _) _)) -> Right $ debootstrap s
+ (Just s@(System (Debian _ _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; OS not specified"
@@ -105,7 +105,7 @@ instance ChrootBootstrapper Debootstrapped where
-- to bootstrap.
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index b86d8e0b..d8a9c423 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -141,7 +141,7 @@ mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props
rsyncextraarg res = intercalate "," $ map showRsyncExtra res
args =
[ "--dist" , suitearg
- , "--arch", architecturearg $ _debianMirrorArchitectures mirror'
+ , "--arch", architecturearg $ map architectureToDebianArchString (_debianMirrorArchitectures mirror')
, "--section", intercalate "," $ _debianMirrorSections mirror'
, "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\""
]
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 87f30776..69ac036a 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -67,7 +67,7 @@ built' installprop target system@(System _ arch) config =
Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
Just s -> pure s
let params = toParams config ++
- [ Param $ "--arch=" ++ arch
+ [ Param $ "--arch=" ++ architectureToDebianArchString arch
, Param suite
, Param target
]
@@ -90,7 +90,7 @@ built' installprop target system@(System _ arch) config =
)
extractSuite :: System -> Maybe String
-extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
+extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
extractSuite (System (FreeBSD _) _) = Nothing
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index afeaa287..06dfa69c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,4 +1,4 @@
--- | Disk image generation.
+-- | Disk image generation.
--
-- This module is designed to be imported unqualified.
@@ -56,7 +56,7 @@ type DiskImage = FilePath
-- > import Propellor.Property.DiskImage
--
-- > let chroot d = Chroot.debootstrapped mempty d
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installed ["linux-image-amd64"]
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
@@ -91,7 +91,7 @@ imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
-imageBuilt' rebuild img mkchroot tabletype final partspec =
+imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
@@ -132,7 +132,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
- szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
+ szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
@@ -151,7 +151,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
-partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
@@ -165,11 +165,11 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
- filtersfor mnt =
+ filtersfor mnt =
let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
(catMaybes mnts)
- in concatMap (\m ->
+ in concatMap (\m ->
-- Include the child mount point, but exclude its contents.
[ Include (Pattern m)
, Exclude (filesUnder m)
@@ -185,8 +185,8 @@ fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
(mounts, mountopts, sizers) = unzip3 l
parttable = PartTable tt (zipWith id sizers basesizes)
--- | Generates a map of the sizes of the contents of
--- every directory in a filesystem tree.
+-- | Generates a map of the sizes of the contents of
+-- every directory in a filesystem tree.
--
-- (Hard links are counted multiple times for simplicity)
--
@@ -201,7 +201,7 @@ dirSizes top = go M.empty top [top]
if isDirectory s
then do
subm <- go M.empty i =<< dirContents i
- let sz' = M.foldr' (+) sz
+ let sz' = M.foldr' (+) sz
(M.filterWithKey (const . subdirof i) subm)
go (M.insertWith (+) i sz' (M.union m subm)) dir is
else go (M.insertWith (+) dir sz m) dir is
@@ -209,13 +209,13 @@ dirSizes top = go M.empty top [top]
getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
-getMountSz szm l (Just mntpt) =
+getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
-- | Ensures that a disk image file of the specified size exists.
---
+--
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
@@ -223,7 +223,7 @@ imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
- Just s
+ Just s
| toInteger (fileSize s) == toInteger sz -> return NoChange
| toInteger (fileSize s) > toInteger sz -> do
setFileSize img (fromInteger sz)
@@ -239,15 +239,15 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
-- with its populated partition tree mounted in the provided
-- location from the provided loop devices. This will typically
-- take care of installing the boot loader to the image.
---
+--
-- It's ok if the second property leaves additional things mounted
-- in the partition tree.
type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
+imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
- withTmpDir "mnt" $ \top ->
+ withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
where
go w top = do
@@ -255,12 +255,12 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
liftIO $ writefstab top
liftIO $ allowservices top
ensureProperty w $ final top devs
-
+
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
-
+
swaps = map (SwapPartition . partitionLoopDev . snd) $
filter ((== LinuxSwap) . partFs . fst) $
zip parts devs
@@ -276,7 +276,7 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
unmountall top = do
unmountBelow top
umountLazy top
-
+
writefstab top = do
let fstab = top ++ "/etc/fstab"
old <- catchDefaultIO [] $ filter (not . unconfigured) . lines
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index fcad9e87..58477468 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -9,7 +9,6 @@ module Propellor.Property.FreeBSD.Poudriere where
import Propellor.Base
import Propellor.Types.Info
import Data.List
-import Data.String (IsString(..))
import qualified Propellor.Property.FreeBSD.Pkg as Pkg
import qualified Propellor.Property.ZFS as ZFS
@@ -27,7 +26,7 @@ poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
setConfigured :: Property (HasInfo + FreeBSD)
-setConfigured = tightenTargets $
+setConfigured = tightenTargets $
pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
poudriere :: Poudriere -> Property (HasInfo + FreeBSD)
@@ -106,10 +105,10 @@ instance Show PoudriereArch where
show I386 = "i386"
show AMD64 = "amd64"
-instance IsString PoudriereArch where
- fromString "i386" = I386
- fromString "amd64" = AMD64
- fromString _ = error "Not a valid Poudriere architecture."
+fromArchitecture :: Architecture -> PoudriereArch
+fromArchitecture X86_64 = AMD64
+fromArchitecture X86_32 = I386
+fromArchitecture _ = error "Not a valid Poudriere architecture."
yesNoProp :: Bool -> String
yesNoProp b = if b then "yes" else "no"
diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
index c1e0ffc9..053338de 100644
--- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs
+++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
@@ -7,15 +7,13 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
-import Data.List
-
-- | Digital Ocean does not provide any way to boot
-- the kernel provided by the distribution, except using kexec.
-- Without this, some old, and perhaps insecure kernel will be used.
--
-- This property causes the distro kernel to be loaded on reboot, using kexec.
--
--- If the power is cycled, the non-distro kernel still boots up.
+-- When the power is cycled, the non-distro kernel still boots up.
-- So, this property also checks if the running kernel is present in /boot,
-- and if not, reboots immediately into a distro kernel.
distroKernel :: Property DebianLike
@@ -25,25 +23,4 @@ distroKernel = propertyList "digital ocean distro kernel hack" $ props
[ "LOAD_KEXEC=true"
, "USE_GRUB_CONFIG=true"
] `describe` "kexec configured"
- & check (not <$> runningInstalledKernel) Reboot.now
- `describe` "running installed kernel"
-
-runningInstalledKernel :: IO Bool
-runningInstalledKernel = do
- kernelver <- takeWhile (/= '\n') <$> readProcess "uname" ["-r"]
- when (null kernelver) $
- error "failed to read uname -r"
- kernelimages <- concat <$> mapM kernelsIn ["/", "/boot/"]
- when (null kernelimages) $
- error "failed to find any installed kernel images"
- findVersion kernelver <$>
- readProcess "file" ("-L" : kernelimages)
-
--- | File output looks something like this, we want to unambiguously
--- match the running kernel version:
--- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA
-findVersion :: String -> String -> Bool
-findVersion ver s = (" version " ++ ver ++ " ") `isInfixOf` s
-
-kernelsIn :: FilePath -> IO [FilePath]
-kernelsIn d = filter ("vmlinu" `isInfixOf`) <$> dirContents d
+ & Reboot.toDistroKernel
diff --git a/src/Propellor/Property/HostingProvider/Exoscale.hs b/src/Propellor/Property/HostingProvider/Exoscale.hs
new file mode 100644
index 00000000..18e3c42f
--- /dev/null
+++ b/src/Propellor/Property/HostingProvider/Exoscale.hs
@@ -0,0 +1,37 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+--
+-- Properties for use on <https://www.exoscale.ch/>
+
+module Propellor.Property.HostingProvider.Exoscale (
+ distroKernel,
+) where
+
+import Propellor.Base
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Grub as Grub
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Reboot as Reboot
+
+-- | Flavor of kernel, eg "amd64" or "686"
+type KernelFlavor = String
+
+-- | The current Exoshare Debian image doesn't install GRUB, so this property
+-- makes sure GRUB is installed and correctly configured
+--
+-- In case an old, insecure kernel is running, we check for an old kernel
+-- version and reboot immediately if one is found.
+--
+-- Note that we ignore anything after the first hyphen when considering
+-- whether the running kernel's version is older than the Debian-supplied
+-- kernel's version.
+distroKernel :: KernelFlavor -> Property DebianLike
+distroKernel kernelflavor = go `flagFile` theFlagFile
+ where
+ go = combineProperties "boots distro kernel" $ props
+ & Apt.installed ["grub2", "linux-image-" ++ kernelflavor]
+ & Grub.boots "/dev/vda"
+ & Grub.mkConfig
+ -- Since we're rebooting we have to manually create the flagfile
+ & File.hasContent theFlagFile [""]
+ & Reboot.toDistroKernel
+ theFlagFile = "/etc/propellor-distro-kernel"
diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs
index 592a1e1d..9e4898dd 100644
--- a/src/Propellor/Property/LetsEncrypt.hs
+++ b/src/Propellor/Property/LetsEncrypt.hs
@@ -8,10 +8,8 @@ import qualified Propellor.Property.Apt as Apt
import System.Posix.Files
--- Not using the certbot name yet, until it reaches jessie-backports and
--- testing.
installed :: Property DebianLike
-installed = Apt.installed ["letsencrypt"]
+installed = Apt.installed ["certbot"]
-- | Tell the letsencrypt client that you agree with the Let's Encrypt
-- Subscriber Agreement. Providing an email address is recommended,
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index bb0f60a7..026509a9 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -118,7 +118,7 @@ blkidTag tag dev = catchDefaultIO Nothing $
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
- errorMessage $ "failed unmounting " ++ mnt
+ stopPropellorMessage $ "failed unmounting " ++ mnt
-- | Unmounts anything mounted inside the specified directory.
unmountBelow :: FilePath -> IO ()
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index 5a3ccc70..d974cfbc 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -22,7 +22,7 @@ import Control.Exception (throw)
-- | Replaces whatever OS was installed before with a clean installation
-- of the OS that the Host is configured to have.
---
+--
-- This is experimental; use with caution!
--
-- This can replace one Linux distribution with different one.
@@ -35,7 +35,7 @@ import Control.Exception (throw)
-- This property only runs once. The cleanly installed system will have
-- a file </etc/propellor-cleaninstall>, which indicates it was cleanly
-- installed.
---
+--
-- The files from the old os will be left in </old-os>
--
-- After the OS is installed, and if all properties of the host have
@@ -46,7 +46,7 @@ import Control.Exception (throw)
-- install succeeds, to bootstrap from the cleanly installed system to
-- a fully working system. For example:
--
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & cleanInstallOnce (Confirmed "foo.example.com")
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
@@ -68,7 +68,7 @@ cleanInstallOnce :: Confirmation -> Property Linux
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
- go =
+ go =
finalized
`requires`
-- easy to forget and system may not boot without shadow pw!
@@ -85,19 +85,19 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
osbootstrapped :: Property Linux
osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
- (Just d@(System (Debian _) _)) -> ensureProperty w $
+ (Just d@(System (Debian _ _) _)) -> ensureProperty w $
debootstrap d
(Just u@(System (Buntish _) _)) -> ensureProperty w $
debootstrap u
_ -> unsupportedOS'
-
+
debootstrap :: System -> Property Linux
debootstrap targetos =
-- Install debootstrap from source, since we don't know
-- what OS we're currently running in.
Debootstrap.built' Debootstrap.sourceInstall
newOSDir targetos Debootstrap.DefaultConfig
- -- debootstrap, I wish it was faster..
+ -- debootstrap, I wish it was faster..
-- TODO eatmydata to speed it up
-- Problem: Installing eatmydata on some random OS like
-- Fedora may be difficult. Maybe configure dpkg to not
@@ -120,7 +120,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
createDirectoryIfMissing True oldOSDir
massRename (renamesout ++ renamesin)
removeDirectoryRecursive newOSDir
-
+
-- Prepare environment for running additional properties,
-- overriding old OS's environment.
void $ setEnv "PATH" stdPATH True
@@ -150,15 +150,15 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- git repo url, which all need to be arranged to
-- be present in /old-os's /usr/local/propellor)
-- TODO
-
+
finalized :: Property UnixLike
finalized = property "clean OS installed" $ do
liftIO $ writeFile flagfile ""
return MadeChange
flagfile = "/etc/propellor-cleaninstall"
-
- trickydirs =
+
+ trickydirs =
-- /tmp can contain X's sockets, which prevent moving it
-- so it's left as-is.
[ "/tmp"
@@ -195,7 +195,7 @@ confirmed desc (Confirmed c) = property desc $ do
return FailedChange
else return NoChange
--- | </etc/network/interfaces> is configured to bring up the network
+-- | </etc/network/interfaces> is configured to bring up the network
-- interface that currently has a default route configured, using
-- the same (static) IP address.
preserveNetwork :: Property DebianLike
@@ -210,7 +210,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile
ensureProperty w $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
- return FailedChange
+ return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
preserveResolvConf :: Property Linux
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 5b854fa3..6a0626a2 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -1,12 +1,34 @@
-module Propellor.Property.Reboot where
+module Propellor.Property.Reboot (
+ now,
+ atEnd,
+ toDistroKernel,
+ toKernelNewerThan,
+ KernelVersion,
+) where
import Propellor.Base
+import Data.List
+import Data.Version
+import Text.ParserCombinators.ReadP
+
+-- | Kernel version number, in a string.
+type KernelVersion = String
+
+-- | Using this property causes an immediate reboot.
+--
+-- So, this is not a useful property on its own, but it can be useful to
+-- compose with other properties. For example:
+--
+-- > Apt.installed ["new-kernel"]
+-- > `onChange` Reboot.now
now :: Property Linux
now = tightenTargets $ cmdProperty "reboot" []
`assume` MadeChange
`describe` "reboot now"
+type Force = Bool
+
-- | Schedules a reboot at the end of the current propellor run.
--
-- The `Result` code of the entire propellor run can be checked;
@@ -14,7 +36,7 @@ now = tightenTargets $ cmdProperty "reboot" []
--
-- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property Linux
+atEnd :: Force -> (Result -> Bool) -> Property Linux
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend
return NoChange
@@ -28,3 +50,93 @@ atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
rebootparams
| force = [Param "--force"]
| otherwise = []
+
+-- | Reboots immediately if a kernel other than the distro-installed kernel is
+-- running.
+--
+-- This will only work if you have taken measures to ensure that the other
+-- kernel won't just get booted again.
+-- See 'Propellor.Property.HostingProvider.DigitalOcean'
+-- for an example of how to do this.
+toDistroKernel :: Property DebianLike
+toDistroKernel = check (not <$> runningInstalledKernel) now
+ `describe` "running installed kernel"
+
+-- | Given a kernel version string @v@, reboots immediately if the running
+-- kernel version is strictly less than @v@ and there is an installed kernel
+-- version is greater than or equal to @v@. Dies if the requested kernel
+-- version is not installed.
+--
+-- For this to be useful, you need to have ensured that the installed kernel
+-- with the highest version number is the one that will be started after a
+-- reboot.
+--
+-- This is useful when upgrading to a new version of Debian where you need to
+-- ensure that a new enough kernel is running before ensuring other properties.
+toKernelNewerThan :: KernelVersion -> Property DebianLike
+toKernelNewerThan ver =
+ property' ("reboot to kernel newer than " ++ ver) $ \w -> do
+ wantV <- tryReadVersion ver
+ runningV <- tryReadVersion =<< liftIO runningKernelVersion
+ installedV <- maximum <$>
+ (mapM tryReadVersion =<< liftIO installedKernelVersions)
+ if runningV >= wantV then noChange
+ else if installedV >= wantV
+ then ensureProperty w now
+ -- Stop propellor here because other
+ -- properties may be incorrectly ensured
+ -- under a kernel version that's too old.
+ -- E.g. Sbuild.built can fail
+ -- to add the config line `union-type=overlay`
+ else stopPropellorMessage $
+ "kernel newer than "
+ ++ ver
+ ++ " not installed"
+
+runningInstalledKernel :: IO Bool
+runningInstalledKernel = do
+ kernelver <- runningKernelVersion
+ when (null kernelver) $
+ error "failed to read uname -r"
+ kernelimages <- installedKernelImages
+ when (null kernelimages) $
+ error "failed to find any installed kernel images"
+ findVersion kernelver <$>
+ readProcess "file" ("-L" : kernelimages)
+
+runningKernelVersion :: IO KernelVersion
+runningKernelVersion = takeWhile (/= '\n') <$> readProcess "uname" ["-r"]
+
+installedKernelImages :: IO [String]
+installedKernelImages = concat <$> mapM kernelsIn ["/", "/boot/"]
+
+-- | File output looks something like this, we want to unambiguously
+-- match the running kernel version:
+-- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA
+findVersion :: KernelVersion -> String -> Bool
+findVersion ver s = (" version " ++ ver ++ " ") `isInfixOf` s
+
+installedKernelVersions :: IO [KernelVersion]
+installedKernelVersions = do
+ kernelimages <- installedKernelImages
+ when (null kernelimages) $
+ error "failed to find any installed kernel images"
+ imageLines <- lines <$> readProcess "file" ("-L" : kernelimages)
+ return $ extractKernelVersion <$> imageLines
+
+kernelsIn :: FilePath -> IO [FilePath]
+kernelsIn d = filter ("vmlinu" `isInfixOf`) <$> dirContents d
+
+extractKernelVersion :: String -> KernelVersion
+extractKernelVersion =
+ unwords . take 1 . drop 1 . dropWhile (/= "version") . words
+
+readVersionMaybe :: KernelVersion -> Maybe Version
+readVersionMaybe ver = case map fst $ readP_to_S parseVersion ver of
+ [] -> Nothing
+ l -> Just $ maximum l
+
+tryReadVersion :: KernelVersion -> Propellor Version
+tryReadVersion ver = case readVersionMaybe ver of
+ Just x -> return x
+ Nothing -> errorMessage ("couldn't parse version " ++ ver)
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index 2647e69e..50825a0c 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -9,9 +9,9 @@ Build and maintain schroots for use with sbuild.
Suggested usage in @config.hs@:
> & Apt.installed ["piuparts"]
-> & Sbuild.builtFor (System (Debian Unstable) "i386")
-> & Sbuild.piupartsConfFor (System (Debian Unstable) "i386")
-> & Sbuild.updatedFor (System (Debian Unstable) "i386") `period` Weekly 1
+> & Sbuild.builtFor (System (Debian Unstable) X86_32)
+> & Sbuild.piupartsConfFor (System (Debian Unstable) X86_32)
+> & Sbuild.updatedFor (System (Debian Unstable) X86_32) `period` Weekly 1
> & Sbuild.usableBy (User "spwhitton")
> & Sbuild.shareAptCache
> & Schroot.overlaysInTmpfs
@@ -66,6 +66,7 @@ module Propellor.Property.Sbuild (
-- blockNetwork,
installed,
keypairGenerated,
+ keypairInsecurelyGenerated,
shareAptCache,
usableBy,
) where
@@ -93,7 +94,7 @@ type Suite = String
data SbuildSchroot = SbuildSchroot Suite Architecture
instance Show SbuildSchroot where
- show (SbuildSchroot suite arch) = suite ++ "-" ++ arch
+ show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
-- | Build and configure a schroot for use with sbuild using a distribution's
-- standard mirror
@@ -130,7 +131,7 @@ built s@(SbuildSchroot suite arch) mirror =
make w = do
de <- liftIO standardPathEnv
let params = Param <$>
- [ "--arch=" ++ arch
+ [ "--arch=" ++ architectureToDebianArchString arch
, "--chroot-suffix=-propellor"
, "--include=eatmydata,ccache"
, suite
@@ -192,7 +193,7 @@ updated s@(SbuildSchroot suite arch) =
where
go :: Property DebianLike
go = tightenTargets $ cmdProperty
- "sbuild-update" ["-udr", suite ++ "-" ++ arch]
+ "sbuild-update" ["-udr", suite ++ "-" ++ architectureToDebianArchString arch]
`assume` MadeChange
-- Find the conf file that sbuild-createchroot(1) made when we passed it
@@ -219,7 +220,7 @@ fixConfFile s@(SbuildSchroot suite arch) =
where
new = schrootConf s
dir = takeDirectory new
- tempPrefix = dir </> suite ++ "-" ++ arch ++ "-propellor-"
+ tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-"
munge = replace "-propellor]" "-sbuild]"
-- | Create a corresponding schroot config file for use with piuparts
@@ -320,7 +321,22 @@ keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
go = tightenTargets $
cmdProperty "sbuild-update" ["--keygen"]
`assume` MadeChange
- secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"
+
+secKeyFile :: FilePath
+secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"
+
+-- | Generate the apt keys needed by sbuild using a low-quality source of
+-- randomness
+--
+-- Useful on throwaway build VMs.
+keypairInsecurelyGenerated :: Property DebianLike
+keypairInsecurelyGenerated = check (not <$> doesFileExist secKeyFile) go
+ where
+ go :: Property DebianLike
+ go = combineProperties "sbuild keyring insecurely generated" $ props
+ & Apt.installed ["rng-tools"]
+ & cmdProperty "rngd" ["-r", "/dev/urandom"] `assume` MadeChange
+ & keypairGenerated
-- another script from wiki.d.o/sbuild
ccachePrepared :: Property DebianLike
@@ -367,17 +383,17 @@ schrootFromSystem system@(System _ arch) =
>>= \suite -> return $ SbuildSchroot suite arch
stdMirror :: System -> Maybe Apt.Url
-stdMirror (System (Debian _) _) = Just "http://httpredir.debian.org/debian"
+stdMirror (System (Debian _ _) _) = Just "http://httpredir.debian.org/debian"
stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/"
stdMirror _ = Nothing
schrootRoot :: SbuildSchroot -> FilePath
-schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ a
+schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ architectureToDebianArchString a
schrootConf :: SbuildSchroot -> FilePath
schrootConf (SbuildSchroot s a) =
- "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-sbuild-propellor"
+ "/etc/schroot/chroot.d" </> s ++ "-" ++ architectureToDebianArchString a ++ "-sbuild-propellor"
schrootPiupartsConf :: SbuildSchroot -> FilePath
schrootPiupartsConf (SbuildSchroot s a) =
- "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-piuparts-propellor"
+ "/etc/schroot/chroot.d" </> s ++ "-" ++ architectureToDebianArchString a ++ "-piuparts-propellor"
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index b4812c7e..90c9c7bf 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -25,7 +25,9 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h
-autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike)
+type ArchString = String
+
+autobuilder :: ArchString -> Times -> TimeOut -> Property (HasInfo + DebianLike)
autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
& Apt.serviceInstalledRunning "cron"
& Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir
@@ -47,7 +49,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
then makeChange $ writeFile pwfile want
else noChange
-tree :: Architecture -> Flavor -> Property DebianLike
+tree :: ArchString -> Flavor -> Property DebianLike
tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& Apt.installed ["git"]
& File.dirExists gitbuilderdir
@@ -55,7 +57,7 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& gitannexbuildercloned
& builddircloned
where
- gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
+ gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
userScriptProperty (User builduser)
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
, "cd " ++ gitbuilderdir
@@ -85,7 +87,7 @@ buildDepsNoHaskellLibs = Apt.installed
]
haskellPkgsInstalled :: String -> Property DebianLike
-haskellPkgsInstalled dir = tightenTargets $
+haskellPkgsInstalled dir = tightenTargets $
flagFile go ("/haskellpkgsinstalled")
where
go = userScriptProperty (User builduser)
@@ -107,9 +109,9 @@ autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasI
autoBuilderContainer mkprop suite arch flavor crontime timeout =
Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props
& mkprop suite arch flavor
- & autobuilder arch crontime timeout
+ & autobuilder (architectureToDebianArchString arch) crontime timeout
where
- name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
+ name = architectureToDebianArchString arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
type Flavor = Maybe String
@@ -122,7 +124,7 @@ standardAutoBuilder suite arch flavor =
& Apt.unattendedUpgrades
& Apt.cacheCleaned
& User.accountFor (User builduser)
- & tree arch flavor
+ & tree (architectureToDebianArchString arch) flavor
stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
stackAutoBuilder suite arch flavor =
@@ -133,7 +135,7 @@ stackAutoBuilder suite arch flavor =
& Apt.unattendedUpgrades
& Apt.cacheCleaned
& User.accountFor (User builduser)
- & tree arch flavor
+ & tree (architectureToDebianArchString arch) flavor
& stackInstalled
-- Workaround https://github.com/commercialhaskell/stack/issues/2093
& Apt.installed ["libtinfo-dev"]
@@ -141,15 +143,15 @@ stackAutoBuilder suite arch flavor =
stackInstalled :: Property Linux
stackInstalled = withOS "stack installed" $ \w o ->
case o of
- (Just (System (Debian (Stable "jessie")) "i386")) ->
- ensureProperty w $ manualinstall "i386"
+ (Just (System (Debian Linux (Stable "jessie")) X86_32)) ->
+ ensureProperty w $ manualinstall X86_32
_ -> ensureProperty w $ Apt.installed ["haskell-stack"]
where
-- Warning: Using a binary downloaded w/o validation.
manualinstall :: Architecture -> Property Linux
manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $
propertyList "stack installed from upstream tarball" $ props
- & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
+ & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ architectureToDebianArchString arch, "-O", tmptar]
`assume` MadeChange
& File.dirExists tmpdir
& cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
@@ -163,7 +165,7 @@ stackInstalled = withOS "stack installed" $ \w o ->
tmpdir = "/root/stack"
armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
-armAutoBuilder suite arch flavor =
+armAutoBuilder suite arch flavor =
propertyList "arm git-annex autobuilder" $ props
& standardAutoBuilder suite arch flavor
& buildDepsNoHaskellLibs
@@ -187,9 +189,9 @@ androidAutoBuilderContainer'
-> Times
-> TimeOut
-> Systemd.Container
-androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
+androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
Systemd.container name $ \d -> bootstrap d $ props
- & osDebian (Stable "jessie") "i386"
+ & osDebian (Stable "jessie") X86_32
& Apt.stdSourcesList
& User.accountFor (User builduser)
& File.dirExists gitbuilderdir
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index a6cb3794..652a7141 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -103,7 +103,7 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
& oldUseNetInstalled "oldusenet-server"
& oldUseNetBackup
& spoolsymlink
- & "/etc/news/leafnode/config" `File.hasContent`
+ & "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire
, "server = " -- no upstream server
@@ -134,7 +134,7 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
, Apache.allowAll
, " </Directory>"
]
-
+
spoolsymlink :: Property UnixLike
spoolsymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
(property "olduse.net spool in place" $ makeChange $ do
@@ -177,7 +177,7 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
]
`assume` MadeChange
`describe` "olduse.net built"
-
+
kgbServer :: Property (HasInfo + Debian)
kgbServer = propertyList desc $ props
& installed
@@ -187,7 +187,7 @@ kgbServer = propertyList desc $ props
desc = "kgb.kitenet.net setup"
installed :: Property Debian
installed = withOS desc $ \w o -> case o of
- (Just (System (Debian Unstable) _)) ->
+ (Just (System (Debian _ Unstable) _)) ->
ensureProperty w $ propertyList desc $ props
& Apt.serviceInstalledRunning "kgb-bot"
& "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
@@ -289,7 +289,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
postupdatehook = dir </> ".git/hooks/post-update"
setup = userScriptProperty (User "joey") setupscript
`assume` MadeChange
- setupscript =
+ setupscript =
[ "cd " ++ shellEscape dir
, "git annex reinit " ++ shellEscape uuid
] ++ map addremote remotes ++
@@ -316,7 +316,7 @@ apacheSite :: HostName -> Apache.ConfigFile -> RevertableProperty DebianLike Deb
apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle
apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile
-apachecfg hn middle =
+apachecfg hn middle =
[ "<VirtualHost *:"++show port++">"
, " ServerAdmin grue@joeyh.name"
, " ServerName "++hn++":"++show port
@@ -333,7 +333,7 @@ apachecfg hn middle =
]
where
port = 80 :: Int
-
+
gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
& Apt.installed ["rsync"]
@@ -360,7 +360,7 @@ downloads hosts = annexWebSite "/srv/git/downloads.git"
"840760dc-08f0-11e2-8c61-576b7e66acfd"
[("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")]
`requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey")
-
+
tmp :: Property (HasInfo + DebianLike)
tmp = propertyList "tmp.kitenet.net" $ props
& annexWebSite "/srv/git/joey/tmp.git"
@@ -384,7 +384,7 @@ twitRss = combineProperties "twitter rss" $ props
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
compiled = userScriptProperty (User "joey")
[ "cd " ++ dir
- , "ghc --make twitRss"
+ , "ghc --make twitRss"
]
`assume` NoChange
`requires` Apt.installed
@@ -447,7 +447,7 @@ githubBackup = propertyList "github-backup box" $ props
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
githubKeys :: Property (HasInfo + UnixLike)
-githubKeys =
+githubKeys =
let f = "/home/joey/.github-keys"
in File.hasPrivContent f anyContext
`onChange` File.ownerGroup f (User "joey") (Group "joey")
@@ -511,14 +511,14 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
] `onChange` Service.restarted "spamassassin"
`describe` "spamd enabled"
`requires` Apt.serviceInstalledRunning "cron"
-
+
& Apt.serviceInstalledRunning "spamass-milter"
-- Add -m to prevent modifying messages Subject or body.
& "/etc/default/spamass-milter" `File.containsLine`
"OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\""
`onChange` Service.restarted "spamass-milter"
`describe` "spamass-milter configured"
-
+
& Apt.serviceInstalledRunning "amavisd-milter"
& "/etc/default/amavisd-milter" `File.containsLines`
[ "# Propellor deployed"
@@ -642,7 +642,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
`onChange` Postfix.dedupMainCf
`onChange` Postfix.reloaded
`describe` "postfix configured"
-
+
& Apt.serviceInstalledRunning "dovecot-imapd"
& Apt.serviceInstalledRunning "dovecot-pop3d"
& "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
@@ -679,16 +679,18 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
, "inbox-path={localhost/novalidate-cert/NoRsh}inbox"
]
`describe` "pine configured to use local imap server"
-
+
& Apt.serviceInstalledRunning "mailman"
& Postfix.service ssmtp
+
+ & Apt.installed ["fetchmail"]
where
ctx = Context "kitenet.net"
pinescript = "/usr/local/bin/pine"
dovecotusers = "/etc/dovecot/users"
- ssmtp = Postfix.Service
+ ssmtp = Postfix.Service
(Postfix.InetService Nothing "ssmtp")
"smtpd" Postfix.defServiceOpts
@@ -825,7 +827,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "RewriteRule ^/joey/index.html http://www.kitenet.net/joey/ [R]"
, "RewriteRule ^/wifi http://www.kitenet.net/wifi/ [R]"
, "RewriteRule ^/wifi/index.html http://www.kitenet.net/wifi/ [R]"
-
+
, "# Old ikiwiki filenames for kitenet.net wiki."
, "rewritecond $1 !^/~"
, "rewritecond $1 !^/doc/"
@@ -912,7 +914,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "rewritecond $1 !.*/index$"
, "rewriterule (.+).rss$ http://joeyh.name/$1/index.rss [l]"
-
+
, "# Redirect all to joeyh.name."
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index e11c991e..78529f73 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -204,7 +204,7 @@ machined :: Property Linux
machined = withOS "machined installed" $ \w o ->
case o of
-- Split into separate debian package since systemd 225.
- (Just (System (Debian suite) _))
+ (Just (System (Debian _ suite) _))
| not (isStable suite) -> ensureProperty w $
Apt.installed ["systemd-container"]
_ -> noChange
@@ -217,11 +217,11 @@ machined = withOS "machined installed" $ \w o ->
-- to bootstrap.
--
-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installedRunning "apache2"
-- > & ...
container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
-container name mkchroot =
+container name mkchroot =
let c = Container name chroot h
in setContainerProps c $ containerProps c
&^ resolvConfed
@@ -238,7 +238,7 @@ container name mkchroot =
-- to bootstrap.
--
-- > debContainer "webserver" $ props
--- > & osDebian Unstable "amd64"
+-- > & osDebian Unstable X86_64
-- > & Apt.installedRunning "apache2"
-- > & ...
debContainer :: MachineName -> Props metatypes -> Container
@@ -447,7 +447,7 @@ instance Publishable (Proto, Bound Port) where
-- >
-- > webserver :: Systemd.container
-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty)
--- > & os (System (Debian Testing) "amd64")
+-- > & os (System (Debian Testing) X86_64)
-- > & Systemd.privateNetwork
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)
diff --git a/src/Propellor/Types/Exception.hs b/src/Propellor/Types/Exception.hs
new file mode 100644
index 00000000..3a810d55
--- /dev/null
+++ b/src/Propellor/Types/Exception.hs
@@ -0,0 +1,21 @@
+module Propellor.Types.Exception where
+
+import Data.Typeable
+import Control.Exception
+
+-- | Normally when an exception is encountered while propellor is
+-- ensuring a property, the property fails, but propellor robustly
+-- continues on to the next property.
+--
+-- This is the only exception that will stop the entire propellor run,
+-- preventing any subsequent properties of the Host from being ensured.
+-- (When propellor is running in a container in a Host, this exception only
+-- stops the propellor run in the container; the outer run in the Host
+-- continues.)
+--
+-- You should only throw this exception when things are so badly messed up
+-- that it's best for propellor to not try to do anything else.
+data StopPropellorException = StopPropellorException String
+ deriving (Show, Typeable)
+
+instance Exception StopPropellorException
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index d7df5490..b569a6e8 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -4,12 +4,14 @@ module Propellor.Types.OS (
System(..),
Distribution(..),
TargetOS(..),
+ DebianKernel(..),
DebianSuite(..),
FreeBSDRelease(..),
FBSDVersion(..),
isStable,
Release,
- Architecture,
+ Architecture(..),
+ architectureToDebianArchString,
HostName,
UserName,
User(..),
@@ -29,7 +31,7 @@ data System = System Distribution Architecture
deriving (Show, Eq, Typeable)
data Distribution
- = Debian DebianSuite
+ = Debian DebianKernel DebianSuite
| Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/>
| FreeBSD FreeBSDRelease
deriving (Show, Eq)
@@ -43,10 +45,15 @@ data TargetOS
deriving (Show, Eq, Ord)
systemToTargetOS :: System -> TargetOS
-systemToTargetOS (System (Debian _) _) = OSDebian
+systemToTargetOS (System (Debian _ _) _) = OSDebian
systemToTargetOS (System (Buntish _) _) = OSBuntish
systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD
+-- | Most of Debian ports are based on Linux. There also exist hurd-i386,
+-- kfreebsd-i386, kfreebsd-amd64 ports
+data DebianKernel = Linux | KFreeBSD | Hurd
+ deriving (Show, Eq)
+
-- | Debian has several rolling suites, and a number of stable releases,
-- such as Stable "jessie".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
@@ -75,7 +82,53 @@ isStable (Stable _) = True
isStable _ = False
type Release = String
-type Architecture = String
+
+-- | Many of these architecture names are based on the names used by
+-- Debian, with a few exceptions for clarity.
+data Architecture
+ = X86_64 -- ^ 64 bit Intel, called "amd64" in Debian
+ | X86_32 -- ^ 32 bit Intel, called "i386" in Debian
+ | ARMHF
+ | ARMEL
+ | PPC
+ | PPC64
+ | SPARC
+ | SPARC64
+ | MIPS
+ | MIPSEL
+ | MIPS64EL
+ | SH4
+ | IA64 -- ^ Itanium
+ | S390
+ | S390X
+ | ALPHA
+ | HPPA
+ | M68K
+ | ARM64
+ | X32 -- ^ New Linux ABI for 64 bit CPUs using 32-bit integers. Not widely used.
+ deriving (Show, Eq)
+
+architectureToDebianArchString :: Architecture -> String
+architectureToDebianArchString X86_64 = "amd64"
+architectureToDebianArchString X86_32 = "i386"
+architectureToDebianArchString ARMHF = "armhf"
+architectureToDebianArchString ARMEL = "armel"
+architectureToDebianArchString PPC = "powerpc"
+architectureToDebianArchString PPC64 = "ppc64el"
+architectureToDebianArchString SPARC = "sparc"
+architectureToDebianArchString SPARC64 = "sparc64"
+architectureToDebianArchString MIPS = "mips"
+architectureToDebianArchString MIPSEL = "mipsel"
+architectureToDebianArchString MIPS64EL = "mips64el"
+architectureToDebianArchString SH4 = "sh"
+architectureToDebianArchString IA64 = "ia64"
+architectureToDebianArchString S390 = "s390"
+architectureToDebianArchString S390X = "s390x"
+architectureToDebianArchString ALPHA = "alpha"
+architectureToDebianArchString HPPA = "hppa"
+architectureToDebianArchString M68K = "m68k"
+architectureToDebianArchString ARM64 = "arm64"
+architectureToDebianArchString X32 = "x32"
type UserName = String