diff options
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 |