summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 05:53:38 -0400
committerJoey Hess2016-03-28 05:55:48 -0400
commita1655d24bbb1db9caccdf93eae8110d746389ae2 (patch)
tree66b6890d852c19daec2306920fecf9108e055273
parentebf30061d8f8a251330070e69c2710fe4a8fd9da (diff)
type safe targets for properties
* Property types have been improved to indicate what systems they target. This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: - Change "host name & foo & bar" to "host name $ props & foo & bar" - Similarly, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy.
-rw-r--r--config-freebsd.hs13
-rw-r--r--config-simple.hs23
-rw-r--r--debian/changelog69
-rw-r--r--debian/control2
-rw-r--r--doc/FreeBSD.mdwn6
-rw-r--r--doc/Linux.mdwn2
-rw-r--r--doc/haskell_newbie.mdwn6
-rw-r--r--doc/todo/depend_on_concurrent-output.mdwn3
-rw-r--r--doc/todo/type_level_OS_requirements.mdwn7
-rw-r--r--doc/writing_properties.mdwn10
-rw-r--r--joeyconfig.hs149
-rw-r--r--propellor.cabal46
-rw-r--r--src/Propellor.hs9
-rw-r--r--src/Propellor/Bootstrap.hs1
-rw-r--r--src/Propellor/Container.hs62
-rw-r--r--src/Propellor/Engine.hs23
-rw-r--r--src/Propellor/EnsureProperty.hs70
-rw-r--r--src/Propellor/Info.hs108
-rw-r--r--src/Propellor/PrivData.hs45
-rw-r--r--src/Propellor/PropAccum.hs122
-rw-r--r--src/Propellor/Property.hs126
-rw-r--r--src/Propellor/Property/Aiccu.hs16
-rw-r--r--src/Propellor/Property/Apache.hs54
-rw-r--r--src/Propellor/Property/Apt.hs119
-rw-r--r--src/Propellor/Property/Chroot.hs99
-rw-r--r--src/Propellor/Property/Cmd.hs10
-rw-r--r--src/Propellor/Property/Concurrent.hs14
-rw-r--r--src/Propellor/Property/Conductor.hs57
-rw-r--r--src/Propellor/Property/ConfFile.hs8
-rw-r--r--src/Propellor/Property/Cron.hs25
-rw-r--r--src/Propellor/Property/DebianMirror.hs20
-rw-r--r--src/Propellor/Property/Debootstrap.hs42
-rw-r--r--src/Propellor/Property/DiskImage.hs92
-rw-r--r--src/Propellor/Property/Dns.hs45
-rw-r--r--src/Propellor/Property/DnsSec.hs12
-rw-r--r--src/Propellor/Property/Docker.hs161
-rw-r--r--src/Propellor/Property/Fail2Ban.hs8
-rw-r--r--src/Propellor/Property/File.hs49
-rw-r--r--src/Propellor/Property/Firewall.hs4
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs17
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs21
-rw-r--r--src/Propellor/Property/Git.hs23
-rw-r--r--src/Propellor/Property/Gpg.hs5
-rw-r--r--src/Propellor/Property/Group.hs2
-rw-r--r--src/Propellor/Property/Grub.hs39
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs33
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs11
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs9
-rw-r--r--src/Propellor/Property/Hostname.hs21
-rw-r--r--src/Propellor/Property/Journald.hs16
-rw-r--r--src/Propellor/Property/Kerberos.hs29
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs7
-rw-r--r--src/Propellor/Property/LightDM.hs6
-rw-r--r--src/Propellor/Property/List.hs111
-rw-r--r--src/Propellor/Property/Locale.hs38
-rw-r--r--src/Propellor/Property/Logcheck.hs4
-rw-r--r--src/Propellor/Property/Mount.hs17
-rw-r--r--src/Propellor/Property/Munin.hs8
-rw-r--r--src/Propellor/Property/Network.hs38
-rw-r--r--src/Propellor/Property/Nginx.hs14
-rw-r--r--src/Propellor/Property/OS.hs51
-rw-r--r--src/Propellor/Property/Obnam.hs17
-rw-r--r--src/Propellor/Property/OpenId.hs6
-rw-r--r--src/Propellor/Property/Parted.hs17
-rw-r--r--src/Propellor/Property/Partition.hs12
-rw-r--r--src/Propellor/Property/Postfix.hs37
-rw-r--r--src/Propellor/Property/PropellorRepo.hs2
-rw-r--r--src/Propellor/Property/Prosody.hs12
-rw-r--r--src/Propellor/Property/Reboot.hs6
-rw-r--r--src/Propellor/Property/Rsync.hs6
-rw-r--r--src/Propellor/Property/Scheduled.hs13
-rw-r--r--src/Propellor/Property/Service.hs10
-rw-r--r--src/Propellor/Property/SiteSpecific/Branchable.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs103
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs11
-rw-r--r--src/Propellor/Property/SiteSpecific/IABak.hs13
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs133
-rw-r--r--src/Propellor/Property/Ssh.hs193
-rw-r--r--src/Propellor/Property/Sudo.hs9
-rw-r--r--src/Propellor/Property/Systemd.hs163
-rw-r--r--src/Propellor/Property/Systemd/Core.hs2
-rw-r--r--src/Propellor/Property/Tor.hs44
-rw-r--r--src/Propellor/Property/Unbound.hs8
-rw-r--r--src/Propellor/Property/User.hs63
-rw-r--r--src/Propellor/Property/Uwsgi.hs12
-rw-r--r--src/Propellor/Property/ZFS/Properties.hs12
-rw-r--r--src/Propellor/Spin.hs4
-rw-r--r--src/Propellor/Types.hs408
-rw-r--r--src/Propellor/Types/Core.hs106
-rw-r--r--src/Propellor/Types/Info.hs15
-rw-r--r--src/Propellor/Types/MetaTypes.hs213
-rw-r--r--src/Propellor/Types/OS.hs21
-rw-r--r--src/Propellor/Types/ResultCheck.hs3
-rw-r--r--src/Propellor/Types/Singletons.hs49
-rw-r--r--src/System/Console/Concurrent.hs44
-rw-r--r--src/System/Console/Concurrent/Internal.hs556
-rw-r--r--src/System/Process/Concurrent.hs34
97 files changed, 2341 insertions, 2275 deletions
diff --git a/config-freebsd.hs b/config-freebsd.hs
index b6334c31..3ee3f27c 100644
--- a/config-freebsd.hs
+++ b/config-freebsd.hs
@@ -27,8 +27,8 @@ hosts =
-- An example freebsd host.
freebsdbox :: Host
-freebsdbox = host "freebsdbox.example.com"
- & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64")
+freebsdbox = host "freebsdbox.example.com" $ props
+ & osFreeBSD (FBSDProduction FBSD102) "amd64"
& Pkg.update
& Pkg.upgrade
& Poudriere.poudriere poudriereZFS
@@ -43,8 +43,8 @@ poudriereZFS = Poudriere.defaultConfig
-- An example linux host.
linuxbox :: Host
-linuxbox = host "linuxbox.example.com"
- & os (System (Debian Unstable) "amd64")
+linuxbox = host "linuxbox.example.com" $ props
+ & osDebian Unstable "amd64"
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& Apt.installed ["etckeeper"]
@@ -58,10 +58,9 @@ linuxbox = host "linuxbox.example.com"
-- A generic webserver in a Docker container.
webserverContainer :: Docker.Container
-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
- & os (System (Debian (Stable "jessie")) "amd64")
+webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props
+ & osDebian (Stable "jessie") "amd64"
& Apt.stdSourcesList
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"
-
diff --git a/config-simple.hs b/config-simple.hs
index 21accd18..42b3d838 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -4,15 +4,8 @@
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Network as Network
---import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.Cron as Cron
-import Propellor.Property.Scheduled
---import qualified Propellor.Property.Sudo as Sudo
import qualified Propellor.Property.User as User
---import qualified Propellor.Property.Hostname as Hostname
---import qualified Propellor.Property.Tor as Tor
-import qualified Propellor.Property.Docker as Docker
main :: IO ()
main = defaultMain hosts
@@ -25,24 +18,12 @@ hosts =
-- An example host.
mybox :: Host
-mybox = host "mybox.example.com"
- & os (System (Debian Unstable) "amd64")
+mybox = host "mybox.example.com" $ props
+ & osDebian Unstable "amd64"
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& Apt.installed ["etckeeper"]
& Apt.installed ["ssh"]
& User.hasSomePassword (User "root")
- & Network.ipv6to4
& File.dirExists "/var/www"
- & Docker.docked webserverContainer
- & Docker.garbageCollected `period` Daily
& Cron.runPropellor (Cron.Times "30 * * * *")
-
--- A generic webserver in a Docker container.
-webserverContainer :: Docker.Container
-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
- & os (System (Debian (Stable "jessie")) "amd64")
- & Apt.stdSourcesList
- & Docker.publish "80:80"
- & Docker.volume "/var/www:/var/www"
- & Apt.serviceInstalledRunning "apache2"
diff --git a/debian/changelog b/debian/changelog
index 15587571..0560b15e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,68 @@
+propellor (3.0.0) UNRELEASED; urgency=medium
+
+ * Property types have been improved to indicate what systems they target.
+ This prevents using eg, Property FreeBSD on a Debian system.
+ Transition guide for this sweeping API change:
+ - Change "host name & foo & bar"
+ to "host name $ props & foo & bar"
+ - Similarly, `propertyList` and `combineProperties` need `props`
+ to be used to combine together properties; they no longer accept
+ lists of properties. (If you have such a list, use `toProps`.)
+ - And similarly, Chroot, Docker, and Systemd container need `props`
+ to be used to combine together the properies used inside them.
+ - The `os` property is removed. Instead use `osDebian`, `osBuntish`,
+ or `osFreeBSD`. These tell the type checker the target OS of a host.
+ - Change "Property NoInfo" to "Property UnixLike"
+ - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
+ - Change "RevertableProperty NoInfo" to
+ "RevertableProperty UnixLike UnixLike"
+ - Change "RevertableProperty HasInfo" to
+ "RevertableProperty (HasInfo + UnixLike) UnixLike"
+ - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types.
+ This is enabled by default for all modules in propellor.cabal. But
+ if you are using propellor as a library, you may need to enable it
+ manually.
+ - If you know a property only works on a particular OS, like Debian
+ or FreeBSD, use that instead of "UnixLike". For example:
+ "Property Debian"
+ - It's also possible make a property support a set of OS's, for example:
+ "Property (Debian + FreeBSD)"
+ - Removed `infoProperty` and `simpleProperty` constructors, instead use
+ `property` to construct a Property.
+ - Due to the polymorphic type returned by `property`, additional type
+ signatures tend to be needed when using it. For example, this will
+ fail to type check, because the type checker cannot guess what type
+ you intend the intermediate property "go" to have:
+ foo :: Property UnixLike
+ foo = go `requires` bar
+ where
+ go = property "foo" (return NoChange)
+ To fix, specify the type of go:
+ go :: Property UnixLike
+ - `ensureProperty` now needs to be passed a witness to the type of the
+ property it's used in.
+ change this: foo = property desc $ ... ensureProperty bar
+ to this: foo = property' desc $ \w -> ... ensureProperty w bar
+ - General purpose properties like cmdProperty have type "Property UnixLike".
+ When using that to run a command only available on Debian, you can
+ tighten the type to only the OS that your more specific property works on.
+ For example:
+ upgraded :: Property Debian
+ upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"])
+ - Several utility functions have been renamed:
+ getInfo to fromInfo
+ propertyInfo to getInfo
+ propertyDesc to getDesc
+ propertyChildren to getChildren
+ * The new `pickOS` property combinator can be used to combine different
+ properties, supporting different OS's, into one Property that chooses
+ which to use based on the Host's OS.
+ * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling
+ these complex new types.
+ * Added dependency on concurrent-output; removed embedded copy.
+
+ -- Joey Hess <id@joeyh.name> Thu, 24 Mar 2016 15:02:33 -0400
+
propellor (2.17.1) UNRELEASED; urgency=medium
* Avoid generating excessively long paths to the unix socket file
@@ -481,12 +546,12 @@ propellor (2.0.0) unstable; urgency=medium
This was done to make sure that ensureProperty is only used on
properties that do not have Info.
Transition guide:
- - Change all "Property" to "Property NoInfo" or "Property WithInfo"
+ - Change all "Property" to "Property NoInfo" or "Property HasInfo"
(The compiler can tell you if you got it wrong!)
- To construct a RevertableProperty, it is useful to use the new
(<!>) operator
- Constructing a list of properties can be problimatic, since
- Property NoInto and Property WithInfo are different types and cannot
+ Property NoInto and Property HasInfo are different types and cannot
appear in the same list. To deal with this, "props" has been added,
and can built up a list of properties of different types,
using the same (&) and (!) operators that are used to build
diff --git a/debian/control b/debian/control
index 757462d1..898e558d 100644
--- a/debian/control
+++ b/debian/control
@@ -18,6 +18,7 @@ Build-Depends:
libghc-exceptions-dev (>= 0.6),
libghc-stm-dev,
libghc-text-dev,
+ libghc-concurrent-output-dev,
Maintainer: Joey Hess <id@joeyh.name>
Standards-Version: 3.9.6
Vcs-Git: git://git.joeyh.name/propellor
@@ -41,6 +42,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-exceptions-dev (>= 0.6),
libghc-stm-dev,
libghc-text-dev,
+ libghc-concurrent-output-dev,
git,
make,
Description: property-based host configuration management in haskell
diff --git a/doc/FreeBSD.mdwn b/doc/FreeBSD.mdwn
index 2edff223..47b9c65b 100644
--- a/doc/FreeBSD.mdwn
+++ b/doc/FreeBSD.mdwn
@@ -1,8 +1,10 @@
Propellor is in the early stages of supporting FreeBSD. It should basically
work, and there are some modules with FreeBSD-specific properties.
-However, many other properties assume they're being run on a
-Debian Linux system, and need additional porting to support FreeBSD.
+However, many other properties only work on a Debian Linux system, and need
+additional porting to support FreeBSD. Such properties have types like
+`Property DebianLike`. The type checker will detect and reject attempts
+to combine such properties with `Property FreeBSD`.
[Sample config file](http://git.joeyh.name/?p=propellor.git;a=blob;f=config-freebsd.hs)
which configures a FreeBSD system, as well as a Linux one.
diff --git a/doc/Linux.mdwn b/doc/Linux.mdwn
index 0434d69d..00276f69 100644
--- a/doc/Linux.mdwn
+++ b/doc/Linux.mdwn
@@ -6,4 +6,4 @@ Indeed, Propellor has been ported to [[FreeBSD]] now!
See [[forum/Supported_OS]] for porting tips.
Note that you can run Propellor on a OSX laptop and have it manage Linux
-systems.
+and other systems.
diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn
index e92481f9..bd343cd6 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"
- & os (System (Debian Unstable) "amd64")
+ & osDebian Unstable "amd64"
& Apt.stdSourcesList
myserver :: Host
myserver = host "server.example.com"
- & os (System (Debian (Stable "jessie")) "amd64")
+ & osDebian (Stable "jessie") "amd64"
& Apt.stdSourcesList
& Apt.installed ["ssh"]
"""]]
@@ -96,7 +96,7 @@ is.
<pre>
config.hs:30:19:
Couldn't match expected type `RevertableProperty'
- with actual type `Property NoInfo'
+ with actual type `Property DebianLike'
In the return type of a call of `Apt.installed'
In the second argument of `(!)', namely `Apt.installed ["ssh"]'
In the first argument of `(&)', namely
diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn
index fdc66b04..a104c82b 100644
--- a/doc/todo/depend_on_concurrent-output.mdwn
+++ b/doc/todo/depend_on_concurrent-output.mdwn
@@ -8,3 +8,6 @@ Once this is done, can switch GHC-Options back to -O0 from -O.
-O0 is better because ghc takes less memory to build propellor.
[[!tag user/joey]]
+
+> [[done]]. Didn't wait for it to hit stable; cabal will be used to install
+> it.
diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn
index 7c2fb78f..f1c3e59f 100644
--- a/doc/todo/type_level_OS_requirements.mdwn
+++ b/doc/todo/type_level_OS_requirements.mdwn
@@ -21,13 +21,12 @@ withOS.
The `os` property would need to yield a `Property (os:[])`, where the type
level list contains a type-level eqivilant of the value passed to the
-property. Is that possible to do? reification or something?
-(See: <https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection>)
-Or, alternatively, could have less polymorphic `debian` etc
+property. Is that possible to do?
+Or, alternatively, could have less polymorphic `osDebian` etc
properties replace the `os` property.
If a Host's list of properties, when all combined together,
-contains more than one element in its '[OS], that needs to be a type error,
+contains more than one element in its '[OS], that could be a type error,
the OS of the Host is indeterminite. Which would be fixed by using the `os`
property to specify.
diff --git a/doc/writing_properties.mdwn b/doc/writing_properties.mdwn
index 2209026f..1b7f046a 100644
--- a/doc/writing_properties.mdwn
+++ b/doc/writing_properties.mdwn
@@ -31,7 +31,7 @@ Propellor makes it very easy to put together a property like this.
Let's start with a property that combines the two properties you mentioned:
- hasLoginShell :: UserName -> FilePath -> Property
+ hasLoginShell :: UserName -> FilePath -> Property UnixLike
hasLoginShell user shell = shellSetTo user shell `requires` shellEnabled shell
The shellEnabled property can be easily written using propellor's file
@@ -40,14 +40,14 @@ manipulation properties.
-- Need to add an import to the top of the source file.
import qualified Propellor.Property.File as File
- shellEnabled :: FilePath -> Property
+ shellEnabled :: FilePath -> Property UnixLike
shellEnabled shell = "/etc/shells" `File.containsLine` shell
And then, we want to actually change the user's shell. The `chsh(1)`
program can do that, so we can simply tell propellor the command line to
run:
- shellSetTo :: UserName -> FilePath -> Property
+ shellSetTo :: UserName -> FilePath -> Property UnixLike
shellSetTo user shell = cmdProperty "chsh" ["--shell", shell, user]
The only remaining problem with this is that shellSetTo runs chsh every
@@ -56,7 +56,7 @@ it runs, even when it didn't really do much. Now, there's an easy way to
avoid that problem, we could just tell propellor to assume that chsh
has not made a change:
- shellSetTo :: UserName -> FilePath -> Property
+ shellSetTo :: UserName -> FilePath -> Property UnixLike
shellSetTo user shell = cmdProperty "chsh" ["--shell", shell, user]
`assume` NoChange
@@ -64,7 +64,7 @@ But, it's not much harder to do this right. Let's make the property
check if the user's shell is already set to the desired value and avoid
doing anything in that case.
- shellSetTo :: UserName -> FilePath -> Property
+ shellSetTo :: UserName -> FilePath -> Property UnixLike
shellSetTo user shell = check needchangeshell $
cmdProperty "chsh" ["--shell", shell, user]
where
diff --git a/joeyconfig.hs b/joeyconfig.hs
index 327c268e..3852f14b 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -59,24 +59,26 @@ hosts = -- (o) `
] ++ monsters
testvm :: Host
-testvm = host "testvm.kitenet.net"
- & os (System (Debian Unstable) "amd64")
+testvm = host "testvm.kitenet.net" $ props
+ & osDebian Unstable "amd64"
& OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net")
- `onChange` propertyList "fixing up after clean install"
- [ OS.preserveRootSshAuthorized
- , OS.preserveResolvConf
- , Apt.update
- , Grub.boots "/dev/sda"
- `requires` Grub.installed Grub.PC
- ]
+ `onChange` postinstall
& Hostname.sane
& Hostname.searchDomain
& Apt.installed ["linux-image-amd64"]
& Apt.installed ["ssh"]
& User.hasPassword (User "root")
+ where
+ postinstall :: Property DebianLike
+ postinstall = propertyList "fixing up after clean install" $ props
+ & OS.preserveRootSshAuthorized
+ & OS.preserveResolvConf
+ & Apt.update
+ & Grub.boots "/dev/sda"
+ `requires` Grub.installed Grub.PC
darkstar :: Host
-darkstar = host "darkstar.kitenet.net"
+darkstar = host "darkstar.kitenet.net" $ props
& ipv6 "2001:4830:1600:187::2"
& Aiccu.hasConfig "T18376" "JHZ2-SIXXS"
@@ -95,22 +97,23 @@ darkstar = host "darkstar.kitenet.net"
, swapPartition (MegaBytes 256)
]
where
- c d = Chroot.debootstrapped mempty d
- & os (System (Debian Unstable) "amd64")
+ c d = Chroot.debootstrapped mempty d $ props
+ & osDebian Unstable "amd64"
& Hostname.setTo "demo"
& Apt.installed ["linux-image-amd64"]
& User "root" `User.hasInsecurePassword` "root"
gnu :: Host
-gnu = host "gnu.kitenet.net"
+gnu = host "gnu.kitenet.net" $ props
& Apt.buildDep ["git-annex"] `period` Daily
& JoeySites.postfixClientRelay (Context "gnu.kitenet.net")
& JoeySites.dkimMilter
clam :: Host
-clam = standardSystem "clam.kitenet.net" Unstable "amd64"
- [ "Unreliable server. Anything here may be lost at any time!" ]
+clam = host "clam.kitenet.net" $ props
+ & standardSystem Unstable "amd64"
+ ["Unreliable server. Anything here may be lost at any time!" ]
& ipv4 "167.88.41.194"
& CloudAtCost.decruft
@@ -141,8 +144,9 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
& alias "us.scroll.joeyh.name"
mayfly :: Host
-mayfly = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64"
- [ "Scratch VM. Contents can change at any time!" ]
+mayfly = host "mayfly.kitenet.net" $ props
+ & standardSystem (Stable "jessie") "amd64"
+ [ "Scratch VM. Contents can change at any time!" ]
& ipv4 "167.88.36.193"
& CloudAtCost.decruft
@@ -156,8 +160,9 @@ mayfly = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64"
& Tor.bandwidthRate (Tor.PerMonth "400 GB")
oyster :: Host
-oyster = standardSystem "oyster.kitenet.net" Unstable "amd64"
- [ "Unreliable server. Anything here may be lost at any time!" ]
+oyster = host "oyster.kitenet.net" $ props
+ & standardSystem Unstable "amd64"
+ [ "Unreliable server. Anything here may be lost at any time!" ]
& ipv4 "104.167.117.109"
& CloudAtCost.decruft
@@ -179,8 +184,8 @@ oyster = standardSystem "oyster.kitenet.net" Unstable "amd64"
& Ssh.listenPort (Port 80)
orca :: Host
-orca = standardSystem "orca.kitenet.net" Unstable "amd64"
- [ "Main git-annex build box." ]
+orca = host "orca.kitenet.net" $ props
+ & standardSystem Unstable "amd64" [ "Main git-annex build box." ]
& ipv4 "138.38.108.179"
& Apt.unattendedUpgrades
@@ -190,19 +195,19 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
- (System (Debian Unstable) "amd64") Nothing (Cron.Times "15 * * * *") "2h")
+ Unstable "amd64" Nothing (Cron.Times "15 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
- (System (Debian Unstable) "i386") Nothing (Cron.Times "30 * * * *") "2h")
+ Unstable "i386" Nothing (Cron.Times "30 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.stackAutoBuilder
- (System (Debian (Stable "jessie")) "i386") (Just "ancient") (Cron.Times "45 * * * *") "2h")
+ (Stable "jessie") "i386" (Just "ancient") (Cron.Times "45 * * * *") "2h")
& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
(Cron.Times "1 1 * * *") "3h")
honeybee :: Host
-honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
- [ "Arm git-annex build box." ]
+honeybee = host "honeybee.kitenet.net" $ props
+ & 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.
@@ -229,14 +234,14 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.armAutoBuilder
- (System (Debian 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 = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
- [ "Welcome to kite!" ]
+kite = host "kite.kitenet.net" $ props
+ & standardSystemUnhardened Testing "amd64" [ "Welcome to kite!" ]
& ipv4 "66.228.36.95"
& ipv6 "2600:3c03::f03c:91ff:fe73:b0d2"
& alias "kitenet.net"
@@ -351,10 +356,11 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
]
elephant :: Host
-elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
- [ "Storage, big data, and backups, omnomnom!"
- , "(Encrypt all data stored here.)"
- ]
+elephant = host "elephant.kitenet.net" $ props
+ & standardSystem Unstable "amd64"
+ [ "Storage, big data, and backups, omnomnom!"
+ , "(Encrypt all data stored here.)"
+ ]
& ipv4 "193.234.225.114"
& Ssh.hostKeys hostContext
[ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBANxXGWac0Yz58akI3UbLkphAa8VPDCGswTS0CT3D5xWyL9OeArISAi/OKRIvxA4c+9XnWtNXS7nYVFDJmzzg8v3ZMx543AxXK82kXCfvTOc/nAlVz9YKJAA+FmCloxpmOGrdiTx1k36FE+uQgorslGW/QTxnOcO03fDZej/ppJifAAAAFQCnenyJIw6iJB1+zuF/1TSLT8UAeQAAAIEA1WDrI8rKnxnh2rGaQ0nk+lOcVMLEr7AxParnZjgC4wt2mm/BmkF/feI1Fjft2z4D+V1W7MJHOqshliuproxhFUNGgX9fTbstFJf66p7h7OLAlwK8ZkpRk/uV3h5cIUPel6aCwjL5M2gN6/yq+gcCTXeHLq9OPyUTmlN77SBL71UAAACBAJJiCHWxPAGooe7Vv3W7EIBbsDyf7b2kDH3bsIlo+XFcKIN6jysBu4kn9utjFlrlPeHUDzGQHe+DmSqTUQQ0JPCRGcAcuJL8XUqhJi6A6ye51M9hVt51cJMXmERx9TjLOP/adkEuxpv3Fj20FxRUr1HOmvRvewSHrJ1GeA1bjbYL")
@@ -412,7 +418,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& Ssh.listenPort (Port 80)
beaver :: Host
-beaver = host "beaver.kitenet.net"
+beaver = host "beaver.kitenet.net" $ props
& ipv6 "2001:4830:1600:195::2"
& Apt.serviceInstalledRunning "aiccu"
& Apt.installed ["ssh"]
@@ -425,7 +431,7 @@ beaver = host "beaver.kitenet.net"
-- Branchable is not completely deployed with propellor yet.
pell :: Host
-pell = host "pell.branchable.com"
+pell = host "pell.branchable.com" $ props
& alias "branchable.com"
& ipv4 "66.228.46.55"
& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
@@ -449,10 +455,10 @@ pell = host "pell.branchable.com"
& Branchable.server hosts
iabak :: Host
-iabak = host "iabak.archiveteam.org"
+iabak = host "iabak.archiveteam.org" $ props
& ipv4 "124.6.40.227"
& Hostname.sane
- & os (System (Debian Testing) "amd64")
+ & osDebian Testing "amd64"
& Systemd.persistentJournal
& Cron.runPropellor (Cron.Times "30 * * * *")
& Apt.stdSourcesList `onChange` Apt.upgrade
@@ -466,7 +472,7 @@ iabak = host "iabak.archiveteam.org"
& Apt.installed ["vim", "screen", "tmux", "less", "emax-nox", "netcat"]
& User.hasSomePassword (User "root")
& propertyList "admin accounts"
- (map User.accountFor admins ++ map Sudo.enabledFor admins)
+ (toProps $ map User.accountFor admins ++ map Sudo.enabledFor admins)
& User.hasSomePassword (User "joey")
& GitHome.installedFor (User "joey")
& Ssh.authorizedKey (User "db48x") "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAAIAQDQ6urXcMDeyuFf4Ga7CuGezTShKnEMPHKJm7RQUtw3yXCPX5wnbvPS2+UFnHMzJvWOX5S5b/XpBpOusP0jLpxwOCEg4nA5b7uvWJ2VIChlMqopYMo+tDOYzK/Q74MZiNWi2hvf1tn3N9SnqOa7muBMKMENIX5KJdH8cJ/BaPqAP883gF8r2SwSZFvaB0xYCT/CIylC593n/+0+Lm07NUJIO8jil3n2SwXdVg6ib65FxZoO86M46wTghnB29GXqrzraOg+5DY1zzCWpIUtFwGr4DP0HqLVtmAkC7NI14l1M0oHE0UEbhoLx/a+mOIMD2DuzW3Rs3ZmHtGLj4PL/eBU8D33AqSeM0uR/0pEcoq6A3a8ixibj9MBYD2lMh+Doa2audxS1OLM//FeNccbm1zlvvde82PZtiO11P98uN+ja4A+CfgQU5s0z0wikc4gXNhWpgvz8DrOEJrjstwOoqkLg2PpIdHRw7dhpp3K1Pc+CGAptDwbKkxs4rzUgMbO9DKI7fPcXXgKHLLShMpmSA2vsQUMfuCp2cVrQJ+Vkbwo29N0Js5yU7L4NL4H854Nbk5uwWJCs/mjXtvTimN2va23HEecTpk44HDUjJ9NyevAfPcO9q1ZtgXFTQSMcdv1m10Fvmnaiy8biHnopL6MBo1VRITh5UFiJYfK4kpTTg2vSspii/FYkkYOAnnZtXZqMehP7OZjJ6HWJpsCVR2hxP3sKOoQu+kcADWa/4obdp+z7gY8iMMjd6kwuIWsNV8KsX+eVJ4UFpAi/L00ZjI2B9QLVCsOg6D1fT0698wEchwUROy5vZZJq0078BdAGnwC0WGLt+7OUgn3O2gUAkb9ffD0odbZSqq96NCelM6RaHA+AaIE4tjGL3lFkyOtb+IGPNACQ73/lmaRQd6Cgasq9cEo0g22Ew5NQi0CBuu1aLDk7ezu3SbU09eB9lcZ+8lFnl5K2eQFeVJStFJbJNfOvgKyOb7ePsrUFF5GJ2J/o1F60fRnG64HizZHxyFWkEOh+k3i8qO+whPa5MTQeYLYb6ysaTPrUwNRcSNNCcPEN8uYOh1dOFAtIYDcYA56BZ321yz0b5umj+pLsrFU+4wMjWxZi0inJzDS4dVegBVcRm0NP5u8VRosJQE9xdbt5K1I0khzhrEW1kowoTbhsZCaDHhL9LZo73Z1WIHvulvlF3RLZip5hhtQu3ZVkbdV5uts8AWaEWVnIu9z0GtQeeOuseZpT0u1/1xjVAOKIzuY3sB7FKOaipe8TDvmdiQf/ICySqqYaYhN6GOhiYccSleoX6yzhYuCvzTgAyWHIfW0t25ff1CM7Vn+Vo9cVplIer1pbwhZZy4QkROWTOE+3yuRlQ+o6op4hTGdAZhjKh9zkDW7rzqQECFrZrX/9mJhxYKjhpkk0X3dSipPt9SUHagc4igya+NgCygQkWBOQfr4uia0LcwDxy4Kchw7ZuypHuGVZkGhNHXS+9JdAHopnSqYwDMG/z1ys1vQihgER0b9g3TchvGF+nmHe2kbM1iuIYMNNlaZD1yGZ5qR7wr/8dw8r0NBEwzsUfak3BUPX7H6X0tGS96llwUxmvQD85WNNoef0uryuAtDEwWlfN1RmWysZDc57Rn4gZi0M5jXmQD23ZiYXYBcG849OeqNzlxONEFsForXO/29Ud4x/Hqa9tf+kJbqMRsaLFO+PXhHzgl6ZHLAljQDxrJ6keNnkqaYfqQ8wyRi1mKv4Ab57kde7mUsZhe7w93GaE9Lxfvu7d3pB+lXfI9NJCSITHreUP4JfmFW+p/eVg+r/1wbElNylGna4I4+qYObOUncGwFKYdFPdtU1XLDKXmywTEgbEh7iI9zX0xD3bPHQLMg+TTtXiU9dQm1x/0zRf9trwDsRDJCbG4/P4iQYkcVvYx2CCfi0JSHv8tWsLi3GJKJLXUxZyzfvY2lThPeYnnY/HFrPJCyJUN55QuRmfzbu8rHgWlcyOlVpKtz+7kn823kEQykiIYKIKrb0G6VBzuMtAk9XzJPv+Wu7suOGXHlVfCqPLk6RjHDm4kTYciW9VgxDts5Y+zwcAbrUeA4UuN/6KisWpivMrfDSIHUCeH/lHBtNkqKohdrUKJMEOx5X6r2dJbmoTFBDi5XtYu/5cBtiDMmupNB0S+pZ2JD5/RKtj6kgzTeE1q/OG4q/eq1O1rjf0vIS31luy27K/YHFIGE0D/CmuXE74Uyaxm27RnrKUxEBl84V70GaIF4F5On8pSThxxizigXTRTKiczc+A5Zi29mid+1EFeUAJOa/DuHJfpVNY4pYEmhPl/Bk66L8kzlbJz6Hg/LIiJIRcy3UKrbSxPFIDpXn33drBHgklMDlrIVDZDXF6cn0Ml71SabB4A3TM6TK+oWZoyvftPIhcWhVwAWQj7nFNAiMEl1z/29ovHrRooqQFozf7GDW8Mjiu7ChZP9zx2H8JB/AAEFuWMwGV4AHICYdS9lOl/v+cDhgsnXdeuKEuxHhYlRxuRxJk/f17Sm/5H85UIzlu85wi3q/DW2FTZnlw4iJLnL6FArUIMzuBOZyoEhh0SPR41Xc4kkucDhnENybTZSR/yDzb0P1B7qjZ4GqcSEFja/hm/LH1oKJzZg8MEqeUoKYCUdVv9ek4IUGUONtVs53V5SOwFWR/nVuDk2BENr7NadYYVtu6MjBwgjso7NuhoNxVwIEP3BW67OQ8bxfNBtJJQNJejAhgZiqJItI9ucAfjQ== db48x@anglachel"
@@ -489,14 +495,16 @@ iabak = host "iabak.archiveteam.org"
-- Simple web server, publishing the outside host's /var/www
webserver :: Systemd.Container
-webserver = standardStableContainer "webserver"
+webserver = Systemd.debContainer "webserver" $ props
+ & standardContainer (Stable "jessie")
& Systemd.bind "/var/www"
& Apache.installed
-- My own openid provider. Uses php, so containerized for security
-- and administrative sanity.
openidProvider :: Systemd.Container
-openidProvider = standardStableContainer "openid-provider"
+openidProvider = Systemd.debContainer "openid-provider" $ props
+ & standardContainer (Stable "jessie")
& alias hn
& OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081))
where
@@ -504,7 +512,8 @@ openidProvider = standardStableContainer "openid-provider"
-- Exhibit: kite's 90's website on port 1994.
ancientKitenet :: Systemd.Container
-ancientKitenet = standardStableContainer "ancient-kitenet"
+ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props
+ & standardContainer (Stable "jessie")
& alias hn
& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html"
(Just "remotes/origin/old-kitenet.net")
@@ -517,24 +526,27 @@ ancientKitenet = standardStableContainer "ancient-kitenet"
hn = "ancient.kitenet.net"
oldusenetShellBox :: Systemd.Container
-oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
+oldusenetShellBox = Systemd.debContainer "oldusenet-shellbox" $ props
+ & standardContainer (Stable "jessie")
& alias "shell.olduse.net"
& JoeySites.oldUseNetShellBox
kiteShellBox :: Systemd.Container
-kiteShellBox = standardStableContainer "kiteshellbox"
+kiteShellBox = Systemd.debContainer "kiteshellbox" $ props
+ & standardContainer (Stable "jessie")
& JoeySites.kiteShellBox
type Motd = [String]
-- This is my standard system setup.
-standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host
-standardSystem hn suite arch motd = standardSystemUnhardened hn suite arch motd
- & Ssh.noPasswords
-
-standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host
-standardSystemUnhardened hn suite arch motd = host hn
- & os (System (Debian suite) arch)
+standardSystem :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian)
+standardSystem suite arch motd =
+ standardSystemUnhardened suite arch motd
+ `before` Ssh.noPasswords
+
+standardSystemUnhardened :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian)
+standardSystemUnhardened suite arch motd = propertyList "standard system" $ props
+ & osDebian suite arch
& Hostname.sane
& Hostname.searchDomain
& File.hasContent "/etc/motd" ("":motd++[""])
@@ -555,32 +567,27 @@ standardSystemUnhardened hn suite arch motd = host hn
`onChange` Apt.autoRemove
-- This is my standard container setup, Featuring automatic upgrades.
-standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container
-standardContainer name suite arch =
- Systemd.container name system (Chroot.debootstrapped mempty)
- & Apt.stdSourcesList `onChange` Apt.upgrade
- & Apt.unattendedUpgrades
- & Apt.cacheCleaned
- where
- system = System (Debian suite) arch
-
-standardStableContainer :: Systemd.MachineName -> Systemd.Container
-standardStableContainer name = standardContainer name (Stable "jessie") "amd64"
+standardContainer :: DebianSuite -> Property (HasInfo + Debian)
+standardContainer suite = propertyList "standard container" $ props
+ & osDebian suite "amd64"
+ & Apt.stdSourcesList `onChange` Apt.upgrade
+ & Apt.unattendedUpgrades
+ & Apt.cacheCleaned
-myDnsSecondary :: Property HasInfo
+myDnsSecondary :: Property (HasInfo + DebianLike)
myDnsSecondary = propertyList "dns secondary for all my domains" $ props
& Dns.secondary hosts "kitenet.net"
& Dns.secondary hosts "joeyh.name"
& Dns.secondary hosts "ikiwiki.info"
& Dns.secondary hosts "olduse.net"
-branchableSecondary :: RevertableProperty HasInfo
+branchableSecondary :: RevertableProperty (HasInfo + DebianLike) DebianLike
branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"
-- Currently using kite (ns4) as primary with secondaries
-- elephant (ns3) and gandi.
-- kite handles all mail.
-myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain
(Dns.mkSOA "ns4.kitenet.net" 100) $
[ (RootDomain, NS $ AbsDomain "ns4.kitenet.net")
@@ -594,20 +601,20 @@ myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly No
monsters :: [Host] -- Systems I don't manage with propellor,
monsters = -- but do want to track their public keys etc.
- [ host "usw-s002.rsync.net"
+ [ host "usw-s002.rsync.net" $ props
& Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd"
- , host "github.com"
+ , host "github.com" $ props
& Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ=="
- , host "gitlab.com"
+ , host "gitlab.com" $ props
& Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY="
- , host "ns6.gandi.net"
+ , host "ns6.gandi.net" $ props
& ipv4 "217.70.177.40"
- , host "turtle.kitenet.net"
+ , host "turtle.kitenet.net" $ props
& ipv4 "67.223.19.96"
& ipv6 "2001:4978:f:2d9::2"
- , host "mouse.kitenet.net"
+ , host "mouse.kitenet.net" $ props
& ipv6 "2001:4830:1600:492::2"
- , host "animx"
+ , host "animx" $ props
& ipv4 "76.7.162.101"
& ipv4 "76.7.162.186"
]
diff --git a/propellor.cabal b/propellor.cabal
index dc322e88..06142155 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.17.0
+Version: 3.0.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -36,31 +36,39 @@ Description:
Executable propellor
Main-Is: wrapper.hs
- GHC-Options: -threaded -Wall -fno-warn-tabs
+ GHC-Options: -threaded -Wall -fno-warn-tabs -O0
+ Extensions: TypeOperators
Hs-Source-Dirs: src
- Build-Depends:
+ Build-Depends:
-- propellor needs to support the ghc shipped in Debian stable
base >= 4.5, base < 5,
MissingH, directory, filepath, IfElse, process, bytestring, hslogger,
unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,
- time, mtl, transformers, exceptions (>= 0.6), stm, text
+ time, mtl, transformers, exceptions (>= 0.6), stm, text,
+ concurrent-output
Executable propellor-config
Main-Is: config.hs
- GHC-Options: -threaded -Wall -fno-warn-tabs
+ GHC-Options: -threaded -Wall -fno-warn-tabs -O0
+ Extensions: TypeOperators
Hs-Source-Dirs: src
- Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
- IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers (>= 0.5), network, async, time, mtl, transformers,
- exceptions (>= 0.6), stm, text, unix
+ Build-Depends:
+ base >= 4.5, base < 5,
+ MissingH, directory, filepath, IfElse, process, bytestring, hslogger,
+ unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,
+ time, mtl, transformers, exceptions (>= 0.6), stm, text,
+ concurrent-output
Library
- GHC-Options: -Wall -fno-warn-tabs
+ GHC-Options: -Wall -fno-warn-tabs -O0
+ Extensions: TypeOperators
Hs-Source-Dirs: src
- Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
- IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers (>= 0.5), network, async, time, mtl, transformers,
- exceptions (>= 0.6), stm, text, unix
+ Build-Depends:
+ base >= 4.5, base < 5,
+ MissingH, directory, filepath, IfElse, process, bytestring, hslogger,
+ unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,
+ time, mtl, transformers, exceptions (>= 0.6), stm, text,
+ concurrent-output
Exposed-Modules:
Propellor
@@ -138,24 +146,29 @@ Library
Propellor.PropAccum
Propellor.Utilities
Propellor.CmdLine
+ Propellor.Container
Propellor.Info
Propellor.Message
Propellor.Debug
Propellor.PrivData
Propellor.Engine
+ Propellor.EnsureProperty
Propellor.Exception
Propellor.Types
+ Propellor.Types.Core
Propellor.Types.Chroot
+ Propellor.Types.CmdLine
Propellor.Types.Container
Propellor.Types.Docker
Propellor.Types.Dns
Propellor.Types.Empty
Propellor.Types.Info
+ Propellor.Types.MetaTypes
Propellor.Types.OS
Propellor.Types.PrivData
Propellor.Types.Result
Propellor.Types.ResultCheck
- Propellor.Types.CmdLine
+ Propellor.Types.Singletons
Propellor.Types.ZFS
Other-Modules:
Propellor.Bootstrap
@@ -193,9 +206,6 @@ Library
Utility.ThreadScheduler
Utility.Tmp
Utility.UserInfo
- System.Console.Concurrent
- System.Console.Concurrent.Internal
- System.Process.Concurrent
source-repository head
type: git
diff --git a/src/Propellor.hs b/src/Propellor.hs
index 9c5a85a9..a371ea44 100644
--- a/src/Propellor.hs
+++ b/src/Propellor.hs
@@ -14,13 +14,14 @@
-- > main = defaultMain hosts
-- >
-- > hosts :: [Host]
--- > hosts =
--- > [ host "example.com"
+-- > hosts = [example]
+-- >
+-- > example :: Host
+-- > example = host "example.com" $ props
-- > & Apt.installed ["mydaemon"]
-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1"
-- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
-- > ! Apt.installed ["unwantedpackage"]
--- > ]
--
-- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor:
@@ -38,7 +39,6 @@ module Propellor (
, (&)
, (!)
-- * Propertries
- , describe
-- | Properties are often combined together in your propellor
-- configuration. For example:
--
@@ -47,6 +47,7 @@ module Propellor (
, requires
, before
, onChange
+ , describe
, module Propellor.Property
-- | Everything you need to build your own properties,
-- and useful property combinators
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 69eee66c..3b4c3106 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -90,6 +90,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "libghc-exceptions-dev"
, "libghc-stm-dev"
, "libghc-text-dev"
+ , "libghc-concurrent-output-dev"
, "make"
]
fbsddeps =
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
new file mode 100644
index 00000000..c4d6f864
--- /dev/null
+++ b/src/Propellor/Container.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE DataKinds, TypeFamilies #-}
+
+module Propellor.Container where
+
+import Propellor.Types
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
+import Propellor.Types.Info
+import Propellor.Info
+import Propellor.PrivData
+import Propellor.PropAccum
+
+class IsContainer c where
+ containerProperties :: c -> [ChildProperty]
+ containerInfo :: c -> Info
+ setContainerProperties :: c -> [ChildProperty] -> c
+
+instance IsContainer Host where
+ containerProperties = hostProperties
+ containerInfo = hostInfo
+ setContainerProperties h ps = host (hostName h) (Props ps)
+
+-- | Note that the metatype of a container's properties is not retained,
+-- so this defaults to UnixLike. So, using this with setContainerProps can
+-- add properties to a container that conflict with properties already in it.
+-- Use caution when using this; only add properties that do not have
+-- restricted targets.
+containerProps :: IsContainer c => c -> Props UnixLike
+containerProps = Props . containerProperties
+
+setContainerProps :: IsContainer c => c -> Props metatypes -> c
+setContainerProps c (Props ps) = setContainerProperties c ps
+
+-- | Adjust the provided Property, adding to its
+-- propertyChidren the properties of the provided container.
+--
+-- The Info of the propertyChildren is adjusted to only include
+-- info that should be propagated out to the Property.
+--
+-- Any PrivInfo that uses HostContext is adjusted to use the name
+-- of the container as its context.
+propagateContainer
+ ::
+ -- Since the children being added probably have info,
+ -- require the Property's metatypes to have info.
+ ( IncludesInfo metatypes ~ 'True
+ , IsContainer c
+ )
+ => String
+ -> c
+ -> Property metatypes
+ -> Property metatypes
+propagateContainer containername c prop = prop
+ `addChildren` map convert (containerProperties c)
+ where
+ convert p =
+ let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
+ n' = n
+ `setInfoProperty` mapInfo (forceHostContext containername)
+ (propagatableInfo (getInfo p))
+ `addChildren` map convert (getChildren p)
+ in toChildProperty n'
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 2e914d67..f0035c40 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -1,11 +1,10 @@
{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
module Propellor.Engine (
mainProperties,
runPropellor,
- ensureProperty,
- ensureProperties,
+ ensureChildProperties,
fromHost,
fromHost',
onlyProcess,
@@ -23,24 +22,26 @@ import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Core
import Propellor.Message
import Propellor.Exception
import Propellor.Info
-import Propellor.Property
import Utility.Exception
-- | Gets the Properties of a Host, and ensures them all,
-- with nice display of what's being done.
mainProperties :: Host -> IO ()
mainProperties host = do
- ret <- runPropellor host $
- ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
+ ret <- runPropellor host $ ensureChildProperties [toChildProperty overall]
messagesDone
case ret of
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
where
- ps = map ignoreInfo $ hostProperties host
+ overall :: Property (MetaTypes '[])
+ overall = property "overall" $
+ ensureChildProperties (hostProperties host)
-- | Runs a Propellor action with the specified host.
--
@@ -58,14 +59,14 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
(ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host ()
return ret
--- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property NoInfo] -> Propellor Result
-ensureProperties ps = ensure ps NoChange
+-- | Ensures the child properties, with a display of each as it runs.
+ensureChildProperties :: [ChildProperty] -> Propellor Result
+ensureChildProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
ensure (p:ls) rs = do
hn <- asks hostName
- r <- actionMessageOn hn (propertyDesc p) (ensureProperty p)
+ r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)
ensure ls (r <> rs)
-- | Lifts an action into the context of a different host.
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
new file mode 100644
index 00000000..ce01d436
--- /dev/null
+++ b/src/Propellor/EnsureProperty.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Propellor.EnsureProperty
+ ( ensureProperty
+ , property'
+ , OuterMetaTypesWitness(..)
+ ) where
+
+import Propellor.Types
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
+import Propellor.Exception
+
+import Data.Monoid
+import Prelude
+
+-- | For when code running in the Propellor monad needs to ensure a
+-- Property.
+--
+-- Use `property'` to get the `OuterMetaTypesWithness`. For example:
+--
+-- > foo = Property Debian
+-- > foo = property' $ \w -> do
+-- > ensureProperty w (aptInstall "foo")
+--
+-- The type checker will prevent using ensureProperty with a property
+-- that does not support the target OSes needed by the OuterMetaTypesWitness.
+-- In the example above, aptInstall must support Debian, since foo
+-- is supposed to support Debian.
+--
+-- The type checker will also prevent using ensureProperty with a property
+-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated
+-- with the property to be lost.
+ensureProperty
+ ::
+ ( Cannot_ensureProperty_WithInfo inner ~ 'True
+ , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine
+ )
+ => OuterMetaTypesWitness outer
+ -> Property (MetaTypes inner)
+ -> Propellor Result
+ensureProperty _ = catchPropellor . getSatisfy
+
+-- The name of this was chosen to make type errors a more understandable.
+type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool
+type instance Cannot_ensureProperty_WithInfo '[] = 'True
+type instance Cannot_ensureProperty_WithInfo (t ': ts) =
+ Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
+
+-- | Constructs a property, like `property`, but provides its
+-- `OuterMetaTypesWitness`.
+property'
+ :: SingI metatypes
+ => Desc
+ -> (OuterMetaTypesWitness metatypes -> Propellor Result)
+ -> Property (MetaTypes metatypes)
+property' d a =
+ let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty
+ in p
+
+-- | Used to provide the metatypes of a Property to calls to
+-- 'ensureProperty` within it.
+newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes)
+
+outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l
+outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 7eb7d4a8..b87369c3 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -1,9 +1,30 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Info where
+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}
+
+module Propellor.Info (
+ osDebian,
+ osBuntish,
+ osFreeBSD,
+ setInfoProperty,
+ addInfoProperty,
+ pureInfoProperty,
+ pureInfoProperty',
+ askInfo,
+ getOS,
+ ipv4,
+ ipv6,
+ alias,
+ addDNS,
+ hostMap,
+ aliasMap,
+ findHost,
+ findHostNoAlias,
+ getAddresses,
+ hostAddresses,
+) where
import Propellor.Types
import Propellor.Types.Info
+import Propellor.Types.MetaTypes
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
@@ -13,21 +34,67 @@ import Data.Monoid
import Control.Applicative
import Prelude
-pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo
-pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)
-
-pureInfoProperty' :: Desc -> Info -> Property HasInfo
-pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+-- | Adds info to a Property.
+--
+-- The new Property will include HasInfo in its metatypes.
+setInfoProperty
+ :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
+ => Property metatypes
+ -> Info
+ -> Property (MetaTypes metatypes')
+setInfoProperty (Property _ d a oldi c) newi =
+ Property sing d a (oldi <> newi) c
+
+-- | Adds more info to a Property that already HasInfo.
+addInfoProperty
+ :: (IncludesInfo metatypes ~ 'True)
+ => Property metatypes
+ -> Info
+ -> Property metatypes
+addInfoProperty (Property t d a oldi c) newi =
+ Property t d a (oldi <> newi) c
+
+-- | Makes a property that does nothing but set some `Info`.
+pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
+pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)
+
+pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
+pureInfoProperty' desc i = setInfoProperty p i
+ where
+ p :: Property UnixLike
+ p = property ("has " ++ desc) (return NoChange)
-- | Gets a value from the host's Info.
askInfo :: (IsInfo v) => Propellor v
-askInfo = asks (getInfo . hostInfo)
+askInfo = asks (fromInfo . hostInfo)
+
+-- | Specifies that a host's operating system is Debian,
+-- and further indicates the suite and architecture.
+--
+-- This provides info for other Properties, so they can act
+-- conditionally on the details of the OS.
+--
+-- It also lets the type checker know that all the properties of the
+-- host must support Debian.
+--
+-- > & osDebian (Stable "jessie") "amd64"
+osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
+osDebian suite arch = tightenTargets $ os (System (Debian suite) arch)
--- | Specifies the operating system of a host.
+-- | Specifies that a host's operating system is a well-known Debian
+-- derivative founded by a space tourist.
--
--- This only provides info for other Properties, so they can act
--- conditionally on the os.
-os :: System -> Property HasInfo
+-- (The actual name of this distribution is not used in Propellor per
+-- <http://joeyh.name/blog/entry/trademark_nonsense/>)
+osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)
+osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)
+
+-- | Specifies that a host's operating system is FreeBSD
+-- and further indicates the release and architecture.
+osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
+osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)
+
+os :: System -> Property (HasInfo + UnixLike)
os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)
-- Gets the operating system of a host, if it has been specified.
@@ -43,11 +110,11 @@ getOS = fromInfoVal <$> askInfo
-- When propellor --spin is used to deploy a host, it checks
-- if the host's IP Property matches the DNS. If the DNS is missing or
-- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property HasInfo
+ipv4 :: String -> Property (HasInfo + UnixLike)
ipv4 = addDNS . Address . IPv4
-- | Indicate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property HasInfo
+ipv6 :: String -> Property (HasInfo + UnixLike)
ipv6 = addDNS . Address . IPv6
-- | Indicates another name for the host in the DNS.
@@ -56,14 +123,14 @@ ipv6 = addDNS . Address . IPv6
-- to use their address, rather than using a CNAME. This avoids various
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property HasInfo
+alias :: Domain -> Property (HasInfo + UnixLike)
alias d = pureInfoProperty' ("alias " ++ d) $ mempty
`addInfo` toAliasesInfo [d]
-- A CNAME is added here, but the DNS setup code converts it to an
-- IP address when that makes sense.
`addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)
-addDNS :: Record -> Property HasInfo
+addDNS :: Record -> Property (HasInfo + UnixLike)
addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))
where
rdesc (CNAME d) = unwords ["alias", ddesc d]
@@ -86,7 +153,7 @@ hostMap l = M.fromList $ zip (map hostName l) l
aliasMap :: [Host] -> M.Map HostName Host
aliasMap = M.fromList . concat .
- map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)
+ map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)
@@ -98,10 +165,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
findAlias l hn = M.lookup hn (aliasMap l)
getAddresses :: Info -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo
+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo
hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)
-
-addHostInfo ::IsInfo v => Host -> v -> Host
-addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v }
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index bc09f0c6..d3bb3a6d 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -2,6 +2,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
module Propellor.PrivData (
withPrivData,
@@ -40,6 +42,7 @@ import Prelude
import Propellor.Types
import Propellor.Types.PrivData
+import Propellor.Types.MetaTypes
import Propellor.Types.Info
import Propellor.Message
import Propellor.Info
@@ -75,29 +78,41 @@ import Utility.FileSystemEncoding
-- being used, which is necessary to ensure that the privdata is sent to
-- the remote host by propellor.
withPrivData
- :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
+ ::
+ ( IsContext c
+ , IsPrivDataSource s
+ , IncludesInfo metatypes ~ 'True
+ )
=> s
-> c
- -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
- -> Property HasInfo
+ -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property metatypes)
+ -> Property metatypes
withPrivData s = withPrivData' snd [s]
-- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData
- :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
+ ::
+ ( IsContext c
+ , IsPrivDataSource s
+ , IncludesInfo metatypes ~ 'True
+ )
=> [s]
-> c
- -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
- -> Property HasInfo
+ -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property metatypes)
+ -> Property metatypes
withSomePrivData = withPrivData' id
withPrivData'
- :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
+ ::
+ ( IsContext c
+ , IsPrivDataSource s
+ , IncludesInfo metatypes ~ 'True
+ )
=> ((PrivDataField, PrivData) -> v)
-> [s]
-> c
- -> (((v -> Propellor Result) -> Propellor Result) -> Property i)
- -> Property HasInfo
+ -> (((v -> Propellor Result) -> Propellor Result) -> Property metatypes)
+ -> Property metatypes
withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
maybe missing (a . feed) =<< getM get fieldlist
where
@@ -112,11 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
"Fix this by running:" :
showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist)
return FailedChange
- addinfo p = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p `addInfo` privset)
- (propertyChildren p)
+ addinfo p = p `addInfoProperty` (toInfo privset)
privset = PrivInfo $ S.fromList $
map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
@@ -132,7 +143,7 @@ showSet = concatMap go
, Just ""
]
-addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
+addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property (HasInfo + UnixLike)
addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))
{- Gets the requested field's value, in the specified context if it's
@@ -150,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
- fromPrivInfo $ getInfo $ hostInfo host
+ fromPrivInfo $ fromInfo $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
getPrivData field context m = do
@@ -234,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h
mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a
mkPrivDataMap host mkv = M.fromList $
map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d))
- (S.toList $ fromPrivInfo $ getInfo $ hostInfo host)
+ (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host)
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
setPrivDataTo field context (PrivData value) = do
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 85a30af5..d9fa8ec7 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -1,88 +1,86 @@
-{-# LANGUAGE PackageImports, FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds #-}
module Propellor.PropAccum
( host
- , PropAccum(..)
+ , Props(..)
+ , props
, (&)
, (&^)
, (!)
- , propagateContainer
) where
-import Data.Monoid
-
import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Core
import Propellor.Property
-import Propellor.Types.Info
-import Propellor.PrivData
--- | Starts accumulating the properties of a Host.
+import Data.Monoid
+import Prelude
+
+-- | Defines a host and its properties.
--
--- > host "example.com"
+-- > host "example.com" $ props
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
-host :: HostName -> Host
-host hn = Host hn [] mempty
+host :: HostName -> Props metatypes -> Host
+host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
--- | Something that can accumulate properties.
-class PropAccum h where
- -- | Adds a property.
- addProp :: IsProp p => h -> p -> h
+-- | Start accumulating a list of properties.
+--
+-- Properties can be added to it using `(&)` etc.
+props :: Props UnixLike
+props = Props []
- -- | Like addProp, but adds the property at the front of the list.
- addPropFront :: IsProp p => h -> p -> h
+infixl 1 &
+infixl 1 &^
+infixl 1 !
- getProperties :: h -> [Property HasInfo]
+type family GetMetaTypes x
+type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t
+type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t
--- | Adds a property to a `Host` or other `PropAccum`
+-- | Adds a property to a Props.
--
-- Can add Properties and RevertableProperties
-(&) :: (PropAccum h, IsProp p) => h -> p -> h
-(&) = addProp
+(&)
+ ::
+ ( IsProp p
+ , MetaTypes y ~ GetMetaTypes p
+ , CheckCombinable x y ~ 'CanCombine
+ )
+ => Props (MetaTypes x)
+ -> p
+ -> Props (MetaTypes (Combine x y))
+Props c & p = Props (c ++ [toChildProperty p])
-- | Adds a property before any other properties.
-(&^) :: (PropAccum h, IsProp p) => h -> p -> h
-(&^) = addPropFront
+(&^)
+ ::
+ ( IsProp p
+ , MetaTypes y ~ GetMetaTypes p
+ , CheckCombinable x y ~ 'CanCombine
+ )
+ => Props (MetaTypes x)
+ -> p
+ -> Props (MetaTypes (Combine x y))
+Props c &^ p = Props (toChildProperty p : c)
-- | Adds a property in reverted form.
-(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h
-h ! p = h & revert p
+(!)
+ :: (CheckCombinable x z ~ 'CanCombine)
+ => Props (MetaTypes x)
+ -> RevertableProperty (MetaTypes y) (MetaTypes z)
+ -> Props (MetaTypes (Combine x z))
+Props c ! p = Props (c ++ [toChildProperty (revert p)])
-infixl 1 &
-infixl 1 &^
-infixl 1 !
-
-instance PropAccum Host where
- (Host hn ps is) `addProp` p = Host hn (ps ++ [toProp p])
- (is <> getInfoRecursive p)
- (Host hn ps is) `addPropFront` p = Host hn (toProp p : ps)
- (getInfoRecursive p <> is)
- getProperties = hostProperties
-
--- | Adjust the provided Property, adding to its
--- propertyChidren the properties of the provided container.
---
--- The Info of the propertyChildren is adjusted to only include
--- info that should be propagated out to the Property.
---
--- Any PrivInfo that uses HostContext is adjusted to use the name
--- of the container as its context.
-propagateContainer
- :: (PropAccum container)
- => String
- -> container
- -> Property HasInfo
- -> Property HasInfo
-propagateContainer containername c prop = infoProperty
- (propertyDesc prop)
- (propertySatisfy prop)
- (propertyInfo prop)
- (propertyChildren prop ++ hostprops)
- where
- hostprops = map go $ getProperties c
- go p =
- let i = mapInfo (forceHostContext containername)
- (propagatableInfo (propertyInfo p))
- cs = map go (propertyChildren p)
- in infoProperty (propertyDesc p) (propertySatisfy p) i cs
+-- addPropsHost :: Host -> [Prop] -> Host
+-- addPropsHost (Host hn ps i) p = Host hn ps' i'
+-- where
+-- ps' = ps ++ [toChildProperty p]
+-- i' = i <> getInfoRecursive p
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index b6b8dc0d..55c39ee2 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
module Propellor.Property (
-- * Property combinators
@@ -18,9 +22,13 @@ module Propellor.Property (
-- * Constructing properties
, Propellor
, property
+ , property'
+ , OuterMetaTypesWitness
, ensureProperty
+ , pickOS
, withOS
, unsupportedOS
+ , unsupportedOS'
, makeChange
, noChange
, doNothing
@@ -44,22 +52,21 @@ import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
import qualified Data.Hash.MD5 as MD5
+import Data.List
import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.Core
import Propellor.Types.ResultCheck
+import Propellor.Types.MetaTypes
+import Propellor.Types.Singletons
import Propellor.Info
-import Propellor.Exception
+import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Misc
--- | Constructs a Property, from a description and an action to run to
--- ensure the Property is met.
-property :: Desc -> Propellor Result -> Property NoInfo
-property d s = simpleProperty d s mempty
-
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
@@ -164,13 +171,6 @@ describe = setDesc
(==>) = flip describe
infixl 1 ==>
--- | For when code running in the Propellor monad needs to ensure a
--- Property.
---
--- This can only be used on a Property that has NoInfo.
-ensureProperty :: Property NoInfo -> Propellor Result
-ensureProperty = catchPropellor . propertySatisfy
-
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
@@ -249,28 +249,96 @@ isNewerThan x y = do
where
mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
--- | Makes a property that is satisfied differently depending on the host's
--- operating system.
+-- | Picks one of the two input properties to use,
+-- depending on the targeted OS.
+--
+-- If both input properties support the targeted OS, then the
+-- first will be used.
--
--- Note that the operating system may not be declared for all hosts.
+-- The resulting property will use the description of the first property
+-- no matter which property is used in the end. So, it's often a good
+-- idea to change the description to something clearer.
--
--- > myproperty = withOS "foo installed" $ \o -> case o of
--- > (Just (System (Debian suite) arch)) -> ...
--- > (Just (System (Buntish release) arch)) -> ...
--- > Nothing -> unsupportedOS
-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
-withOS desc a = property desc $ a =<< getOS
+-- For example:
+--
+-- > upgraded :: UnixLike
+-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
+-- > `describe` "OS upgraded"
+--
+-- If neither input property supports the targeted OS, calls
+-- `unsupportedOS`. Using the example above on a Fedora system would
+-- fail that way.
+pickOS
+ ::
+ ( SingKind ('KProxy :: KProxy ka)
+ , SingKind ('KProxy :: KProxy kb)
+ , DemoteRep ('KProxy :: KProxy ka) ~ [MetaType]
+ , DemoteRep ('KProxy :: KProxy kb) ~ [MetaType]
+ , SingI c
+ -- Would be nice to have this constraint, but
+ -- union will not generate metatypes lists with the same
+ -- order of OS's as is used everywhere else. So,
+ -- would need a type-level sort.
+ --, Union a b ~ c
+ )
+ => Property (MetaTypes (a :: ka))
+ -> Property (MetaTypes (b :: kb))
+ -> Property (MetaTypes c)
+pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
+ where
+ -- This use of getSatisfy is safe, because both a and b
+ -- are added as children, so their info will propigate.
+ c = withOS (getDesc a) $ \_ o ->
+ if matching o a
+ then getSatisfy a
+ else if matching o b
+ then getSatisfy b
+ else unsupportedOS'
+ matching Nothing _ = False
+ matching (Just o) p =
+ Targeting (systemToTargetOS o)
+ `elem`
+ fromSing (proptype p)
+ proptype (Property t _ _ _ _) = t
+
+-- | Makes a property that is satisfied differently depending on specifics
+-- of the host's operating system.
+--
+-- > myproperty :: Property Debian
+-- > myproperty = withOS "foo installed" $ \w o -> case o of
+-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
+-- > (Just (System (Debian suite) arch)) -> ensureProperty w ...
+-- > _ -> unsupportedOS'
+--
+-- Note that the operating system specifics may not be declared for all hosts,
+-- which is where Nothing comes in.
+withOS
+ :: (SingI metatypes)
+ => Desc
+ -> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)
+ -> Property (MetaTypes metatypes)
+withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
+ where
+ -- Using this dummy value allows ensureProperty to be used
+ -- even though the inner property probably doesn't target everything
+ -- that the outer withOS property targets.
+ dummyoutermetatypes :: OuterMetaTypesWitness ('[])
+ dummyoutermetatypes = OuterMetaTypesWitness sing
+
+-- | A property that always fails with an unsupported OS error.
+unsupportedOS :: Property UnixLike
+unsupportedOS = property "unsupportedOS" unsupportedOS'
-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
-unsupportedOS :: Propellor a
-unsupportedOS = go =<< getOS
- where
- go Nothing = error "Unknown host OS is not supported by this property."
- go (Just o) = error $ "This property is not implemented for " ++ show o
+unsupportedOS' :: Propellor Result
+unsupportedOS' = go =<< getOS
+ where
+ go Nothing = error "Unknown host OS is not supported by this property."
+ go (Just o) = error $ "This property is not implemented for " ++ show o
-- | Undoes the effect of a RevertableProperty.
-revert :: RevertableProperty i -> RevertableProperty i
+revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
makeChange :: IO () -> Propellor Result
@@ -279,7 +347,7 @@ makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
-doNothing :: Property NoInfo
+doNothing :: SingI t => Property (MetaTypes t)
doNothing = property "noop property" noChange
-- | Registers an action that should be run at the very end, after
diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs
index 47841a7b..1b28759c 100644
--- a/src/Propellor/Property/Aiccu.hs
+++ b/src/Propellor/Property/Aiccu.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
-- | Maintainer: Jelmer Vernooij <jelmer@samba.org>
module Propellor.Property.Aiccu (
@@ -14,10 +16,10 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.File as File
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["aiccu"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "aiccu"
confPath :: FilePath
@@ -41,12 +43,12 @@ config u t p =
-- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId
-- and sixx.net UserName.
-hasConfig :: TunnelId -> UserName -> Property HasInfo
-hasConfig t u = prop `onChange` restarted
+hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike)
+hasConfig t u = prop `onChange` restarted
where
+ prop :: Property (HasInfo + UnixLike)
prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $
- property "aiccu configured" . writeConfig
- writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result
- writeConfig getpassword = getpassword $ ensureProperty . go
+ property' "aiccu configured" . writeConfig
+ writeConfig getpassword w = getpassword $ ensureProperty w . go
go (Password u', p) = confPath `File.hasContentProtected` config u' t p
go (f, _) = error $ "Unexpected type of privdata: " ++ show f
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index e107cb9f..f321143f 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -6,50 +6,50 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.LetsEncrypt as LetsEncrypt
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["apache2"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "apache2"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "apache2"
type ConfigLine = String
type ConfigFile = [ConfigLine]
-siteEnabled :: Domain -> ConfigFile -> RevertableProperty NoInfo
+siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike
siteEnabled domain cf = siteEnabled' domain cf <!> siteDisabled domain
-siteEnabled' :: Domain -> ConfigFile -> Property NoInfo
-siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain)
- [ siteAvailable domain cf
+siteEnabled' :: Domain -> ConfigFile -> Property DebianLike
+siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props
+ & siteAvailable domain cf
`requires` installed
`onChange` reloaded
- , check (not <$> isenabled)
+ & check (not <$> isenabled)
(cmdProperty "a2ensite" ["--quiet", domain])
`requires` installed
`onChange` reloaded
- ]
where
isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain]
-siteDisabled :: Domain -> Property NoInfo
+siteDisabled :: Domain -> Property DebianLike
siteDisabled domain = combineProperties
("apache site disabled " ++ domain)
- (map File.notPresent (siteCfg domain))
+ (toProps $ map File.notPresent (siteCfg domain))
`onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange)
`requires` installed
`onChange` reloaded
-siteAvailable :: Domain -> ConfigFile -> Property NoInfo
+siteAvailable :: Domain -> ConfigFile -> Property DebianLike
siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $
- map (`File.hasContent` (comment:cf)) (siteCfg domain)
+ toProps $ map tightenTargets $
+ map (`File.hasContent` (comment:cf)) (siteCfg domain)
where
comment = "# deployed with propellor, do not modify"
-modEnabled :: String -> RevertableProperty NoInfo
+modEnabled :: String -> RevertableProperty DebianLike DebianLike
modEnabled modname = enable <!> disable
where
enable = check (not <$> isenabled)
@@ -68,7 +68,7 @@ modEnabled modname = enable <!> disable
--
-- Note that ports are also specified inside a site's config file,
-- so that also needs to be changed.
-listenPorts :: [Port] -> Property NoInfo
+listenPorts :: [Port] -> Property DebianLike
listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps
`onChange` restarted
where
@@ -89,7 +89,7 @@ siteCfg domain =
--
-- This was off by default in apache 2.2.22. Newver versions enable
-- it by default. This property uses the filename used by the old version.
-multiSSL :: Property NoInfo
+multiSSL :: Property DebianLike
multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $
"/etc/apache2/conf.d/ssl" `File.hasContent`
[ "NameVirtualHost *:443"
@@ -129,11 +129,11 @@ type WebRoot = FilePath
-- | A basic virtual host, publishing a directory, and logging to
-- the combined apache log file. Not https capable.
-virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo
+virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike
virtualHost domain port docroot = virtualHost' domain port docroot []
-- | Like `virtualHost` but with additional config lines added.
-virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo
+virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
virtualHost' domain port docroot addedcfg = siteEnabled domain $
[ "<VirtualHost *:" ++ fromPort port ++ ">"
, "ServerName " ++ domain ++ ":" ++ fromPort port
@@ -159,11 +159,11 @@ virtualHost' domain port docroot addedcfg = siteEnabled domain $
--
-- Note that reverting this property does not remove the certificate from
-- letsencrypt's cert store.
-httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty NoInfo
+httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike
httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos []
-- | Like `httpsVirtualHost` but with additional config lines added.
-httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty NoInfo
+httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
where
setup = setuphttp
@@ -185,13 +185,13 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
, "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]"
]
setuphttps = LetsEncrypt.letsEncrypt letos domain docroot
- `onChange` combineProperties (domain ++ " ssl cert installed")
- [ File.dirExists (takeDirectory cf)
- , File.hasContent cf sslvhost
- `onChange` reloaded
- -- always reload since the cert has changed
- , reloaded
- ]
+ `onChange` postsetuphttps
+ postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props
+ & File.dirExists (takeDirectory cf)
+ & File.hasContent cf sslvhost
+ `onChange` reloaded
+ -- always reload since the cert has changed
+ & reloaded
where
cf = sslconffile "letsencrypt"
sslvhost = vhost (Port 443)
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 7301a6ae..1a15f72c 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -75,42 +75,41 @@ securityUpdates suite
in [l, srcLine l]
| otherwise = []
--- | Makes sources.list have a standard content using the mirror CDN,
+-- | Makes sources.list have a standard content using the Debian mirror CDN,
-- with the Debian suite configured by the os.
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
-stdSourcesList :: Property NoInfo
-stdSourcesList = withOS "standard sources.list" $ \o ->
- case o of
- (Just (System (Debian suite) _)) ->
- ensureProperty $ stdSourcesListFor suite
- _ -> error "os is not declared to be Debian"
-
-stdSourcesListFor :: DebianSuite -> Property NoInfo
+stdSourcesList :: Property Debian
+stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
+ (Just (System (Debian suite) _)) ->
+ ensureProperty w $ stdSourcesListFor suite
+ _ -> unsupportedOS'
+
+stdSourcesListFor :: DebianSuite -> Property Debian
stdSourcesListFor suite = stdSourcesList' suite []
-- | Adds additional sources.list generators.
--
-- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/>
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
-stdSourcesList' suite more = setSourcesList
+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian
+stdSourcesList' suite more = tightenTargets $ setSourcesList
(concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite)
where
generators = [debCdn, kernelOrg, securityUpdates] ++ more
-setSourcesList :: [Line] -> Property NoInfo
+setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-setSourcesListD :: [Line] -> FilePath -> Property NoInfo
+setSourcesListD :: [Line] -> FilePath -> Property DebianLike
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
-runApt :: [String] -> UncheckedProperty NoInfo
-runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv
+runApt :: [String] -> UncheckedProperty DebianLike
+runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
@@ -118,66 +117,66 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none")
]
-update :: Property NoInfo
+update :: Property DebianLike
update = runApt ["update"]
`assume` MadeChange
`describe` "apt update"
-- | Have apt upgrade packages, adding new packages and removing old as
-- necessary.
-upgrade :: Property NoInfo
+upgrade :: Property DebianLike
upgrade = upgrade' "dist-upgrade"
-upgrade' :: String -> Property NoInfo
-upgrade' p = combineProperties ("apt " ++ p)
- [ pendingConfigured
- , runApt ["-y", p]
+upgrade' :: String -> Property DebianLike
+upgrade' p = combineProperties ("apt " ++ p) $ props
+ & pendingConfigured
+ & runApt ["-y", p]
`assume` MadeChange
- ]
-- | Have apt upgrade packages, but never add new packages or remove
-- old packages. Not suitable for upgrading acrocess major versions
-- of the distribution.
-safeUpgrade :: Property NoInfo
+safeUpgrade :: Property DebianLike
safeUpgrade = upgrade' "upgrade"
-- | Have dpkg try to configure any packages that are not fully configured.
-pendingConfigured :: Property NoInfo
-pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
- `assume` MadeChange
- `describe` "dpkg configured pending"
+pendingConfigured :: Property DebianLike
+pendingConfigured = tightenTargets $
+ cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
+ `assume` MadeChange
+ `describe` "dpkg configured pending"
type Package = String
-installed :: [Package] -> Property NoInfo
+installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
-installed' :: [String] -> [Package] -> Property NoInfo
+installed' :: [String] -> [Package] -> Property DebianLike
installed' params ps = robustly $ check (isInstallable ps) go
`describe` unwords ("apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
-installedBackport :: [Package] -> Property NoInfo
-installedBackport ps = withOS desc $ \o -> case o of
+installedBackport :: [Package] -> Property Debian
+installedBackport ps = withOS desc $ \w o -> case o of
(Just (System (Debian suite) _)) -> case backportSuite suite of
- Nothing -> unsupportedOS
- Just bs -> ensureProperty $
+ Nothing -> unsupportedOS'
+ Just bs -> ensureProperty w $
runApt (["install", "-t", bs, "-y"] ++ ps)
`changesFile` dpkgStatus
- _ -> unsupportedOS
+ _ -> unsupportedOS'
where
desc = unwords ("apt installed backport":ps)
-- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property NoInfo
+installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
-removed :: [Package] -> Property NoInfo
+removed :: [Package] -> Property DebianLike
removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
`describe` unwords ("apt removed":ps)
-buildDep :: [Package] -> Property NoInfo
+buildDep :: [Package] -> Property DebianLike
buildDep ps = robustly $ go
`changesFile` dpkgStatus
`describe` unwords ("apt build-dep":ps)
@@ -187,7 +186,7 @@ buildDep ps = robustly $ go
-- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property NoInfo
+buildDepIn :: FilePath -> Property DebianLike
buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
`changesFile` dpkgStatus
`requires` installedMin ["devscripts", "equivs"]
@@ -196,14 +195,8 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
-robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
-robustly p = adjustPropertySatisfy p $ \satisfy -> do
- r <- satisfy
- if r == FailedChange
- -- Safe to use ignoreInfo because we're re-running
- -- the same property.
- then ensureProperty $ ignoreInfo $ p `requires` update
- else return r
+robustly :: Property DebianLike -> Property DebianLike
+robustly p = p `fallback` (update `before` p)
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
@@ -228,13 +221,13 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
-autoRemove :: Property NoInfo
+autoRemove :: Property DebianLike
autoRemove = runApt ["-y", "autoremove"]
`changesFile` dpkgStatus
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades :: RevertableProperty NoInfo
+unattendedUpgrades :: RevertableProperty DebianLike DebianLike
unattendedUpgrades = enable <!> disable
where
enable = setup True
@@ -253,11 +246,12 @@ unattendedUpgrades = enable <!> disable
| enabled = "true"
| otherwise = "false"
- configure = withOS "unattended upgrades configured" $ \o ->
+ configure :: Property DebianLike
+ configure = withOS "unattended upgrades configured" $ \w o ->
case o of
-- the package defaults to only upgrading stable
(Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
+ | not (isStable suite) -> ensureProperty w $
"/etc/apt/apt.conf.d/50unattended-upgrades"
`File.containsLine`
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
@@ -269,10 +263,13 @@ type DebconfTemplateValue = String
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo
-reConfigure package vals = reconfigure `requires` setselections
- `describe` ("reconfigure " ++ package)
+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike
+reConfigure package vals = tightenTargets $
+ reconfigure
+ `requires` setselections
+ `describe` ("reconfigure " ++ package)
where
+ setselections :: Property DebianLike
setselections = property "preseed" $
if null vals
then noChange
@@ -289,7 +286,7 @@ reConfigure package vals = reconfigure `requires` setselections
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
-serviceInstalledRunning :: Package -> Property NoInfo
+serviceInstalledRunning :: Package -> Property DebianLike
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
@@ -297,10 +294,10 @@ data AptKey = AptKey
, pubkey :: String
}
-trustsKey :: AptKey -> RevertableProperty NoInfo
+trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike
trustsKey k = trustsKey' k <!> untrustKey k
-trustsKey' :: AptKey -> Property NoInfo
+trustsKey' :: AptKey -> Property DebianLike
trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
@@ -311,21 +308,21 @@ trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
desc = "apt trusts key " ++ keyname k
f = aptKeyFile k
-untrustKey :: AptKey -> Property NoInfo
-untrustKey = File.notPresent . aptKeyFile
+untrustKey :: AptKey -> Property DebianLike
+untrustKey = tightenTargets . File.notPresent . aptKeyFile
aptKeyFile :: AptKey -> FilePath
aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- | Cleans apt's cache of downloaded packages to avoid using up disk
-- space.
-cacheCleaned :: Property NoInfo
-cacheCleaned = cmdProperty "apt-get" ["clean"]
+cacheCleaned :: Property DebianLike
+cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"]
`assume` NoChange
`describe` "apt cache cleaned"
-- | Add a foreign architecture to dpkg and apt.
-hasForeignArch :: String -> Property NoInfo
+hasForeignArch :: String -> Property DebianLike
hasForeignArch arch = check notAdded (add `before` update)
`describe` ("dpkg has foreign architecture " ++ arch)
where
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 378836e8..09047ce5 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -19,9 +19,11 @@ module Propellor.Property.Chroot (
) where
import Propellor.Base
+import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Info
+import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
@@ -40,24 +42,24 @@ import System.Console.Concurrent
data Chroot where
Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
+instance IsContainer Chroot where
+ containerProperties (Chroot _ _ h) = containerProperties h
+ containerInfo (Chroot _ _ h) = containerInfo h
+ setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
+
chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
+chrootSystem = fromInfoVal . fromInfo . containerInfo
instance Show Chroot where
show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-instance PropAccum Chroot where
- (Chroot l c h) `addProp` p = Chroot l c (h & p)
- (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)
- getProperties (Chroot _ _ h) = hostProperties h
-
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
-- If the operating System is not supported, return
-- Left error message.
- buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
+ buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -68,14 +70,14 @@ class ChrootBootstrapper b where
data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
- buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
-
-extractTarball :: FilePath -> FilePath -> Property HasInfo
-extractTarball target src = toProp .
- check (unpopulated target) $
- cmdProperty "tar" params
- `assume` MadeChange
- `requires` File.dirExists target
+ buildchroot (ChrootTarball tb) _ loc = Right $
+ tightenTargets $ extractTarball loc tb
+
+extractTarball :: FilePath -> FilePath -> Property UnixLike
+extractTarball target src = check (unpopulated target) $
+ cmdProperty "tar" params
+ `assume` MadeChange
+ `requires` File.dirExists target
where
params =
[ "-C"
@@ -92,28 +94,27 @@ instance ChrootBootstrapper Debootstrapped where
(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` property not specified"
+ Nothing -> Left "Cannot debootstrap; OS not specified"
where
debootstrap s = Debootstrap.built loc s cf
-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot. At a minimum,
--- add the `os` property to specify the operating system to bootstrap.
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
--- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
--- > & os (System (Debian Unstable) "amd64")
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
-bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot
-bootstrapped bootstrapper location = Chroot location bootstrapper h
- where
- h = Host location [] mempty
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
+bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -121,43 +122,44 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h
-- Reverting this property removes the chroot. Anything mounted inside it
-- is first unmounted. Note that it does not ensure that any processes
-- that might be running inside the chroot are stopped.
-provisioned :: Chroot -> RevertableProperty HasInfo
+provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned c = provisioned' (propagateChrootInfo c) c False
-provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo
+provisioned'
+ :: (Property Linux -> Property (HasInfo + Linux))
+ -> Chroot
+ -> Bool
+ -> RevertableProperty (HasInfo + Linux) Linux
provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
- (propigator $ propertyList (chrootDesc c "exists") [setup])
+ (propigator $ setup `describe` chrootDesc c "exists")
<!>
- (propertyList (chrootDesc c "removed") [teardown])
+ (teardown `describe` chrootDesc c "removed")
where
+ setup :: Property Linux
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
- `requires` toProp built
+ `requires` built
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
- cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
+ cantbuild e = property (chrootDesc c "built") (error e)
+ teardown :: Property Linux
teardown = check (not <$> unpopulated loc) $
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
- where
- p' = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p <> chrootInfo c)
- (propertyChildren p)
+propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -205,7 +207,7 @@ chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
Just h -> go h
where
@@ -213,11 +215,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
changeWorkingDirectory localdir
when onconsole forceConsole
onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureProperties $
+ r <- runPropellor (setInChroot h) $ ensureChildProperties $
if systemdonly
- then [Systemd.installed]
- else map ignoreInfo $
- hostProperties h
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
@@ -255,15 +256,17 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- from being started, which is often something you want to prevent when
-- building a chroot.
--
--- This is accomplished by installing a </usr/sbin/policy-rc.d> script
--- that does not let any daemons be started by packages that use
+-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>
+-- script that does not let any daemons be started by packages that use
-- invoke-rc.d. Reverting the property removes the script.
-noServices :: RevertableProperty NoInfo
+--
+-- This property has no effect on non-Debian systems.
+noServices :: RevertableProperty UnixLike UnixLike
noServices = setup <!> teardown
where
f = "/usr/sbin/policy-rc.d"
script = [ "#!/bin/sh", "exit 101" ]
- setup = combineProperties "no services started"
+ setup = combineProperties "no services started" $ toProps
[ File.hasContent f script
, File.mode f (combineModes (readModes ++ executeModes))
]
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 6da2e643..6b84acb5 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -58,10 +58,10 @@ import Utility.Process (createProcess, CreateProcess, waitForProcess)
-- | A property that can be satisfied by running a command.
--
-- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> UncheckedProperty NoInfo
+cmdProperty :: String -> [String] -> UncheckedProperty UnixLike
cmdProperty cmd params = cmdProperty' cmd params id
-cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty NoInfo
+cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike
cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $
cmdResult <$> boolSystem' cmd (map Param params) mkprocess
where
@@ -74,7 +74,7 @@ cmdResult True = NoChange
-- | A property that can be satisfied by running a command,
-- with added environment variables in addition to the standard
-- environment.
-cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty NoInfo
+cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike
cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
cmdResult <$> boolSystemEnv cmd (map Param params) (Just env')
@@ -85,14 +85,14 @@ cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do
type Script = [String]
-- | A property that can be satisfied by running a script.
-scriptProperty :: Script -> UncheckedProperty NoInfo
+scriptProperty :: Script -> UncheckedProperty UnixLike
scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
where
shellcmd = intercalate " ; " ("set -e" : script)
-- | A property that can satisfied by running a script
-- as user (cd'd to their home directory).
-userScriptProperty :: User -> Script -> UncheckedProperty NoInfo
+userScriptProperty :: User -> Script -> UncheckedProperty UnixLike
userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 74afecc4..e69dc17d 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -37,6 +37,8 @@ module Propellor.Property.Concurrent (
) where
import Propellor.Base
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Control.Concurrent
import qualified Control.Concurrent.Async as A
@@ -77,8 +79,8 @@ concurrently p1 p2 = (combineWith go go p1 p2)
--
-- The above example will run foo and bar concurrently, and once either of
-- those 2 properties finishes, will start running baz.
-concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo
-concurrentList getn d (PropList ps) = infoProperty d go mempty ps
+concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+concurrentList getn d (Props ps) = property d go `addChildren` ps
where
go = do
n <- liftIO getn
@@ -97,15 +99,11 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
(p:rest) -> return (rest, Just p)
case v of
Nothing -> return r
- -- This use of propertySatisfy does not lose any
- -- Info asociated with the property, because
- -- concurrentList sets all the properties as
- -- children, and so propigates their info.
Just p -> do
hn <- asks hostName
r' <- actionMessageOn hn
- (propertyDesc p)
- (propertySatisfy p)
+ (getDesc p)
+ (getSatisfy p)
worker q (r <> r')
-- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 0d275b91..8aa18d20 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-}
-- | This module adds conductors to propellor. A conductor is a Host that
-- is responsible for running propellor on other hosts
@@ -73,7 +73,8 @@ module Propellor.Property.Conductor (
Conductable(..),
) where
-import Propellor.Base hiding (os)
+import Propellor.Base
+import Propellor.Container
import Propellor.Spin (spin')
import Propellor.PrivData.Paths
import Propellor.Types.Info
@@ -82,21 +83,22 @@ import qualified Propellor.Property.Ssh as Ssh
import qualified Data.Set as S
-- | Class of things that can be conducted.
+--
+-- There are instances for single hosts, and for lists of hosts.
+-- With a list, each listed host will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
class Conductable c where
- conducts :: c -> RevertableProperty HasInfo
+ conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
instance Conductable Host where
- -- | Conduct the specified host.
conducts h = conductorFor h <!> notConductorFor h
--- | Each host in the list will be conducted in turn. Failure to conduct
--- one host does not prevent conducting subsequent hosts in the list, but
--- will be propagated as an overall failure of the property.
instance Conductable [Host] where
conducts hs =
- propertyList desc (map (toProp . conducts) hs)
+ propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs)
<!>
- propertyList desc (map (toProp . revert . conducts) hs)
+ propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs)
where
desc = cdesc $ unwords $ map hostName hs
@@ -126,7 +128,7 @@ mkOrchestra = fromJust . go S.empty
where
go seen h
| S.member (hostName h) seen = Nothing -- break loop
- | otherwise = Just $ case getInfo (hostInfo h) of
+ | otherwise = Just $ case fromInfo (hostInfo h) of
ConductorFor [] -> Conducted h
ConductorFor l ->
let seen' = S.insert (hostName h) seen
@@ -214,14 +216,15 @@ orchestrate :: [Host] -> [Host]
orchestrate hs = map go hs
where
go h
- | isOrchestrated (getInfo (hostInfo h)) = h
+ | isOrchestrated (fromInfo (hostInfo h)) = h
| otherwise = foldl orchestrate' (removeold h) (map (deloop h) os)
os = extractOrchestras hs
removeold h = foldl removeold' h (oldconductorsof h)
- removeold' h oldconductor = h & revert (conductedBy oldconductor)
+ removeold' h oldconductor = setContainerProps h $ containerProps h
+ ! conductedBy oldconductor
- oldconductors = zip hs (map (getInfo . hostInfo) hs)
+ oldconductors = zip hs (map (fromInfo . hostInfo) hs)
oldconductorsof h = flip mapMaybe oldconductors $
\(oldconductor, NotConductorFor l) ->
if any (sameHost h) l
@@ -232,7 +235,9 @@ orchestrate' :: Host -> Orchestra -> Host
orchestrate' h (Conducted _) = h
orchestrate' h (Conductor c l)
| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
- | any (sameHost h) (map topHost l) = cont $ h & conductedBy c
+ | any (sameHost h) (map topHost l) = cont $
+ setContainerProps h $ containerProps h
+ & conductedBy c
| otherwise = cont h
where
cont h' = foldl orchestrate' h' l
@@ -240,14 +245,16 @@ orchestrate' h (Conductor c l)
-- The host this property is added to becomes the conductor for the
-- specified Host. Note that `orchestrate` must be used for this property
-- to have any effect.
-conductorFor :: Host -> Property HasInfo
-conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
- `requires` toProp (conductorKnownHost h)
+conductorFor :: Host -> Property (HasInfo + UnixLike)
+conductorFor h = go
+ `setInfoProperty` (toInfo (ConductorFor [h]))
+ `requires` setupRevertableProperty (conductorKnownHost h)
`requires` Ssh.installed
where
desc = cdesc (hostName h)
- go = ifM (isOrchestrated <$> askInfo)
+ go :: Property UnixLike
+ go = property desc $ ifM (isOrchestrated <$> askInfo)
( do
pm <- liftIO $ filterPrivData h
<$> readPrivDataFile privDataLocal
@@ -262,13 +269,15 @@ conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
)
-- Reverts conductorFor.
-notConductorFor :: Host -> Property HasInfo
-notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) []
- `requires` toProp (revert (conductorKnownHost h))
+notConductorFor :: Host -> Property (HasInfo + UnixLike)
+notConductorFor h = (doNothing :: Property UnixLike)
+ `setInfoProperty` (toInfo (NotConductorFor [h]))
+ `describe` desc
+ `requires` undoRevertableProperty (conductorKnownHost h)
where
desc = "not " ++ cdesc (hostName h)
-conductorKnownHost :: Host -> RevertableProperty NoInfo
+conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike
conductorKnownHost h =
mk Ssh.knownHost
<!>
@@ -287,10 +296,10 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
i = mempty
`addInfo` mconcat (map privinfo hs)
`addInfo` Orchestrated (Any True)
- privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')
+ privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')
-- Use this property to let the specified conductor ssh in and run propellor.
-conductedBy :: Host -> RevertableProperty NoInfo
+conductedBy :: Host -> RevertableProperty UnixLike UnixLike
conductedBy h = (setup <!> teardown)
`describe` ("conducted by " ++ hostName h)
where
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index dac4e564..270e04f1 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -37,7 +37,7 @@ adjustSection
-> AdjustSection
-> InsertSection
-> FilePath
- -> Property NoInfo
+ -> Property UnixLike
adjustSection desc start past adjust insert = fileProperty desc go
where
go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls
@@ -68,7 +68,7 @@ adjustIniSection
-> AdjustSection
-> InsertSection
-> FilePath
- -> Property NoInfo
+ -> Property UnixLike
adjustIniSection desc header =
adjustSection
desc
@@ -77,7 +77,7 @@ adjustIniSection desc header =
-- | Ensures that a .ini file exists and contains a section
-- with a key=value setting.
-containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property NoInfo
+containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike
containsIniSetting f (header, key, value) =
adjustIniSection
(f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value)
@@ -93,7 +93,7 @@ containsIniSetting f (header, key, value) =
isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]
-- | Ensures that a .ini file does not contain the specified section.
-lacksIniSection :: FilePath -> IniSection -> Property NoInfo
+lacksIniSection :: FilePath -> IniSection -> Property UnixLike
lacksIniSection f header =
adjustIniSection
(f ++ " lacks section [" ++ header ++ "]")
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 365e2903..0966a7e5 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -27,9 +27,11 @@ data Times
-- job file.
--
-- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
-job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
- [ cronjobfile `File.hasContent`
+job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
+job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props
+ & Apt.serviceInstalledRunning "cron"
+ & Apt.installed ["util-linux", "moreutils"]
+ & cronjobfile `File.hasContent`
[ case times of
Times _ -> ""
_ -> "#!/bin/sh\nset -e"
@@ -44,22 +46,19 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
"root" -> "chronic " ++ shellEscape scriptfile
_ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile
]
- , case times of
+ & case times of
Times _ -> doNothing
_ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes)
-- Use a separate script because it makes the cron job name
-- prettier in emails, and also allows running the job manually.
- , scriptfile `File.hasContent`
+ & scriptfile `File.hasContent`
[ "#!/bin/sh"
, "# Generated by propellor"
, "set -e"
, "flock -n " ++ shellEscape cronjobfile
++ " sh -c " ++ shellEscape cmdline
]
- , scriptfile `File.mode` combineModes (readModes ++ executeModes)
- ]
- `requires` Apt.serviceInstalledRunning "cron"
- `requires` Apt.installed ["util-linux", "moreutils"]
+ & scriptfile `File.mode` combineModes (readModes ++ executeModes)
where
cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"
cronjobfile = "/etc" </> cronjobdir </> name
@@ -75,13 +74,13 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
| otherwise = '_'
-- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
+niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
niceJob desc times user cddir command = job desc times user cddir
("nice ionice -c 3 sh -c " ++ shellEscape command)
-- | Installs a cron job to run propellor.
-runPropellor :: Times -> Property NoInfo
-runPropellor times = withOS "propellor cron job" $ \o ->
- ensureProperty $
+runPropellor :: Times -> Property UnixLike
+runPropellor times = withOS "propellor cron job" $ \w o ->
+ ensureProperty w $
niceJob "propellor" times (User "root") localdir
(bootstrapPropellorCommand o ++ "; ./propellor")
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index eea7b96f..b86d8e0b 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -119,19 +119,17 @@ debianMirrorKeyring k m = m { _debianMirrorKeyring = k }
debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r }
-mirror :: DebianMirror -> Property NoInfo
-mirror mirror' = propertyList
- ("Debian mirror " ++ dir)
- [ Apt.installed ["debmirror"]
- , User.accountFor (User "debmirror")
- , File.dirExists dir
- , File.ownerGroup dir (User "debmirror") (Group "debmirror")
- , check (not . and <$> mapM suitemirrored suites)
+mirror :: DebianMirror -> Property DebianLike
+mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props
+ & Apt.installed ["debmirror"]
+ & User.accountFor (User "debmirror")
+ & File.dirExists dir
+ & File.ownerGroup dir (User "debmirror") (Group "debmirror")
+ & check (not . and <$> mapM suitemirrored suites)
(cmdProperty "debmirror" args)
`describe` "debmirror setup"
- , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $
- unwords ("/usr/bin/debmirror" : args)
- ]
+ & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/"
+ (unwords ("/usr/bin/debmirror" : args))
where
dir = _debianMirrorDir mirror'
suites = _debianMirrorSuites mirror'
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 5716be38..e0c56966 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@@ -48,14 +46,15 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
-built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
-built target system config = built' (toProp installed) target system config
+built :: FilePath -> System -> DebootstrapConfig -> Property Linux
+built target system config = built' (setupRevertableProperty installed) target system config
-built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
+built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
+ setupprop :: Property Linux
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
-- Don't allow non-root users to see inside the chroot,
@@ -99,39 +98,34 @@ extractSuite (System (FreeBSD _) _) = Nothing
-- When necessary, falls back to installing debootstrap from source.
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
-installed :: RevertableProperty NoInfo
+installed :: RevertableProperty Linux Linux
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \o ->
- ifM (liftIO $ isJust <$> programPath)
- ( return NoChange
- , ensureProperty (installon o)
- )
+ install = check (isJust <$> programPath) $
+ (aptinstall `pickOS` sourceInstall)
+ `describe` "debootstrap installed"
- installon (Just (System (Debian _) _)) = aptinstall
- installon (Just (System (Buntish _) _)) = aptinstall
- installon _ = sourceInstall
-
- remove = withOS "debootstrap removed" $ ensureProperty . removefrom
- removefrom (Just (System (Debian _) _)) = aptremove
- removefrom (Just (System (Buntish _) _)) = aptremove
- removefrom _ = sourceRemove
+ remove = (aptremove `pickOS` sourceRemove)
+ `describe` "debootstrap removed"
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
-sourceInstall :: Property NoInfo
-sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
+sourceInstall :: Property Linux
+sourceInstall = go
`requires` perlInstalled
`requires` arInstalled
+ where
+ go :: Property Linux
+ go = property "debootstrap installed from source" (liftIO sourceInstall')
-perlInstalled :: Property NoInfo
+perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
-arInstalled :: Property NoInfo
+arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
@@ -175,7 +169,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
-sourceRemove :: Property NoInfo
+sourceRemove :: Property Linux
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6200f856..718768c2 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,6 +2,8 @@
--
-- This module is designed to be imported unqualified.
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
@@ -30,6 +32,7 @@ import Propellor.Property.Parted
import Propellor.Property.Mount
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Container
import Utility.Path
import Data.List (isPrefixOf, isInfixOf, sortBy)
@@ -51,7 +54,8 @@ type DiskImage = FilePath
--
-- > import Propellor.Property.DiskImage
--
--- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+-- > let chroot d = Chroot.debootstrapped mempty d
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["linux-image-amd64"]
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
@@ -76,44 +80,54 @@ type DiskImage = FilePath
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
- `requires` (cleanrebuild <!> doNothing)
+ `requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
desc = "built disk image " ++ img
+ cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
- chroot = mkchroot chrootdir
- -- Before ensuring any other properties of the chroot, avoid
- -- starting services. Reverted by imageFinalized.
- &^ Chroot.noServices
- -- First stage finalization.
- & fst final
- -- Avoid wasting disk image space on the apt cache
- & Apt.cacheCleaned
+ chroot =
+ let c = mkchroot chrootdir
+ in setContainerProps c $ containerProps c
+ -- Before ensuring any other properties of the chroot,
+ -- avoid starting services. Reverted by imageFinalized.
+ &^ Chroot.noServices
+ -- First stage finalization.
+ & fst final
+ & cachesCleaned
+
+-- | This property is automatically added to the chroot when building a
+-- disk image. It cleans any caches of information that can be omitted;
+-- eg the apt cache on Debian.
+cachesCleaned :: Property UnixLike
+cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
+ where
+ skipit = doNothing :: Property UnixLike
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
- mkimg = property desc $ do
+ mkimg = property' desc $ \w -> do
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
@@ -123,7 +137,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
-- tie the knot!
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
- ensureProperty $
+ ensureProperty w $
imageExists img (partTableSize parttable)
`before`
partitioned YesReallyDeleteDiskContents img parttable
@@ -135,17 +149,18 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
imageFinalized final mnts mntopts devs parttable
rmimg = File.notPresent img
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
-partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
+ mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
- go Nothing _ _ = noChange
- go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+ go _ Nothing _ _ = noChange
+ go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
(const $ liftIO $ umountLazy tmpdir)
$ \ismounted -> if ismounted
- then ensureProperty $
+ then ensureProperty w $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
@@ -203,7 +218,7 @@ getMountSz szm l (Just mntpt) =
-- 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.
-imageExists :: FilePath -> ByteSize -> Property NoInfo
+imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
@@ -226,19 +241,19 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
--
-- It's ok if the second property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
- property "disk image finalized" $
+ property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
- go top `finally` liftIO (unmountall top)
+ go w top `finally` liftIO (unmountall top)
where
- go top = do
+ go w top = do
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
- ensureProperty $ final top devs
+ ensureProperty w $ final top devs
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
@@ -280,27 +295,26 @@ noFinalization = (doNothing, \_ _ -> doNothing)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed' bios, boots)
where
- boots mnt loopdevs = combineProperties "disk image boots using grub"
+ boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
-- bind mount host /dev so grub can access the loop devices
- [ bindMount "/dev" (inmnt "/dev")
- , mounted "proc" "proc" (inmnt "/proc") mempty
- , mounted "sysfs" "sys" (inmnt "/sys") mempty
+ & bindMount "/dev" (inmnt "/dev")
+ & mounted "proc" "proc" (inmnt "/proc") mempty
+ & mounted "sysfs" "sys" (inmnt "/sys") mempty
-- update the initramfs so it gets the uuid of the root partition
- , inchroot "update-initramfs" ["-u"]
+ & inchroot "update-initramfs" ["-u"]
`assume` MadeChange
-- work around for http://bugs.debian.org/802717
- , check haveosprober $ inchroot "chmod" ["-x", osprober]
- , inchroot "update-grub" []
+ & check haveosprober (inchroot "chmod" ["-x", osprober])
+ & inchroot "update-grub" []
`assume` MadeChange
- , check haveosprober $ inchroot "chmod" ["+x", osprober]
- , inchroot "grub-install" [wholediskloopdev]
+ & check haveosprober (inchroot "chmod" ["+x", osprober])
+ & inchroot "grub-install" [wholediskloopdev]
`assume` MadeChange
-- sync all buffered changes out to the disk image
-- may not be necessary, but seemed needed sometimes
-- when using the disk image right away.
- , cmdProperty "sync" []
+ & cmdProperty "sync" []
`assume` NoChange
- ]
where
-- cannot use </> since the filepath is absolute
inmnt f = mnt ++ f
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index adc12930..2e2710a6 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -60,7 +60,7 @@ import Data.List
--
-- In either case, the secondary dns server Host should have an ipv4 and/or
-- ipv6 property defined.
-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
primary hosts domain soa rs = setup <!> cleanup
where
setup = setupPrimary zonefile id hosts domain soa rs
@@ -70,7 +70,7 @@ primary hosts domain soa rs = setup <!> cleanup
zonefile = "/etc/bind/propellor/db." ++ domain
-setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike)
setupPrimary zonefile mknamedconffile hosts domain soa rs =
withwarnings baseprop
`requires` servingZones
@@ -80,9 +80,10 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
- baseprop = infoProperty ("dns primary for " ++ domain) satisfy
- (mempty `addInfo` addNamedConf conf) []
- satisfy = do
+ baseprop = primaryprop
+ `setInfoProperty` (toInfo (addNamedConf conf))
+ primaryprop :: Property DebianLike
+ primaryprop = property ("dns primary for " ++ domain) $ do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
{ zHosts = zHosts partialzone ++ rs ++ sshfps }
@@ -120,11 +121,13 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
in z /= oldzone || oldserial < sSerial (zSOA zone)
-cleanupPrimary :: FilePath -> Domain -> Property NoInfo
+cleanupPrimary :: FilePath -> Domain -> Property DebianLike
cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
- property ("removed dns primary for " ++ domain)
- (makeChange $ removeZoneFile zonefile)
- `requires` namedConfWritten
+ go `requires` namedConfWritten
+ where
+ desc = "removed dns primary for " ++ domain
+ go :: Property DebianLike
+ go = property desc (makeChange $ removeZoneFile zonefile)
-- | Primary dns server for a domain, secured with DNSSEC.
--
@@ -152,7 +155,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- This is different from the serial number used by 'primary', so if you
-- want to later disable DNSSEC you will need to adjust the serial number
-- passed to mkSOA to ensure it is larger.
-signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
where
setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
@@ -184,12 +187,12 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
--
-- Note that if a host is declared to be a primary and a secondary dns
-- server for the same domain, the primary server config always wins.
-secondary :: [Host] -> Domain -> RevertableProperty HasInfo
+secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
-- | This variant is useful if the primary server does not have its DNS
-- configured via propellor.
-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo
+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondaryFor masters hosts domain = setup <!> cleanup
where
setup = pureInfoProperty desc (addNamedConf conf)
@@ -210,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
otherServers wantedtype hosts domain =
M.keys $ M.filter wanted $ hostMap hosts
where
- wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of
+ wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
@@ -218,15 +221,15 @@ otherServers wantedtype hosts domain =
-- | Rewrites the whole named.conf.local file to serve the zones
-- configured by `primary` and `secondary`, and ensures that bind9 is
-- running.
-servingZones :: Property NoInfo
+servingZones :: Property DebianLike
servingZones = namedConfWritten
`onChange` Service.reloaded "bind9"
`requires` Apt.serviceInstalledRunning "bind9"
-namedConfWritten :: Property NoInfo
-namedConfWritten = property "named.conf configured" $ do
+namedConfWritten :: Property DebianLike
+namedConfWritten = property' "named.conf configured" $ \w -> do
zs <- getNamedConf
- ensureProperty $
+ ensureProperty w $
hasContent namedConfFile $
concatMap confStanza $ M.elems zs
@@ -465,7 +468,7 @@ genZone inzdomain hostmap zdomain soa =
-- So we can just use the IPAddrs.
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
where
info = hostInfo h
gen c = case getAddresses info of
@@ -480,7 +483,7 @@ genZone inzdomain hostmap zdomain soa =
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))
-- Simplifies the list of hosts. Remove duplicate entries.
-- Also, filter out any CHAMES where the same domain has an
@@ -515,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf)
domain = confDomain conf
getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo
+getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo
-- | Generates SSHFP records for hosts in the domain (or with CNAMES
-- in the domain) that have configured ssh public keys.
@@ -528,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
(AbsDomain hostname : cnames)
- cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
hostname = hostName h
info = hostInfo h
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index 1ba459e6..aa58dc60 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -7,13 +7,13 @@ import qualified Propellor.Property.File as File
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-keysInstalled :: Domain -> RevertableProperty HasInfo
+keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike
keysInstalled domain = setup <!> cleanup
where
- setup = propertyList "DNSSEC keys installed" $
+ setup = propertyList "DNSSEC keys installed" $ toProps $
map installkey keys
- cleanup = propertyList "DNSSEC keys removed" $
+ cleanup = propertyList "DNSSEC keys removed" $ toProps $
map (File.notPresent . keyFn domain) keys
installkey k = writer (keysrc k) (keyFn domain k) (Context domain)
@@ -37,12 +37,14 @@ keysInstalled domain = setup <!> cleanup
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo
+zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike
zoneSigned domain zonefile = setup <!> cleanup
where
+ setup :: Property (HasInfo + UnixLike)
setup = check needupdate (forceZoneSigned domain zonefile)
`requires` keysInstalled domain
+ cleanup :: Property UnixLike
cleanup = File.notPresent (signedZoneFile zonefile)
`before` File.notPresent dssetfile
`before` revert (keysInstalled domain)
@@ -63,7 +65,7 @@ zoneSigned domain zonefile = setup <!> cleanup
t2 <- getModificationTime f
return (t2 >= t1)
-forceZoneSigned :: Domain -> FilePath -> Property NoInfo
+forceZoneSigned :: Domain -> FilePath -> Property UnixLike
forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
salt <- take 16 <$> saltSha1
let p = proc "dnssec-signzone"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ebc0b301..2ef97438 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
-- | Docker support for propellor
--
@@ -48,8 +48,10 @@ module Propellor.Property.Docker (
import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
+import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
+import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
@@ -66,16 +68,17 @@ import Data.List.Utils
import qualified Data.Map as M
import System.Console.Concurrent
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property HasInfo
+configured :: Property (HasInfo + DebianLike)
configured = prop `requires` installed
where
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src anyContext $ \getcfg ->
- property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+ property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -88,6 +91,11 @@ type ContainerName = String
-- | A docker container.
data Container = Container Image Host
+instance IsContainer Container where
+ containerProperties (Container _ h) = containerProperties h
+ containerInfo (Container _ h) = containerInfo h
+ setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps)
+
class HasImage a where
getImageName :: a -> Image
@@ -97,22 +105,17 @@ instance HasImage Image where
instance HasImage Container where
getImageName (Container i _) = i
-instance PropAccum Container where
- (Container i h) `addProp` p = Container i (h `addProp` p)
- (Container i h) `addPropFront` p = Container i (h `addPropFront` p)
- getProperties (Container _ h) = hostProperties h
-
-- | Defines a Container with a given name, image, and properties.
--- Properties can be added to configure the Container.
+-- Add properties to configure the Container.
--
--- > container "web-server" "debian"
+-- > container "web-server" (latestImage "debian") $ props
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Container
-container cn image = Container image (Host cn [] info)
+container :: ContainerName -> Image -> Props metatypes -> Container
+container cn image (Props ps) = Container image (Host cn ps info)
where
- info = dockerInfo mempty
+ info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
-- | Ensures that a docker container is set up and running.
--
@@ -124,7 +127,7 @@ container cn image = Container image (Host cn [] info)
--
-- Reverting this property ensures that the container is stopped and
-- removed.
-docked :: Container -> RevertableProperty HasInfo
+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr@(Container _ h) =
(propagateContainerInfo ctr (go "docked" setup))
<!>
@@ -132,11 +135,12 @@ docked ctr@(Container _ h) =
where
cn = hostName h
- go desc a = property (desc ++ " " ++ cn) $ do
+ go desc a = property' (desc ++ " " ++ cn) $ \w -> do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureProperties [a cid (mkContainerInfo cid ctr)]
+ ensureProperty w $ a cid (mkContainerInfo cid ctr)
+ setup :: ContainerId -> ContainerInfo -> Property Linux
setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
@@ -144,8 +148,9 @@ docked ctr@(Container _ h) =
`requires`
installed
+ teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown cid (ContainerInfo image _runparams) =
- combineProperties ("undocked " ++ fromContainerId cid)
+ combineProperties ("undocked " ++ fromContainerId cid) $ toProps
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
@@ -155,32 +160,32 @@ docked ctr@(Container _ h) =
]
-- | Build the image from a directory containing a Dockerfile.
-imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo
-imageBuilt directory ctr = describe built msg
+imageBuilt :: HasImage c => FilePath -> c -> Property Linux
+imageBuilt directory ctr = built `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
- built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
- `assume` MadeChange
+ built :: Property Linux
+ built = tightenTargets $
+ Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
+ `assume` MadeChange
workDir p = p { cwd = Just directory }
image = getImageName ctr
-- | Pull the image from the standard Docker Hub registry.
-imagePulled :: HasImage c => c -> Property NoInfo
-imagePulled ctr = describe pulled msg
+imagePulled :: HasImage c => c -> Property Linux
+imagePulled ctr = pulled `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
- pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
- `assume` MadeChange
+ pulled :: Property Linux
+ pulled = tightenTargets $
+ Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
+ `assume` MadeChange
image = getImageName ctr
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
+ p `addInfoProperty` dockerinfo
where
- p' = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p <> dockerinfo)
- (propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
cn = hostName h
@@ -191,8 +196,8 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
- info = getInfo $ hostInfo h'
- h' = h
+ info = fromInfo $ hostInfo h'
+ h' = setContainerProps h $ containerProps h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
&^ restartAlways
@@ -209,14 +214,15 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property NoInfo
-garbageCollected = propertyList "docker garbage collected"
- [ gccontainers
- , gcimages
- ]
+garbageCollected :: Property Linux
+garbageCollected = propertyList "docker garbage collected" $ props
+ & gccontainers
+ & gcimages
where
+ gccontainers :: Property Linux
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+ gcimages :: Property Linux
gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
@@ -225,8 +231,8 @@ garbageCollected = propertyList "docker garbage collected"
-- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
-tweaked :: Property NoInfo
-tweaked = cmdProperty "sh"
+tweaked :: Property Linux
+tweaked = tightenTargets $ cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
@@ -239,10 +245,11 @@ tweaked = cmdProperty "sh"
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
--
-- Only takes effect after reboot. (Not automated.)
-memoryLimited :: Property NoInfo
-memoryLimited = "/etc/default/grub" `File.containsLine` cfg
- `describe` "docker memory limited"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+memoryLimited :: Property DebianLike
+memoryLimited = tightenTargets $
+ "/etc/default/grub" `File.containsLine` cfg
+ `describe` "docker memory limited"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
@@ -300,15 +307,15 @@ instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
-- | Set custom dns server for container.
-dns :: String -> Property HasInfo
+dns :: String -> Property (HasInfo + Linux)
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Property HasInfo
+hostname :: String -> Property (HasInfo + Linux)
hostname = runProp "hostname"
-- | Set name of container.
-name :: String -> Property HasInfo
+name :: String -> Property (HasInfo + Linux)
name = runProp "name"
class Publishable p where
@@ -322,15 +329,15 @@ instance Publishable String where
toPublish = id
-- | Publish a container's port to the host
-publish :: Publishable p => p -> Property HasInfo
+publish :: Publishable p => p -> Property (HasInfo + Linux)
publish = runProp "publish" . toPublish
-- | Expose a container's port without publishing it.
-expose :: String -> Property HasInfo
+expose :: String -> Property (HasInfo + Linux)
expose = runProp "expose"
-- | Username or UID for container.
-user :: String -> Property HasInfo
+user :: String -> Property (HasInfo + Linux)
user = runProp "user"
class Mountable p where
@@ -346,17 +353,17 @@ instance Mountable String where
toMount = id
-- | Mount a volume
-volume :: Mountable v => v -> Property HasInfo
+volume :: Mountable v => v -> Property (HasInfo + Linux)
volume = runProp "volume" . toMount
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Property HasInfo
+volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Property HasInfo
+workdir :: String -> Property (HasInfo + Linux)
workdir = runProp "workdir"
-- | Memory limit for container.
@@ -364,18 +371,18 @@ workdir = runProp "workdir"
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
-memory :: String -> Property HasInfo
+memory :: String -> Property (HasInfo + Linux)
memory = runProp "memory"
-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property HasInfo
+cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property HasInfo
+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@@ -387,24 +394,24 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
-restartAlways :: Property HasInfo
+restartAlways :: Property (HasInfo + Linux)
restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
-restartOnFailure :: Maybe Int -> Property HasInfo
+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
-restartNever :: Property HasInfo
+restartNever :: Property (HasInfo + Linux)
restartNever = runProp "restart" "no"
-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
-environment :: (String, String) -> Property HasInfo
+environment :: (String, String) -> Property (HasInfo + Linux)
environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
@@ -441,9 +448,9 @@ myContainerSuffix = ".propellor"
containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc
where
- desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
+ desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
@@ -507,6 +514,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
retry (n-1) a
_ -> return v
+ go :: ImageIdentifier i => i -> Propellor Result
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
@@ -558,7 +566,7 @@ init s = case toContainerId s of
-- | Once a container is running, propellor can be run inside
-- it to provision it.
-provisionContainer :: ContainerId -> Property NoInfo
+provisionContainer :: ContainerId -> Property Linux
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
@@ -580,16 +588,14 @@ chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
go cid h = do
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do
- r <- runPropellor h $ ensureProperties $
- map ignoreInfo $
- hostProperties h
+ r <- runPropellor h $ ensureChildProperties $ hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
@@ -599,15 +605,16 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
-stoppedContainer :: ContainerId -> Property NoInfo
-stoppedContainer cid = containerDesc cid $ property desc $
+stoppedContainer :: ContainerId -> Property Linux
+stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty
- (property desc $ liftIO $ toResult <$> stopContainer cid)
+ ( liftIO cleanup `after` ensureProperty w stop
, return NoChange
)
where
desc = "stopped"
+ stop :: Property Linux
+ stop = property desc $ liftIO $ toResult <$> stopContainer cid
cleanup = do
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
@@ -651,14 +658,14 @@ listContainers status =
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $
+runProp :: String -> RunParam -> Property (HasInfo + Linux)
+runProp field val = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
-genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $
+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
+genProp field mkval = tightenTargets $ pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info
diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs
index 716d376f..9f147943 100644
--- a/src/Propellor/Property/Fail2Ban.hs
+++ b/src/Propellor/Property/Fail2Ban.hs
@@ -5,24 +5,24 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Propellor.Property.ConfFile
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.serviceInstalledRunning "fail2ban"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "fail2ban"
type Jail = String
-- | By default, fail2ban only enables the ssh jail, but many others
-- are available to be enabled, for example "postfix-sasl"
-jailEnabled :: Jail -> Property NoInfo
+jailEnabled :: Jail -> Property DebianLike
jailEnabled name = jailConfigured name "enabled" "true"
`onChange` reloaded
-- | Configures a jail. For example:
--
-- > jailConfigured "sshd" "port" "2222"
-jailConfigured :: Jail -> IniKey -> String -> Property NoInfo
+jailConfigured :: Jail -> IniKey -> String -> Property UnixLike
jailConfigured name key value =
jailConfFile name `containsIniSetting` (name, key, value)
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 3021617c..e072fcaa 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -9,14 +9,14 @@ import System.Exit
type Line = String
-- | Replaces all the content of a file.
-hasContent :: FilePath -> [Line] -> Property NoInfo
+hasContent :: FilePath -> [Line] -> Property UnixLike
f `hasContent` newcontent = fileProperty
("replace " ++ f)
(\_oldcontent -> newcontent) f
-- | Replaces all the content of a file, ensuring that its modes do not
-- allow it to be read or written by anyone other than the current user
-hasContentProtected :: FilePath -> [Line] -> Property NoInfo
+hasContentProtected :: FilePath -> [Line] -> Property UnixLike
f `hasContentProtected` newcontent = fileProperty' writeFileProtected
("replace " ++ f)
(\_oldcontent -> newcontent) f
@@ -25,38 +25,38 @@ f `hasContentProtected` newcontent = fileProperty' writeFileProtected
--
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
-hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source
-- for PrivData, rather than using PrivDataSourceFile .
-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
-hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
-hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposedFrom = hasPrivContent' writeFile
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
- property desc $ getcontent $ \privcontent ->
- ensureProperty $ fileProperty' writer desc
+ property' desc $ \o -> getcontent $ \privcontent ->
+ ensureProperty o $ fileProperty' writer desc
(\_oldcontent -> privDataLines privcontent) f
where
desc = "privcontent " ++ f
-- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property NoInfo
+containsLine :: FilePath -> Line -> Property UnixLike
f `containsLine` l = f `containsLines` [l]
-containsLines :: FilePath -> [Line] -> Property NoInfo
+containsLines :: FilePath -> [Line] -> Property UnixLike
f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
where
go content = content ++ filter (`notElem` content) ls
@@ -64,27 +64,28 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
-- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
-lacksLine :: FilePath -> Line -> Property NoInfo
+lacksLine :: FilePath -> Line -> Property UnixLike
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-lacksLines :: FilePath -> [Line] -> Property NoInfo
+lacksLines :: FilePath -> [Line] -> Property UnixLike
f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
-- | Replaces the content of a file with the transformed content of another file
-basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo
-f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f')
+basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
+f `basedOn` (f', a) = property' desc $ \o -> do
+ tmpl <- liftIO $ readFile f'
+ ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
desc = "replace " ++ f
- go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
-notPresent :: FilePath -> Property NoInfo
+notPresent :: FilePath -> Property UnixLike
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
+fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
where
go True = do
@@ -103,7 +104,7 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-- | Ensures a directory exists.
-dirExists :: FilePath -> Property NoInfo
+dirExists :: FilePath -> Property UnixLike
dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d
@@ -113,7 +114,7 @@ newtype LinkTarget = LinkTarget FilePath
-- | Creates or atomically updates a symbolic link.
--
-- Does not overwrite regular files or directories.
-isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo
+isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike
link `isSymlinkedTo` (LinkTarget target) = property desc $
go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link)
where
@@ -135,7 +136,7 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
updateLink = createSymbolicLink target `viaStableTmp` link
-- | Ensures that a file is a copy of another (regular) file.
-isCopyOf :: FilePath -> FilePath -> Property NoInfo
+isCopyOf :: FilePath -> FilePath -> Property UnixLike
f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
where
desc = f ++ " is copy of " ++ f'
@@ -156,7 +157,7 @@ f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
[Param "--preserve=all", Param "--", File src, File dest]
-- | Ensures that a file/dir has the specified owner and group.
-ownerGroup :: FilePath -> User -> Group -> Property NoInfo
+ownerGroup :: FilePath -> User -> Group -> Property UnixLike
ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
where
p = cmdProperty "chown" [og, f]
@@ -164,7 +165,7 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
og = owner ++ ":" ++ group
-- | Ensures that a file/dir has the specfied mode.
-mode :: FilePath -> FileMode -> Property NoInfo
+mode :: FilePath -> FileMode -> Property UnixLike
mode f v = p `changesFile` f
where
p = property (f ++ " mode " ++ show v) $ do
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index fa1f95d4..ce0befcd 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -26,10 +26,10 @@ import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["iptables"]
-rule :: Chain -> Table -> Target -> Rules -> Property NoInfo
+rule :: Chain -> Table -> Target -> Rules -> Property Linux
rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
where
r = Rule c tb tg rs
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 6bbd2570..704c1db9 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -22,8 +22,8 @@ runPkg cmd args =
in
lines <$> readProcess p a
-pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo
-pkgCmdProperty cmd args =
+pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD
+pkgCmdProperty cmd args = tightenTargets $
let
(p, a) = pkgCommand cmd args
in
@@ -44,13 +44,14 @@ instance IsInfo PkgUpdate where
pkgUpdated :: PkgUpdate -> Bool
pkgUpdated (PkgUpdate _) = True
-update :: Property HasInfo
+update :: Property (HasInfo + FreeBSD)
update =
let
upd = pkgCmd "update" []
go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []
+ (property "pkg update has run" go :: Property FreeBSD)
+ `setInfoProperty` (toInfo (PkgUpdate ""))
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
@@ -60,17 +61,19 @@ instance IsInfo PkgUpgrade where
pkgUpgraded :: PkgUpgrade -> Bool
pkgUpgraded (PkgUpgrade _) = True
-upgrade :: Property HasInfo
+upgrade :: Property (HasInfo + FreeBSD)
upgrade =
let
upd = pkgCmd "upgrade" []
go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update
+ (property "pkg upgrade has run" go :: Property FreeBSD)
+ `setInfoProperty` (toInfo (PkgUpdate ""))
+ `requires` update
type Package = String
-installed :: Package -> Property NoInfo
+installed :: Package -> Property FreeBSD
installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]
isInstallable :: Package -> IO Bool
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index 5467c668..fcad9e87 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -26,20 +26,23 @@ instance IsInfo PoudriereConfigured where
poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
-setConfigured :: Property HasInfo
-setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
+setConfigured :: Property (HasInfo + FreeBSD)
+setConfigured = tightenTargets $
+ pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
-poudriere :: Poudriere -> Property HasInfo
+poudriere :: Poudriere -> Property (HasInfo + FreeBSD)
poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop
`requires` Pkg.installed "poudriere"
`before` setConfigured
where
- confProp = File.containsLines poudriereConfigPath (toLines conf)
+ confProp :: Property FreeBSD
+ confProp = tightenTargets $
+ File.containsLines poudriereConfigPath (toLines conf)
setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS"
- prop :: CombinedType (Property NoInfo) (Property NoInfo)
+ prop :: Property FreeBSD
prop
| isJust zfs = ((setZfs $ fromJust zfs) `before` confProp)
- | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp]
+ | otherwise = confProp `describe` "Configuring Poudriere without ZFS"
poudriereCommand :: String -> [String] -> (String, [String])
poudriereCommand cmd args = ("poudriere", cmd:args)
@@ -58,8 +61,8 @@ listJails = mapMaybe (headMaybe . take 1 . words)
jailExists :: Jail -> IO Bool
jailExists (Jail name _ _) = isInfixOf [name] <$> listJails
-jail :: Jail -> Property NoInfo
-jail j@(Jail name version arch) =
+jail :: Jail -> Property FreeBSD
+jail j@(Jail name version arch) = tightenTargets $
let
chk = do
c <- poudriereConfigured <$> askInfo
@@ -70,7 +73,7 @@ jail j@(Jail name version arch) =
createJail = cmdProperty cmd args
in
check chk createJail
- `describe` unwords ["Create poudriere jail", name]
+ `describe` unwords ["Create poudriere jail", name]
data JailInfo = JailInfo String
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index a5ef5ab1..5d7c8b4d 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -11,7 +11,7 @@ import Data.List
-- using git-daemon, run from inetd.
--
-- Note that reverting this property does not remove or stop inetd.
-daemonRunning :: FilePath -> RevertableProperty NoInfo
+daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike
daemonRunning exportdir = setup <!> unsetup
where
setup = containsLine conf (mkl "tcp4")
@@ -47,7 +47,7 @@ daemonRunning exportdir = setup <!> unsetup
, exportdir
]
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["git"]
type RepoUrl = String
@@ -61,8 +61,8 @@ type Branch = String
-- it will be recursively deleted first.
--
-- A branch can be specified, to check out.
-cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
-cloned owner url dir mbranch = check originurl (property desc checkout)
+cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike
+cloned owner url dir mbranch = check originurl go
`requires` installed
where
desc = "git cloned " ++ url ++ " to " ++ dir
@@ -74,12 +74,13 @@ cloned owner url dir mbranch = check originurl (property desc checkout)
return (v /= Just url)
, return True
)
- checkout = do
+ go :: Property DebianLike
+ go = property' desc $ \w -> do
liftIO $ do
whenM (doesDirectoryExist dir) $
removeDirectoryRecursive dir
createDirectoryIfMissing True (takeDirectory dir)
- ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds)
+ ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds)
`assume` MadeChange
checkoutcmds =
-- The </dev/null fixes an intermittent
@@ -99,8 +100,8 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
data GitShared = Shared Group | SharedAll | NotShared
-bareRepo :: FilePath -> User -> GitShared -> Property NoInfo
-bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
+bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $
dirExists repo : case gitshared of
NotShared ->
[ ownerGroup repo user (userGroup user)
@@ -121,7 +122,7 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: "
isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])
-- | Set a key value pair in a git repo's configuration.
-repoConfigured :: FilePath -> (String, String) -> Property NoInfo
+repoConfigured :: FilePath -> (String, String) -> Property UnixLike
repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $
userScriptProperty (User "root")
[ "cd " ++ repo
@@ -141,7 +142,7 @@ getRepoConfig repo key = catchDefaultIO [] $
lines <$> readProcess "git" ["-C", repo, "config", key]
-- | Whether a repo accepts non-fast-forward pushes.
-repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo
+repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs repo = accepts <!> refuses
where
accepts = repoConfigured repo ("receive.denyNonFastForwards", "false")
@@ -152,7 +153,7 @@ repoAcceptsNonFFs repo = accepts <!> refuses
-- | Sets a bare repository's default branch, which will be checked out
-- when cloning it.
-bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo
+bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike
bareRepoDefaultBranch repo branch =
userScriptProperty (User "root")
[ "cd " ++ repo
diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs
index bd710ca7..74e9df5a 100644
--- a/src/Propellor/Property/Gpg.hs
+++ b/src/Propellor/Property/Gpg.hs
@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["gnupg"]
-- A numeric id, or a description of the key, in a form understood by gpg.
@@ -22,11 +22,12 @@ data GpgKeyType = GpgPubKey | GpgPrivKey
--
-- Recommend only using this for low-value dedicated role keys.
-- No attempt has been made to scrub the key out of memory once it's used.
-keyImported :: GpgKeyId -> User -> Property HasInfo
+keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike)
keyImported key@(GpgKeyId keyid) user@(User u) = prop
`requires` installed
where
desc = u ++ " has gpg key " ++ show keyid
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src (Context keyid) $ \getkey ->
property desc $ getkey $ \key' -> do
let keylines = privDataLines key'
diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs
index f91ef1c2..58e49a86 100644
--- a/src/Propellor/Property/Group.hs
+++ b/src/Propellor/Property/Group.hs
@@ -4,7 +4,7 @@ import Propellor.Base
type GID = Int
-exists :: Group -> Maybe GID -> Property NoInfo
+exists :: Group -> Maybe GID -> Property UnixLike
exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid))
`describe` unwords ["group", group']
where
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 1b7f2a0a..a03fc5a0 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -19,20 +19,23 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- bootloader.
--
-- This includes running update-grub.
-installed :: BIOS -> Property NoInfo
+installed :: BIOS -> Property DebianLike
installed bios = installed' bios `onChange` mkConfig
-- Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
-mkConfig :: Property NoInfo
-mkConfig = cmdProperty "update-grub" []
+mkConfig :: Property DebianLike
+mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property NoInfo
-installed' bios = Apt.installed [pkg] `describe` "grub package installed"
+installed' :: BIOS -> Property Linux
+installed' bios = (aptinstall `pickOS` unsupportedOS)
+ `describe` "grub package installed"
where
- pkg = case bios of
+ aptinstall :: Property DebianLike
+ aptinstall = Apt.installed [debpkg]
+ debpkg = case bios of
PC -> "grub-pc"
EFI64 -> "grub-efi-amd64"
EFI32 -> "grub-efi-ia32"
@@ -48,8 +51,8 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed"
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
-boots :: OSDevice -> Property NoInfo
-boots dev = cmdProperty "grub-install" [dev]
+boots :: OSDevice -> Property Linux
+boots dev = tightenTargets $ cmdProperty "grub-install" [dev]
`assume` MadeChange
`describe` ("grub boots " ++ dev)
@@ -61,10 +64,10 @@ boots dev = cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
-chainPVGrub rootdev bootdev timeout = combineProperties desc
- [ File.dirExists "/boot/grub"
- , "/boot/grub/menu.lst" `File.hasContent`
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike
+chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
+ & File.dirExists "/boot/grub"
+ & "/boot/grub/menu.lst" `File.hasContent`
[ "default 1"
, "timeout " ++ show timeout
, ""
@@ -73,12 +76,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc
, "kernel /boot/xen-shim"
, "boot"
]
- , "/boot/load.cf" `File.hasContent`
+ & "/boot/load.cf" `File.hasContent`
[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
- , installed Xen
- , flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
- `assume` MadeChange
- `describe` "/boot-xen-shim"
- ]
+ & installed Xen
+ & flip flagFile "/boot/xen-shim" xenshim
where
desc = "chain PV-grub"
+ xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
+ `assume` MadeChange
+ `describe` "/boot-xen-shim"
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index bfe3ae17..5c4788e2 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.User as User
-- Clean up a system as installed by cloudatcost.com
-decruft :: Property NoInfo
-decruft = propertyList "cloudatcost cleanup"
- [ Hostname.sane
- , "worked around grub/lvm boot bug #743126" ==>
+decruft :: Property DebianLike
+decruft = propertyList "cloudatcost cleanup" $ props
+ & Hostname.sane
+ & grubbugfix
+ & nukecruft
+ where
+ grubbugfix :: Property DebianLike
+ grubbugfix = tightenTargets $
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
- `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
- , combineProperties "nuked cloudatcost cruft"
- [ File.notPresent "/etc/rc.local"
- , File.notPresent "/etc/init.d/S97-setup.sh"
- , File.notPresent "/zang-debian.sh"
- , File.notPresent "/bin/npasswd"
- , User.nuked (User "user") User.YesReallyDeleteHome
- ]
- ]
+ `describe` "worked around grub/lvm boot bug #743126"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+ `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
+ nukecruft :: Property Linux
+ nukecruft = tightenTargets $
+ combineProperties "nuked cloudatcost cruft" $ props
+ & File.notPresent "/etc/rc.local"
+ & File.notPresent "/etc/init.d/S97-setup.sh"
+ & File.notPresent "/zang-debian.sh"
+ & File.notPresent "/bin/npasswd"
+ & User.nuked (User "user") User.YesReallyDeleteHome
diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
index f49b86b3..c1e0ffc9 100644
--- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs
+++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
@@ -18,16 +18,15 @@ import Data.List
-- If 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 NoInfo
-distroKernel = propertyList "digital ocean distro kernel hack"
- [ Apt.installed ["grub-pc", "kexec-tools", "file"]
- , "/etc/default/kexec" `File.containsLines`
+distroKernel :: Property DebianLike
+distroKernel = propertyList "digital ocean distro kernel hack" $ props
+ & Apt.installed ["grub-pc", "kexec-tools", "file"]
+ & "/etc/default/kexec" `File.containsLines`
[ "LOAD_KEXEC=true"
, "USE_GRUB_CONFIG=true"
] `describe` "kexec configured"
- , check (not <$> runningInstalledKernel) Reboot.now
+ & check (not <$> runningInstalledKernel) Reboot.now
`describe` "running installed kernel"
- ]
runningInstalledKernel :: IO Bool
runningInstalledKernel = do
diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs
index 274412a0..71719d87 100644
--- a/src/Propellor/Property/HostingProvider/Linode.hs
+++ b/src/Propellor/Property/HostingProvider/Linode.hs
@@ -8,12 +8,13 @@ import Utility.FileMode
-- | Linode's pv-grub-x86_64 does not currently support booting recent
-- Debian kernels compressed with xz. This sets up pv-grub chaining to enable
-- it.
-chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
+chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"
-- | Linode disables mlocate's cron job's execute permissions,
-- presumably to avoid disk IO. This ensures it's executable.
-mlocateEnabled :: Property NoInfo
-mlocateEnabled = "/etc/cron.daily/mlocate"
- `File.mode` combineModes (readModes ++ executeModes)
+mlocateEnabled :: Property DebianLike
+mlocateEnabled = tightenTargets $
+ "/etc/cron.daily/mlocate"
+ `File.mode` combineModes (readModes ++ executeModes)
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 7ab350ae..e1342d91 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -22,20 +22,20 @@ import Data.List.Utils
-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
-- other hostnames there is not best practices and can lead to annoying
-- messages from eg, apache.
-sane :: Property NoInfo
+sane :: Property UnixLike
sane = sane' extractDomain
-sane' :: ExtractDomain -> Property NoInfo
-sane' extractdomain = property ("sane hostname") $
- ensureProperty . setTo' extractdomain =<< asks hostName
+sane' :: ExtractDomain -> Property UnixLike
+sane' extractdomain = property' ("sane hostname") $ \w ->
+ ensureProperty w . setTo' extractdomain =<< asks hostName
-- Like `sane`, but you can specify the hostname to use, instead
-- of the default hostname of the `Host`.
-setTo :: HostName -> Property NoInfo
+setTo :: HostName -> Property UnixLike
setTo = setTo' extractDomain
-setTo' :: ExtractDomain -> HostName -> Property NoInfo
-setTo' extractdomain hn = combineProperties desc
+setTo' :: ExtractDomain -> HostName -> Property UnixLike
+setTo' extractdomain hn = combineProperties desc $ toProps
[ "/etc/hostname" `File.hasContent` [basehost]
, hostslines $ catMaybes
[ if null domain
@@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc
-- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in.
-searchDomain :: Property NoInfo
+searchDomain :: Property UnixLike
searchDomain = searchDomain' extractDomain
-searchDomain' :: ExtractDomain -> Property NoInfo
-searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)
+searchDomain' :: ExtractDomain -> Property UnixLike
+searchDomain' extractdomain = property' desc $ \w ->
+ (ensureProperty w . go =<< asks hostName)
where
desc = "resolv.conf search and domain configured"
go hn =
diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs
index 2fbb780e..d0261626 100644
--- a/src/Propellor/Property/Journald.hs
+++ b/src/Propellor/Property/Journald.hs
@@ -5,7 +5,7 @@ import qualified Propellor.Property.Systemd as Systemd
import Utility.DataUnits
-- | Configures journald, restarting it so the changes take effect.
-configured :: Systemd.Option -> String -> Property NoInfo
+configured :: Systemd.Option -> String -> Property Linux
configured option value =
Systemd.configured "/etc/systemd/journald.conf" option value
`onChange` Systemd.restarted "systemd-journald"
@@ -14,28 +14,28 @@ configured option value =
-- Examples: "100 megabytes" or "0.5tb"
type DataSize = String
-configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
+configuredSize :: Systemd.Option -> DataSize -> Property Linux
configuredSize option s = case readSize dataUnits s of
Just sz -> configured option (systemdSizeUnits sz)
Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $
return FailedChange
-systemMaxUse :: DataSize -> Property NoInfo
+systemMaxUse :: DataSize -> Property Linux
systemMaxUse = configuredSize "SystemMaxUse"
-runtimeMaxUse :: DataSize -> Property NoInfo
+runtimeMaxUse :: DataSize -> Property Linux
runtimeMaxUse = configuredSize "RuntimeMaxUse"
-systemKeepFree :: DataSize -> Property NoInfo
+systemKeepFree :: DataSize -> Property Linux
systemKeepFree = configuredSize "SystemKeepFree"
-runtimeKeepFree :: DataSize -> Property NoInfo
+runtimeKeepFree :: DataSize -> Property Linux
runtimeKeepFree = configuredSize "RuntimeKeepFree"
-systemMaxFileSize :: DataSize -> Property NoInfo
+systemMaxFileSize :: DataSize -> Property Linux
systemMaxFileSize = configuredSize "SystemMaxFileSize"
-runtimeMaxFileSize :: DataSize -> Property NoInfo
+runtimeMaxFileSize :: DataSize -> Property Linux
runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
-- Generates size units as used in journald.conf.
diff --git a/src/Propellor/Property/Kerberos.hs b/src/Propellor/Property/Kerberos.hs
index cb6e06cc..3c351943 100644
--- a/src/Propellor/Property/Kerberos.hs
+++ b/src/Propellor/Property/Kerberos.hs
@@ -34,25 +34,25 @@ keyTabPath = maybe defaultKeyTab id
principal :: String -> Maybe String -> Maybe Realm -> Principal
principal p i r = p ++ maybe "" ("/"++) i ++ maybe "" ("@" ++) r
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["krb5-user"]
-kdcInstalled :: Property NoInfo
+kdcInstalled :: Property DebianLike
kdcInstalled = Apt.serviceInstalledRunning "krb5-kdc"
-adminServerInstalled :: Property NoInfo
+adminServerInstalled :: Property DebianLike
adminServerInstalled = Apt.serviceInstalledRunning "krb5-admin-server"
-kpropServerInstalled :: Property HasInfo
+kpropServerInstalled :: Property DebianLike
kpropServerInstalled = propertyList "kprop server installed" $ props
& kdcInstalled
& Apt.installed ["openbsd-inetd"]
& "/etc/inetd.conf" `File.containsLines`
- [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"
- , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"
- ]
+ [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"
+ , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"
+ ]
-kpropAcls :: [String] -> Property NoInfo
+kpropAcls :: [String] -> Property UnixLike
kpropAcls ps = kpropdAclPath `File.hasContent` ps `describe` "kprop server ACLs"
k5srvutil :: (Maybe FilePath) -> [String] -> IO String
@@ -82,13 +82,14 @@ k5loginPath user = do
h <- homedir user
return $ h </> ".k5login"
-k5login :: User -> [Principal] -> Property NoInfo
-k5login user@(User u) ps = property (u ++ " has k5login") $ do
+k5login :: User -> [Principal] -> Property UnixLike
+k5login user@(User u) ps = property' desc $ \w -> do
f <- liftIO $ k5loginPath user
liftIO $ do
createDirectoryIfMissing True (takeDirectory f)
writeFile f (unlines ps)
- ensureProperties
- [ File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ ensureProperty w $ combineProperties desc $ props
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
+ where
+ desc = u ++ " has k5login"
diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs
index d5528c64..bf38046b 100644
--- a/src/Propellor/Property/LetsEncrypt.hs
+++ b/src/Propellor/Property/LetsEncrypt.hs
@@ -7,7 +7,7 @@ import qualified Propellor.Property.Apt as Apt
import System.Posix.Files
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["letsencrypt"]
-- | Tell the letsencrypt client that you agree with the Let's Encrypt
@@ -39,15 +39,16 @@ type WebRoot = FilePath
--
-- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete
-- integration of apache with letsencrypt, that's built on top of this.
-letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property NoInfo
+letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike
letsEncrypt tos domain = letsEncrypt' tos domain []
-- | Like `letsEncrypt`, but the certificate can be obtained for multiple
-- domains.
-letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property NoInfo
+letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike
letsEncrypt' (AgreeTOS memail) domain domains webroot =
prop `requires` installed
where
+ prop :: Property UnixLike
prop = property desc $ do
startstats <- liftIO getstats
(transcript, ok) <- liftIO $
diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs
index 75e3b19a..339fa9a3 100644
--- a/src/Propellor/Property/LightDM.hs
+++ b/src/Propellor/Property/LightDM.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-
-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
module Propellor.Property.LightDM where
@@ -8,11 +6,11 @@ import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.ConfFile as ConfFile
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["lightdm"]
-- | Configures LightDM to skip the login screen and autologin as a user.
-autoLogin :: User -> Property NoInfo
+autoLogin :: User -> Property UnixLike
autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting`
("SeatDefaults", "autologin-user", u)
`describe` "lightdm autologin"
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 74aa6ca6..0eec04c7 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -1,86 +1,59 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Propellor.Property.List (
props,
- PropertyList(..),
- PropertyListType,
- PropList(..),
+ Props,
+ toProps,
+ propertyList,
+ combineProperties,
) where
import Propellor.Types
-import Propellor.Engine
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Propellor.PropAccum
+import Propellor.Engine
+import Propellor.Exception
import Data.Monoid
--- | Starts accumulating a list of properties.
+toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
+toProps ps = Props (map toChildProperty ps)
+
+-- | Combines a list of properties, resulting in a single property
+-- that when run will run each property in the list in turn,
+-- and print out the description of each as it's run. Does not stop
+-- on failure; does propagate overall success/failure.
+--
+-- For example:
--
-- > propertyList "foo" $ props
--- > & someproperty
--- > ! oldproperty
--- > & otherproperty
-props :: PropList
-props = PropList []
-
-data PropList = PropList [Property HasInfo]
-
-instance PropAccum PropList where
- PropList l `addProp` p = PropList (toProp p : l)
- PropList l `addPropFront` p = PropList (l ++ [toProp p])
- getProperties (PropList l) = reverse l
-
-class PropertyList l where
- -- | Combines a list of properties, resulting in a single property
- -- that when run will run each property in the list in turn,
- -- and print out the description of each as it's run. Does not stop
- -- on failure; does propagate overall success/failure.
- --
- -- Note that Property HasInfo and Property NoInfo are not the same
- -- type, and so cannot be mixed in a list. To make a list of
- -- mixed types, which can also include RevertableProperty,
- -- use `props`
- propertyList :: Desc -> l -> Property (PropertyListType l)
-
- -- | Combines a list of properties, resulting in one property that
- -- ensures each in turn. Stops if a property fails.
- combineProperties :: Desc -> l -> Property (PropertyListType l)
-
--- | Type level function to calculate whether a PropertyList has Info.
-type family PropertyListType t
-type instance PropertyListType [Property HasInfo] = HasInfo
-type instance PropertyListType [Property NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty HasInfo] = HasInfo
-type instance PropertyListType PropList = HasInfo
-
-instance PropertyList [Property NoInfo] where
- propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
- combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
-
-instance PropertyList [Property HasInfo] where
- -- It's ok to use ignoreInfo here, because the ps are made the
- -- child properties of the property, and so their info is visible
- -- that way.
- propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
- combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
-
-instance PropertyList [RevertableProperty HasInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList [RevertableProperty NoInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList PropList where
- propertyList desc = propertyList desc . getProperties
- combineProperties desc = combineProperties desc . getProperties
-
-combineSatisfy :: [Property i] -> Result -> Propellor Result
+-- > & bar
+-- > & baz
+propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+propertyList desc (Props ps) =
+ property desc (ensureChildProperties cs)
+ `addChildren` cs
+ where
+ cs = map toChildProperty ps
+
+-- | Combines a list of properties, resulting in one property that
+-- ensures each in turn. Stops if a property fails.
+combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+combineProperties desc (Props ps) =
+ property desc (combineSatisfy cs NoChange)
+ `addChildren` cs
+ where
+ cs = map toChildProperty ps
+
+combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
-combineSatisfy (l:ls) rs = do
- r <- ensureProperty $ ignoreInfo l
+combineSatisfy (p:ps) rs = do
+ r <- catchPropellor $ getSatisfy p
case r of
FailedChange -> return FailedChange
- _ -> combineSatisfy ls (r <> rs)
+ _ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs
index 06cd63ad..b7cf242c 100644
--- a/src/Propellor/Property/Locale.hs
+++ b/src/Propellor/Property/Locale.hs
@@ -21,14 +21,17 @@ type LocaleVariable = String
--
-- Note that reverting this property does not make a locale unavailable. That's
-- because it might be required for other Locale.selectedFor statements.
-selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo
+selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty DebianLike DebianLike
locale `selectedFor` vars = select <!> deselect
where
- select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs)
- `requires` available locale
- `describe` (locale ++ " locale selected")
- deselect = check isselected (cmdProperty "update-locale" vars)
- `describe` (locale ++ " locale deselected")
+ select = tightenTargets $
+ check (not <$> isselected)
+ (cmdProperty "update-locale" selectArgs)
+ `requires` available locale
+ `describe` (locale ++ " locale selected")
+ deselect = tightenTargets $
+ check isselected (cmdProperty "update-locale" vars)
+ `describe` (locale ++ " locale deselected")
selectArgs = zipWith (++) vars (repeat ('=':locale))
isselected = locale `isSelectedFor` vars
@@ -46,20 +49,21 @@ locale `isSelectedFor` vars = do
--
-- Per Debian bug #684134 we cannot ensure a locale is generated by means of
-- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually.
-available :: Locale -> RevertableProperty NoInfo
-available locale = (ensureAvailable <!> ensureUnavailable)
+available :: Locale -> RevertableProperty DebianLike DebianLike
+available locale = ensureAvailable <!> ensureUnavailable
where
f = "/etc/locale.gen"
desc = (locale ++ " locale generated")
- ensureAvailable =
- property desc $ (lines <$> (liftIO $ readFile f))
- >>= \locales ->
- if locale `presentIn` locales
- then ensureProperty $
- fileProperty desc (foldr uncomment []) f
- `onChange` regenerate
- else return FailedChange -- locale unavailable for generation
- ensureUnavailable =
+ ensureAvailable :: Property DebianLike
+ ensureAvailable = property' desc $ \w -> do
+ locales <- lines <$> (liftIO $ readFile f)
+ if locale `presentIn` locales
+ then ensureProperty w $
+ fileProperty desc (foldr uncomment []) f
+ `onChange` regenerate
+ else return FailedChange -- locale unavailable for generation
+ ensureUnavailable :: Property DebianLike
+ ensureUnavailable = tightenTargets $
fileProperty (locale ++ " locale not generated") (foldr comment []) f
`onChange` regenerate
diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs
index 22621cc2..ced9fce2 100644
--- a/src/Propellor/Property/Logcheck.hs
+++ b/src/Propellor/Property/Logcheck.hs
@@ -28,9 +28,9 @@ defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ "
ignoreFilePath :: ReportLevel -> Service -> FilePath
ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n
-ignoreLines :: ReportLevel -> Service -> [String] -> Property NoInfo
+ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike
ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls
`describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")")
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["logcheck"]
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 590cede9..5921755c 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -37,16 +37,17 @@ formatMountOpts (MountOpts []) = "defaults"
formatMountOpts (MountOpts l) = intercalate "," l
-- | Mounts a device.
-mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo
+mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted fs src mnt opts = property (mnt ++ " mounted") $
toResult <$> liftIO (mount fs src mnt opts)
-- | Bind mounts the first directory so its contents also appear
-- in the second directory.
-bindMount :: FilePath -> FilePath -> Property NoInfo
-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
- `assume` MadeChange
- `describe` ("bind mounted " ++ src ++ " to " ++ dest)
+bindMount :: FilePath -> FilePath -> Property Linux
+bindMount src dest = tightenTargets $
+ cmdProperty "mount" ["--bind", src, dest]
+ `assume` MadeChange
+ `describe` ("bind mounted " ++ src ++ " to " ++ dest)
mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount fs src mnt opts = boolSystem "mount" $
@@ -66,10 +67,10 @@ newtype SwapPartition = SwapPartition FilePath
-- and its mount options are all automatically probed.
--
-- The SwapPartitions are also included in the generated fstab.
-fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo
-fstabbed mnts swaps = property "fstabbed" $ do
+fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
+fstabbed mnts swaps = property' "fstabbed" $ \o -> do
fstab <- liftIO $ genFstab mnts swaps id
- ensureProperty $
+ ensureProperty o $
"/etc/fstab" `File.hasContent` fstab
genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]
diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs
index 2464985a..dd74d91b 100644
--- a/src/Propellor/Property/Munin.hs
+++ b/src/Propellor/Property/Munin.hs
@@ -19,19 +19,19 @@ import qualified Propellor.Property.Service as Service
nodePort :: Integer
nodePort = 4949
-nodeInstalled :: Property NoInfo
+nodeInstalled :: Property DebianLike
nodeInstalled = Apt.serviceInstalledRunning "munin-node"
-nodeRestarted :: Property NoInfo
+nodeRestarted :: Property DebianLike
nodeRestarted = Service.restarted "munin-node"
nodeConfPath :: FilePath
nodeConfPath = "/etc/munin/munin-node.conf"
-masterInstalled :: Property NoInfo
+masterInstalled :: Property DebianLike
masterInstalled = Apt.serviceInstalledRunning "munin"
-masterRestarted :: Property NoInfo
+masterRestarted :: Property DebianLike
masterRestarted = Service.restarted "munin"
masterConfPath :: FilePath
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 382f5d9d..9ed9e591 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -7,8 +7,8 @@ import Data.Char
type Interface = String
-ifUp :: Interface -> Property NoInfo
-ifUp iface = cmdProperty "ifup" [iface]
+ifUp :: Interface -> Property DebianLike
+ifUp iface = tightenTargets $ cmdProperty "ifup" [iface]
`assume` MadeChange
-- | Resets /etc/network/interfaces to a clean and empty state,
@@ -18,8 +18,8 @@ ifUp iface = cmdProperty "ifup" [iface]
-- This can be used as a starting point to defining other interfaces.
--
-- No interfaces are brought up or down by this property.
-cleanInterfacesFile :: Property NoInfo
-cleanInterfacesFile = hasContent interfacesFile
+cleanInterfacesFile :: Property DebianLike
+cleanInterfacesFile = tightenTargets $ hasContent interfacesFile
[ "# Deployed by propellor, do not edit."
, ""
, "source-directory interfaces.d"
@@ -31,8 +31,8 @@ cleanInterfacesFile = hasContent interfacesFile
`describe` ("clean " ++ interfacesFile)
-- | Configures an interface to get its address via dhcp.
-dhcp :: Interface -> Property NoInfo
-dhcp iface = hasContent (interfaceDFile iface)
+dhcp :: Interface -> Property DebianLike
+dhcp iface = tightenTargets $ hasContent (interfaceDFile iface)
[ "auto " ++ iface
, "iface " ++ iface ++ " inet dhcp"
]
@@ -50,18 +50,20 @@ dhcp iface = hasContent (interfaceDFile iface)
--
-- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.)
-static :: Interface -> Property NoInfo
-static iface = check (not <$> doesFileExist f) setup
- `describe` desc
- `requires` interfacesDEnabled
+static :: Interface -> Property DebianLike
+static iface = tightenTargets $
+ check (not <$> doesFileExist f) setup
+ `describe` desc
+ `requires` interfacesDEnabled
where
f = interfaceDFile iface
desc = "static " ++ iface
- setup = property desc $ do
+ setup :: Property DebianLike
+ setup = property' desc $ \o -> do
ls <- liftIO $ lines <$> readProcess "ip"
["-o", "addr", "show", iface, "scope", "global"]
stanzas <- liftIO $ concat <$> mapM mkstanza ls
- ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
+ ensureProperty o $ hasContent f $ ("auto " ++ iface) : stanzas
mkstanza ipline = case words ipline of
-- Note that the IP address is written CIDR style, so
-- the netmask does not need to be specified separately.
@@ -81,8 +83,8 @@ static iface = check (not <$> doesFileExist f) setup
_ -> Nothing
-- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property NoInfo
-ipv6to4 = hasContent (interfaceDFile "sit0")
+ipv6to4 :: Property DebianLike
+ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0")
[ "# Deployed by propellor, do not edit."
, "iface sit0 inet6 static"
, "\taddress 2002:5044:5531::1"
@@ -107,6 +109,8 @@ escapeInterfaceDName :: Interface -> FilePath
escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-"))
-- | Ensures that files in the the interfaces.d directory are used.
-interfacesDEnabled :: Property NoInfo
-interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
- `describe` "interfaces.d directory enabled"
+-- interfacesDEnabled :: Property DebianLike
+interfacesDEnabled :: Property DebianLike
+interfacesDEnabled = tightenTargets $
+ containsLine interfacesFile "source-directory interfaces.d"
+ `describe` "interfaces.d directory enabled"
diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs
index 8fb5c49b..e40ba657 100644
--- a/src/Propellor/Property/Nginx.hs
+++ b/src/Propellor/Property/Nginx.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service
type ConfigFile = [String]
-siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo
+siteEnabled :: HostName -> ConfigFile -> RevertableProperty DebianLike DebianLike
siteEnabled hn cf = enable <!> disable
where
enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn
@@ -22,11 +22,11 @@ siteEnabled hn cf = enable <!> disable
`requires` installed
`onChange` reloaded
-siteAvailable :: HostName -> ConfigFile -> Property NoInfo
-siteAvailable hn cf = ("nginx site available " ++ hn) ==>
- siteCfg hn `File.hasContent` (comment : cf)
+siteAvailable :: HostName -> ConfigFile -> Property DebianLike
+siteAvailable hn cf = "nginx site available " ++ hn ==> tightenTargets go
where
comment = "# deployed with propellor, do not modify"
+ go = siteCfg hn `File.hasContent` (comment : cf)
siteCfg :: HostName -> FilePath
siteCfg hn = "/etc/nginx/sites-available/" ++ hn
@@ -37,11 +37,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn
siteValRelativeCfg :: HostName -> File.LinkTarget
siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn)
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["nginx"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "nginx"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "nginx"
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index e5da0921..5a3ccc70 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -46,7 +46,7 @@ import Control.Exception (throw)
-- install succeeds, to bootstrap from the cleanly installed system to
-- a fully working system. For example:
--
--- > & os (System (Debian Unstable) "amd64")
+-- > & osDebian Unstable "amd64"
-- > & cleanInstallOnce (Confirmed "foo.example.com")
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
@@ -64,7 +64,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey"
-- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property NoInfo
+cleanInstallOnce :: Confirmation -> Property Linux
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
@@ -83,14 +83,18 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
`requires`
osbootstrapped
- osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of
- (Just d@(System (Debian _) _)) -> debootstrap d
- (Just u@(System (Buntish _) _)) -> debootstrap u
- _ -> unsupportedOS
+ osbootstrapped :: Property Linux
+ osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
+ (Just d@(System (Debian _) _)) -> ensureProperty w $
+ debootstrap d
+ (Just u@(System (Buntish _) _)) -> ensureProperty w $
+ debootstrap u
+ _ -> unsupportedOS'
- debootstrap targetos = ensureProperty $
- -- Ignore the os setting, and install debootstrap from
- -- source, since we don't know what OS we're running in yet.
+ 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..
@@ -100,6 +104,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- sync instead?
-- This is the fun bit.
+ flipped :: Property Linux
flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
-- First, unmount most mount points, lazily, so
-- they don't interfere with moving things around.
@@ -137,6 +142,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
return MadeChange
+ propellorbootstrapped :: Property UnixLike
propellorbootstrapped = property "propellor re-debootstrapped in new os" $
return NoChange
-- re-bootstrap propellor in /usr/local/propellor,
@@ -145,6 +151,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- be present in /old-os's /usr/local/propellor)
-- TODO
+ finalized :: Property UnixLike
finalized = property "clean OS installed" $ do
liftIO $ writeFile flagfile ""
return MadeChange
@@ -179,7 +186,7 @@ massRename = go []
data Confirmation = Confirmed HostName
-confirmed :: Desc -> Confirmation -> Property NoInfo
+confirmed :: Desc -> Confirmation -> Property UnixLike
confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName
if hostname /= c
@@ -191,25 +198,26 @@ confirmed desc (Confirmed c) = property desc $ do
-- | </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 NoInfo
+preserveNetwork :: Property DebianLike
preserveNetwork = go `requires` Network.cleanInterfacesFile
where
- go = property "preserve network configuration" $ do
+ go :: Property DebianLike
+ go = property' "preserve network configuration" $ \w -> do
ls <- liftIO $ lines <$> readProcess "ip"
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
- ensureProperty $ Network.static iface
+ ensureProperty w $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
-preserveResolvConf :: Property NoInfo
+preserveResolvConf :: Property Linux
preserveResolvConf = check (fileExist oldloc) $
- property (newloc ++ " copied from old OS") $ do
+ property' (newloc ++ " copied from old OS") $ \w -> do
ls <- liftIO $ lines <$> readFile oldloc
- ensureProperty $ newloc `File.hasContent` ls
+ ensureProperty w $ newloc `File.hasContent` ls
where
newloc = "/etc/resolv.conf"
oldloc = oldOSDir ++ newloc
@@ -217,20 +225,23 @@ preserveResolvConf = check (fileExist oldloc) $
-- | </root/.ssh/authorized_keys> has added to it any ssh keys that
-- were authorized in the old OS. Any other contents of the file are
-- retained.
-preserveRootSshAuthorized :: Property NoInfo
+preserveRootSshAuthorized :: Property UnixLike
preserveRootSshAuthorized = check (fileExist oldloc) $
- property (newloc ++ " copied from old OS") $ do
+ property' desc $ \w -> do
ks <- liftIO $ lines <$> readFile oldloc
- ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks)
+ ensureProperty w $ combineProperties desc $
+ toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks
where
+ desc = newloc ++ " copied from old OS"
newloc = "/root/.ssh/authorized_keys"
oldloc = oldOSDir ++ newloc
-- Removes the old OS's backup from </old-os>
-oldOSRemoved :: Confirmation -> Property NoInfo
+oldOSRemoved :: Confirmation -> Property UnixLike
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where
+ go :: Property UnixLike
go = property "old OS backup removed" $ do
liftIO $ removeDirectoryRecursive oldOSDir
return MadeChange
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 666328ac..6d6f4a7f 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -40,7 +40,7 @@ data NumClients = OnlyClient | MultipleClients
-- Since obnam uses a fair amount of system resources, only one obnam
-- backup job will be run at a time. Other jobs will wait their turns to
-- run.
-backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo
+backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike
backup dir crontimes params numclients =
backup' dir crontimes params numclients
`requires` restored dir params
@@ -50,7 +50,7 @@ backup dir crontimes params numclients =
--
-- The gpg secret key will be automatically imported
-- into root's keyring using Propellor.Property.Gpg.keyImported
-backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo
+backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property (HasInfo + DebianLike)
backupEncrypted dir crontimes params numclients keyid =
backup dir crontimes params' numclients
`requires` Gpg.keyImported keyid (User "root")
@@ -58,7 +58,7 @@ backupEncrypted dir crontimes params numclients keyid =
params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
-- | Does a backup, but does not automatically restore.
-backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo
+backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike
backup' dir crontimes params numclients = cronjob `describe` desc
where
desc = dir ++ " backed up by obnam"
@@ -96,11 +96,12 @@ backup' dir crontimes params numclients = cronjob `describe` desc
--
-- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory.
-restored :: FilePath -> [ObnamParam] -> Property NoInfo
-restored dir params = property (dir ++ " restored by obnam") go
- `requires` installed
+restored :: FilePath -> [ObnamParam] -> Property DebianLike
+restored dir params = go `requires` installed
where
- go = ifM (liftIO needsRestore)
+ desc = dir ++ " restored by obnam"
+ go :: Property DebianLike
+ go = property desc $ ifM (liftIO needsRestore)
( do
warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
liftIO restore
@@ -152,5 +153,5 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps)
isKeepParam :: ObnamParam -> Bool
isKeepParam p = "--keep=" `isPrefixOf` p
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["obnam"]
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index 0f73bfb6..0abf38a6 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -16,7 +16,7 @@ import Data.List
--
-- It's probably a good idea to put this property inside a docker or
-- systemd-nspawn container.
-providerFor :: [User] -> HostName -> Maybe Port -> Property HasInfo
+providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike)
providerFor users hn mp = propertyList desc $ props
& Apt.serviceInstalledRunning "apache2"
& apacheconfigured
@@ -24,7 +24,7 @@ providerFor users hn mp = propertyList desc $ props
`onChange` Apache.restarted
& File.fileProperty (desc ++ " configured")
(map setbaseurl) "/etc/simpleid/config.inc"
- & propertyList desc (map identfile users)
+ & propertyList desc (toProps $ map identfile users)
where
baseurl = hn ++ case mp of
Nothing -> ""
@@ -37,7 +37,7 @@ providerFor users hn mp = propertyList desc $ props
| otherwise = l
apacheconfigured = case mp of
- Nothing -> toProp $
+ Nothing -> setupRevertableProperty $
Apache.virtualHost hn (Port 80) "/var/www/html"
Just p -> propertyList desc $ props
& Apache.listenPorts [p]
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 5d6afa9c..bc8a256d 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -153,18 +153,17 @@ data Eep = YesReallyDeleteDiskContents
-- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file.
--
-- This deletes any existing partitions in the disk! Use with EXTREME caution!
-partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo
-partitioned eep disk (PartTable tabletype parts) = property desc $ do
+partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike
+partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
- ensureProperty $ combineProperties desc
- [ parted eep disk partedparams
- , if isdev
+ ensureProperty w $ combineProperties desc $ props
+ & parted eep disk partedparams
+ & if isdev
then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
- ]
where
desc = disk ++ " partitioned"
- formatl devs = combineProperties desc (map format (zip parts devs))
+ formatl devs = combineProperties desc (toProps $ map format (zip parts devs))
partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
format (p, dev) = Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition (partFs p) dev
@@ -193,12 +192,12 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
--
-- Parted is run in script mode, so it will never prompt for input.
-- It is asked to use cylinder alignment for the disk.
-parted :: Eep -> FilePath -> [String] -> Property NoInfo
+parted :: Eep -> FilePath -> [String] -> Property DebianLike
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
`assume` MadeChange
-- | Gets parted installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["parted"]
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index b2f50339..2bf5b927 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -3,6 +3,7 @@
module Propellor.Property.Partition where
import Propellor.Base
+import Propellor.Types.Core
import qualified Propellor.Property.Apt as Apt
import Utility.Applicative
@@ -16,7 +17,7 @@ data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | Linu
data Eep = YesReallyFormatPartition
-- | Formats a partition.
-formatted :: Eep -> Fs -> FilePath -> Property NoInfo
+formatted :: Eep -> Fs -> FilePath -> Property DebianLike
formatted = formatted' []
-- | Options passed to a mkfs.* command when making a filesystem.
@@ -24,7 +25,7 @@ formatted = formatted' []
-- Eg, ["-m0"]
type MkfsOpts = [String]
-formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo
+formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike
formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts'
`assume` MadeChange
`requires` Apt.installed [pkg]
@@ -64,17 +65,18 @@ isLoopDev' f
-- within a disk image file. The resulting loop devices are passed to the
-- property, which can operate on them. Always cleans up after itself,
-- by removing the device maps after the property is run.
-kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
where
- go = property (propertyDesc (mkprop [])) $ do
+ go :: Property DebianLike
+ go = property' (getDesc (mkprop [])) $ \w -> do
cleanup -- idempotency
loopdevs <- liftIO $ kpartxParse
<$> readProcess "kpartx" ["-avs", diskimage]
bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
unless (null bad) $
error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
- r <- ensureProperty (mkprop loopdevs)
+ r <- ensureProperty w (mkprop loopdevs)
cleanup
return r
cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index df244061..45aa4e42 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -12,13 +12,13 @@ import qualified Data.Map as M
import Data.List
import Data.Char
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.serviceInstalledRunning "postfix"
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "postfix"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which
@@ -28,38 +28,39 @@ reloaded = Service.reloaded "postfix"
-- The smarthost may refuse to relay mail on to other domains, without
-- further configuration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen.
-satellite :: Property NoInfo
+satellite :: Property DebianLike
satellite = check (not <$> mainCfIsSet "relayhost") setup
`requires` installed
where
- setup = property "postfix satellite system" $ do
+ desc = "postfix satellite system"
+ setup :: Property DebianLike
+ setup = property' desc $ \w -> do
hn <- asks hostName
let (_, domain) = separate (== '.') hn
- ensureProperties
- [ Apt.reConfigure "postfix"
+ ensureProperty w $ combineProperties desc $ props
+ & Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
, ("postfix/root_address", "string", "root")
, ("postfix/destinations", "string", "localhost")
, ("postfix/mailname", "string", hn)
]
- , mainCf ("relayhost", "smtp." ++ domain)
+ & mainCf ("relayhost", "smtp." ++ domain)
`onChange` reloaded
- ]
-- | Sets up a file by running a property (which the filename is passed
-- to). If the setup property makes a change, postmap will be run on the
-- file, and postfix will be reloaded.
mappedFile
- :: Combines (Property x) (Property NoInfo)
+ :: Combines (Property x) (Property UnixLike)
=> FilePath
-> (FilePath -> Property x)
- -> Property (CInfo x NoInfo)
+ -> CombinedType (Property x) (Property UnixLike)
mappedFile f setup = setup f
`onChange` (cmdProperty "postmap" [f] `assume` MadeChange)
-- | Run newaliases command, which should be done after changing
-- @/etc/aliases@.
-newaliases :: Property NoInfo
+newaliases :: Property UnixLike
newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
(cmdProperty "newaliases" [])
@@ -68,9 +69,9 @@ mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf"
-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.
-mainCf :: (String, String) -> Property NoInfo
+mainCf :: (String, String) -> Property UnixLike
mainCf (name, value) = check notset set
- `describe` ("postfix main.cf " ++ setting)
+ `describe` ("postfix main.cf " ++ setting)
where
setting = name ++ "=" ++ value
notset = (/= Just value) <$> getMainCf name
@@ -105,7 +106,7 @@ mainCfIsSet name = do
--
-- Note that multiline configurations that continue onto the next line
-- are not currently supported.
-dedupMainCf :: Property NoInfo
+dedupMainCf :: Property UnixLike
dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
dedupCf :: [String] -> [String]
@@ -252,7 +253,7 @@ parseServiceLine l = Service
nws = length ws
-- | Enables a `Service` in postfix's `masterCfFile`.
-service :: Service -> RevertableProperty NoInfo
+service :: Service -> RevertableProperty DebianLike DebianLike
service s = (enable <!> disable)
`describe` desc
where
@@ -276,7 +277,7 @@ service s = (enable <!> disable)
-- It would be wise to enable fail2ban, for example:
--
-- > Fail2Ban.jailEnabled "postfix-sasl"
-saslAuthdInstalled :: Property NoInfo
+saslAuthdInstalled :: Property DebianLike
saslAuthdInstalled = setupdaemon
`requires` Service.running "saslauthd"
`requires` postfixgroup
@@ -303,7 +304,7 @@ saslAuthdInstalled = setupdaemon
-- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file.
--
-- The password is taken from the privdata.
-saslPasswdSet :: Domain -> User -> Property HasInfo
+saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike)
saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"
where
go = withPrivData src ctx $ \getpw ->
diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs
index d4fc089a..e60e7848 100644
--- a/src/Propellor/Property/PropellorRepo.hs
+++ b/src/Propellor/Property/PropellorRepo.hs
@@ -11,7 +11,7 @@ import Propellor.Git.Config
--
-- This property is useful when hosts are being updated without using
-- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job.
-hasOriginUrl :: String -> Property NoInfo
+hasOriginUrl :: String -> Property UnixLike
hasOriginUrl u = property ("propellor repo url " ++ u) $ do
curru <- liftIO getRepoUrl
if curru == Just u
diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs
index 47095504..8017be4a 100644
--- a/src/Propellor/Property/Prosody.hs
+++ b/src/Propellor/Property/Prosody.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type Conf = String
-confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo
+confEnabled :: Conf -> ConfigFile -> RevertableProperty DebianLike DebianLike
confEnabled conf cf = enable <!> disable
where
enable = dir `File.isSymlinkedTo` target
@@ -29,9 +29,9 @@ confEnabled conf cf = enable <!> disable
`requires` installed
`onChange` reloaded
-confAvailable :: Conf -> ConfigFile -> Property NoInfo
+confAvailable :: Conf -> ConfigFile -> Property DebianLike
confAvailable conf cf = ("prosody conf available " ++ conf) ==>
- confAvailPath conf `File.hasContent` (comment : cf)
+ tightenTargets (confAvailPath conf `File.hasContent` (comment : cf))
where
comment = "-- deployed with propellor, do not modify"
@@ -41,11 +41,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua"
confValPath :: Conf -> FilePath
confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["prosody"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "prosody"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "prosody"
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 26b85840..5b854fa3 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -2,8 +2,8 @@ module Propellor.Property.Reboot where
import Propellor.Base
-now :: Property NoInfo
-now = cmdProperty "reboot" []
+now :: Property Linux
+now = tightenTargets $ cmdProperty "reboot" []
`assume` MadeChange
`describe` "reboot now"
@@ -14,7 +14,7 @@ now = 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 NoInfo
+atEnd :: Bool -> (Result -> Bool) -> Property Linux
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend
return NoChange
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 0c77df58..b40396de 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -16,7 +16,7 @@ filesUnder d = Pattern (d ++ "/*")
-- | Ensures that the Dest directory exists and has identical contents as
-- the Src directory.
-syncDir :: Src -> Dest -> Property NoInfo
+syncDir :: Src -> Dest -> Property DebianLike
syncDir = syncDirFiltered []
data Filter
@@ -43,7 +43,7 @@ newtype Pattern = Pattern String
-- Rsync checks each name to be transferred against its list of Filter
-- rules, and the first matching one is acted on. If no matching rule
-- is found, the file is processed.
-syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike
syncDirFiltered filters src dest = rsync $
[ "-av"
-- Add trailing '/' to get rsync to sync the Dest directory,
@@ -56,7 +56,7 @@ syncDirFiltered filters src dest = rsync $
, "--quiet"
] ++ map toRsync filters
-rsync :: [String] -> Property NoInfo
+rsync :: [String] -> Property DebianLike
rsync ps = cmdProperty "rsync" ps
`assume` MadeChange
`requires` Apt.installed ["rsync"]
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 64a530bc..729a3749 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
module Propellor.Property.Scheduled
( period
@@ -10,6 +10,7 @@ module Propellor.Property.Scheduled
) where
import Propellor.Base
+import Propellor.Types.Core
import Utility.Scheduled
import Data.Time.Clock
@@ -22,24 +23,24 @@ import qualified Data.Map as M
-- last run.
period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
- lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+ lasttime <- liftIO $ getLastChecked (getDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
if Just t >= nexttime
then do
r <- satisfy
- liftIO $ setLastChecked t (propertyDesc prop)
+ liftIO $ setLastChecked t (getDesc prop)
return r
else noChange
where
schedule = Schedule recurrance AnyTime
- desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
+ desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string.
-periodParse :: Property NoInfo -> String -> Property NoInfo
+periodParse :: (IsProp (Property i)) => Property i -> String -> Property i
periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance
- Nothing -> property "periodParse" $ do
+ Nothing -> adjustPropertySatisfy prop $ \_ -> do
liftIO $ warningMessage $ "failed periodParse: " ++ s
noChange
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 0e96ed4c..46f9e8ef 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -11,17 +11,17 @@ type ServiceName = String
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
-running :: ServiceName -> Property NoInfo
+running :: ServiceName -> Property DebianLike
running = signaled "start" "running"
-restarted :: ServiceName -> Property NoInfo
+restarted :: ServiceName -> Property DebianLike
restarted = signaled "restart" "restarted"
-reloaded :: ServiceName -> Property NoInfo
+reloaded :: ServiceName -> Property DebianLike
reloaded = signaled "reload" "reloaded"
-signaled :: String -> Desc -> ServiceName -> Property NoInfo
-signaled cmd desc svc = p `describe` (desc ++ " " ++ svc)
+signaled :: String -> Desc -> ServiceName -> Property DebianLike
+signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)
where
p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
`assume` NoChange
diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs
index 5c85610b..239bcbeb 100644
--- a/src/Propellor/Property/SiteSpecific/Branchable.hs
+++ b/src/Propellor/Property/SiteSpecific/Branchable.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Sudo as Sudo
-server :: [Host] -> Property HasInfo
+server :: [Host] -> Property (HasInfo + DebianLike)
server hosts = propertyList "branchable server" $ props
& "/etc/timezone" `File.hasContent` ["Etc/UTC"]
& "/etc/locale.gen" `File.containsLines`
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 2932baf7..ce89b94a 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -25,7 +25,7 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h
-autobuilder :: Architecture -> Times -> TimeOut -> Property HasInfo
+autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike)
autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
& Apt.serviceInstalledRunning "cron"
& Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir
@@ -37,6 +37,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
-- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server
-- password used to upload the built image.
+ rsyncpassword :: Property (HasInfo + DebianLike)
rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
property "rsync password" $ getpw $ \pw -> do
have <- liftIO $ catchDefaultIO "" $
@@ -46,7 +47,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
then makeChange $ writeFile pwfile want
else noChange
-tree :: Architecture -> Flavor -> Property HasInfo
+tree :: Architecture -> Flavor -> Property DebianLike
tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& Apt.installed ["git"]
& File.dirExists gitbuilderdir
@@ -66,14 +67,14 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
[ "git clone git://git-annex.branchable.com/ " ++ builddir
]
-buildDepsApt :: Property HasInfo
+buildDepsApt :: Property DebianLike
buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
& Apt.buildDep ["git-annex"]
& buildDepsNoHaskellLibs
& Apt.buildDepIn builddir
`describe` "git-annex source build deps installed"
-buildDepsNoHaskellLibs :: Property NoInfo
+buildDepsNoHaskellLibs :: Property DebianLike
buildDepsNoHaskellLibs = Apt.installed
["git", "rsync", "moreutils", "ca-certificates",
"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@@ -83,8 +84,9 @@ buildDepsNoHaskellLibs = Apt.installed
"libmagic-dev", "alex", "happy", "c2hs"
]
-haskellPkgsInstalled :: String -> Property NoInfo
-haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
+haskellPkgsInstalled :: String -> Property DebianLike
+haskellPkgsInstalled dir = tightenTargets $
+ flagFile go ("/haskellpkgsinstalled")
where
go = userScriptProperty (User builduser)
[ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages"
@@ -93,7 +95,7 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
-- Installs current versions of git-annex's deps from cabal, but only
-- does so once.
-cabalDeps :: Property NoInfo
+cabalDeps :: Property UnixLike
cabalDeps = flagFile go cabalupdated
where
go = userScriptProperty (User builduser)
@@ -101,20 +103,20 @@ cabalDeps = flagFile go cabalupdated
`assume` MadeChange
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
-autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container
-autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout =
- Systemd.container name osver (Chroot.debootstrapped mempty)
- & mkprop osver flavor
+autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)) -> DebianSuite -> Architecture -> Flavor -> Times -> TimeOut -> Systemd.Container
+autoBuilderContainer mkprop suite arch flavor crontime timeout =
+ Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props
+ & mkprop suite arch flavor
& autobuilder arch crontime timeout
where
name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
type Flavor = Maybe String
-standardAutoBuilder :: System -> Flavor -> Property HasInfo
-standardAutoBuilder osver@(System _ arch) flavor =
+standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+standardAutoBuilder suite arch flavor =
propertyList "standard git-annex autobuilder" $ props
- & os osver
+ & osDebian suite arch
& buildDepsApt
& Apt.stdSourcesList
& Apt.unattendedUpgrades
@@ -122,10 +124,10 @@ standardAutoBuilder osver@(System _ arch) flavor =
& User.accountFor (User builduser)
& tree arch flavor
-stackAutoBuilder :: System -> Flavor -> Property HasInfo
-stackAutoBuilder osver@(System _ arch) flavor =
+stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+stackAutoBuilder suite arch flavor =
propertyList "git-annex autobuilder using stack" $ props
- & os osver
+ & osDebian suite arch
& buildDepsNoHaskellLibs
& Apt.stdSourcesList
& Apt.unattendedUpgrades
@@ -134,34 +136,34 @@ stackAutoBuilder osver@(System _ arch) flavor =
& tree arch flavor
& stackInstalled
-stackInstalled :: Property NoInfo
-stackInstalled = withOS "stack installed" $ \o ->
+stackInstalled :: Property Linux
+stackInstalled = withOS "stack installed" $ \w o ->
case o of
(Just (System (Debian (Stable "jessie")) "i386")) ->
- ensureProperty $ manualinstall "i386"
- _ -> ensureProperty $ Apt.installed ["haskell-stack"]
+ ensureProperty w $ manualinstall "i386"
+ _ -> ensureProperty w $ Apt.installed ["haskell-stack"]
where
-- Warning: Using a binary downloaded w/o validation.
- manualinstall arch = check (not <$> doesFileExist binstack) $
- propertyList "stack installed from upstream tarball"
- [ cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
+ 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]
`assume` MadeChange
- , File.dirExists tmpdir
- , cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
+ & File.dirExists tmpdir
+ & cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
`assume` MadeChange
- , cmdProperty "mv" [tmpdir </> "stack", binstack]
+ & cmdProperty "mv" [tmpdir </> "stack", binstack]
`assume` MadeChange
- , cmdProperty "rm" ["-rf", tmpdir, tmptar]
+ & cmdProperty "rm" ["-rf", tmpdir, tmptar]
`assume` MadeChange
- ]
binstack = "/usr/bin/stack"
tmptar = "/root/stack.tar.gz"
tmpdir = "/root/stack"
-armAutoBuilder :: System -> Flavor -> Property HasInfo
-armAutoBuilder osver flavor =
+armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+armAutoBuilder suite arch flavor =
propertyList "arm git-annex autobuilder" $ props
- & standardAutoBuilder osver flavor
+ & standardAutoBuilder suite arch flavor
& buildDepsNoHaskellLibs
-- Works around ghc crash with parallel builds on arm.
& (homedir </> ".cabal" </> "config")
@@ -172,26 +174,30 @@ armAutoBuilder osver flavor =
androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
androidAutoBuilderContainer crontimes timeout =
- androidContainer "android-git-annex-builder" (tree "android" Nothing) builddir
- & Apt.unattendedUpgrades
- & buildDepsNoHaskellLibs
- & autobuilder "android" crontimes timeout
+ androidAutoBuilderContainer' "android-git-annex-builder"
+ (tree "android" Nothing) builddir crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer
- :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
- => Systemd.MachineName
- -> Property i
+androidAutoBuilderContainer'
+ :: Systemd.MachineName
+ -> Property DebianLike
-> FilePath
+ -> Times
+ -> TimeOut
-> Systemd.Container
-androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap
- & Apt.stdSourcesList
- & User.accountFor (User builduser)
- & File.dirExists gitbuilderdir
- & File.ownerGroup homedir (User builduser) (Group builduser)
- & flagFile chrootsetup ("/chrootsetup")
- `requires` setupgitannexdir
- & haskellPkgsInstalled "android"
+androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
+ Systemd.container name $ \d -> bootstrap d $ props
+ & osDebian (Stable "jessie") "i386"
+ & Apt.stdSourcesList
+ & User.accountFor (User builduser)
+ & File.dirExists gitbuilderdir
+ & File.ownerGroup homedir (User builduser) (Group builduser)
+ & flagFile chrootsetup ("/chrootsetup")
+ `requires` setupgitannexdir
+ & haskellPkgsInstalled "android"
+ & Apt.unattendedUpgrades
+ & buildDepsNoHaskellLibs
+ & autobuilder "android" crontimes timeout
where
-- Use git-annex's android chroot setup script, which will install
-- ghc-android and the NDK, all build deps, etc, in the home
@@ -200,5 +206,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name osve
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
`assume` MadeChange
- osver = System (Debian (Stable "jessie")) "i386"
bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index 83a1a16a..f14b5f12 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -5,14 +5,15 @@ import qualified Propellor.Property.Apt as Apt
import Propellor.Property.User
-- | Clones Joey Hess's git home directory, and runs its fixups script.
-installedFor :: User -> Property NoInfo
+installedFor :: User -> Property DebianLike
installedFor user@(User u) = check (not <$> hasGitDir user) $
- property ("githome " ++ u) (go =<< liftIO (homedir user))
- `requires` Apt.installed ["git"]
+ go `requires` Apt.installed ["git"]
where
- go home = do
+ go :: Property DebianLike
+ go = property' ("githome " ++ u) $ \w -> do
+ home <- liftIO (homedir user)
let tmpdir = home </> "githome"
- ensureProperty $ combineProperties "githome setup"
+ ensureProperty w $ combineProperties "githome setup" $ toProps
[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
`assume` MadeChange
, property "moveout" $ makeChange $ void $
diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs
index bb62fba7..b245e444 100644
--- a/src/Propellor/Property/SiteSpecific/IABak.hs
+++ b/src/Propellor/Property/SiteSpecific/IABak.hs
@@ -15,14 +15,14 @@ repo = "https://github.com/ArchiveTeam/IA.BAK/"
userrepo :: String
userrepo = "git@gitlab.com:archiveteam/IA.bak.users.git"
-publicFace :: Property HasInfo
+publicFace :: Property DebianLike
publicFace = propertyList "iabak public face" $ props
& Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server")
& Apt.serviceInstalledRunning "apache2"
& Cron.niceJob "graph-gen" (Cron.Times "*/10 * * * *") (User "root") "/"
"/usr/local/IA.BAK/web/graph-gen.sh"
-gitServer :: [Host] -> Property HasInfo
+gitServer :: [Host] -> Property (HasInfo + DebianLike)
gitServer knownhosts = propertyList "iabak git server" $ props
& Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server")
& Git.cloned (User "root") repo "/usr/local/IA.BAK/client" (Just "master")
@@ -42,7 +42,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props
"/usr/local/IA.BAK"
"./expireemailer"
-registrationServer :: [Host] -> Property HasInfo
+registrationServer :: [Host] -> Property (HasInfo + DebianLike)
registrationServer knownhosts = propertyList "iabak registration server" $ props
& User.accountFor (User "registrar")
& Ssh.userKeys (User "registrar") (Context "IA.bak.users.git") sshKeys
@@ -66,7 +66,7 @@ sshKeys =
[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCoiE+CPiIQyfWnl/E9iKG3eo4QzlH30vi7xAgKolGaTu6qKy4XPtl+8MNm2Dqn9QEYRVyyOT/XH0yP5dRc6uyReT8dBy03MmLkVbj8Q+nKCz5YOMTxrY3sX6RRXU1zVGjeVd0DtC+rKRT7reoCxef42LAJTm8nCyZu/enAuso5qHqBbqulFz2YXEKfU1SEEXLawtvgGck1KmCyg+pqazeI1eHWXrojQf5isTBKfPQLWVppBkWAf5cA4wP5U1vN9dVirIdw66ds1M8vnGlkTBjxP/HLGBWGYhZHE7QXjXRsk2RIXlHN9q6GdNu8+F3HXS22mst47E4UAeRoiXSMMtF5")
]
-graphiteServer :: Property HasInfo
+graphiteServer :: Property (HasInfo + DebianLike)
graphiteServer = propertyList "iabak graphite server" $ props
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["libapache2-mod-wsgi", "graphite-carbon", "graphite-web"]
@@ -114,7 +114,8 @@ graphiteServer = propertyList "iabak graphite server" $ props
, "</VirtualHost>"
]
where
+ graphiteCSRF :: Property (HasInfo + DebianLike)
graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $
- \gettoken -> property "graphite-web CSRF token" $
- gettoken $ \token -> ensureProperty $ File.containsLine
+ \gettoken -> property' "graphite-web CSRF token" $ \w ->
+ gettoken $ \token -> ensureProperty w $ File.containsLine
"/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 03f2efcb..0ce64939 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -1,6 +1,8 @@
-- | Specific configuration for Joey Hess's sites. Probably not useful to
-- others except as an example.
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
module Propellor.Property.SiteSpecific.JoeySites where
import Propellor.Base
@@ -24,7 +26,7 @@ import Data.List
import System.Posix.Files
import Data.String.Utils
-scrollBox :: Property HasInfo
+scrollBox :: Property (HasInfo + DebianLike)
scrollBox = propertyList "scroll server" $ props
& User.accountFor (User "scroll")
& Git.cloned (User "scroll") "git://git.kitenet.net/scroll" (d </> "scroll") Nothing
@@ -94,16 +96,12 @@ scrollBox = propertyList "scroll server" $ props
s = d </> "login.sh"
g = d </> "game.sh"
-oldUseNetServer :: [Host] -> Property HasInfo
+oldUseNetServer :: [Host] -> Property (HasInfo + DebianLike)
oldUseNetServer hosts = propertyList "olduse.net server" $ props
& Apt.installed ["leafnode"]
& oldUseNetInstalled "oldusenet-server"
& oldUseNetBackup
- & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
- (property "olduse.net spool in place" $ makeChange $ do
- removeDirectoryRecursive newsspool
- createSymbolicLink (datadir </> "news") newsspool
- )
+ & spoolsymlink
& "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire
@@ -135,7 +133,15 @@ 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
+ removeDirectoryRecursive newsspool
+ createSymbolicLink (datadir </> "news") newsspool
+ )
+ oldUseNetBackup :: Property (HasInfo + DebianLike)
oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *")
[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
, "--client-name=spool"
@@ -149,12 +155,12 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root")
keyfile = "/root/.ssh/olduse.net.key"
-oldUseNetShellBox :: Property HasInfo
+oldUseNetShellBox :: Property DebianLike
oldUseNetShellBox = propertyList "olduse.net shellbox" $ props
& oldUseNetInstalled "oldusenet"
& Service.running "shellinabox"
-oldUseNetInstalled :: Apt.Package -> Property HasInfo
+oldUseNetInstalled :: Apt.Package -> Property DebianLike
oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
propertyList ("olduse.net " ++ pkg) $ props
& Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
@@ -170,25 +176,25 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
]
`assume` MadeChange
`describe` "olduse.net built"
-
-kgbServer :: Property HasInfo
+
+kgbServer :: Property (HasInfo + Debian)
kgbServer = propertyList desc $ props
& installed
& File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
`onChange` Service.restarted "kgb-bot"
where
desc = "kgb.kitenet.net setup"
- installed = withOS desc $ \o -> case o of
+ installed :: Property Debian
+ installed = withOS desc $ \w o -> case o of
(Just (System (Debian Unstable) _)) ->
- ensureProperty $ propertyList desc
- [ Apt.serviceInstalledRunning "kgb-bot"
- , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
+ ensureProperty w $ propertyList desc $ props
+ & Apt.serviceInstalledRunning "kgb-bot"
+ & "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
`describe` "kgb bot enabled"
`onChange` Service.running "kgb-bot"
- ]
_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
-mumbleServer :: [Host] -> Property HasInfo
+mumbleServer :: [Host] -> Property (HasInfo + DebianLike)
mumbleServer hosts = combineProperties hn $ props
& Apt.serviceInstalledRunning "mumble-server"
& Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *")
@@ -209,7 +215,7 @@ mumbleServer hosts = combineProperties hn $ props
sshkey = "/root/.ssh/mumble.debian.net.key"
-- git.kitenet.net and git.joeyh.name
-gitServer :: [Host] -> Property HasInfo
+gitServer :: [Host] -> Property (HasInfo + DebianLike)
gitServer hosts = propertyList "git.kitenet.net setup" $ props
& Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *")
[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
@@ -266,7 +272,7 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props
type AnnexUUID = String
-- | A website, with files coming from a git-annex repository.
-annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo
+annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property (HasInfo + DebianLike)
annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props
& Git.cloned (User "joey") origin dir Nothing
`onChange` setup
@@ -308,7 +314,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, " </Directory>"
]
-apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo
+apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty DebianLike DebianLike
apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle
apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
@@ -348,7 +354,7 @@ mainhttpscert True =
, " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
]
-gitAnnexDistributor :: Property HasInfo
+gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
& Apt.installed ["rsync"]
& File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
@@ -364,19 +370,18 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
-- git-annex distribution signing key
& Gpg.keyImported (Gpg.GpgKeyId "89C809CB") (User "joey")
where
- endpoint d = combineProperties ("endpoint " ++ d)
- [ File.dirExists d
- , File.ownerGroup d (User "joey") (Group "joey")
- ]
+ endpoint d = combineProperties ("endpoint " ++ d) $ props
+ & File.dirExists d
+ & File.ownerGroup d (User "joey") (Group "joey")
-downloads :: [Host] -> Property HasInfo
+downloads :: [Host] -> Property (HasInfo + DebianLike)
downloads hosts = annexWebSite "/srv/git/downloads.git"
"downloads.kitenet.net"
"840760dc-08f0-11e2-8c61-576b7e66acfd"
[("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")]
`requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey")
-tmp :: Property HasInfo
+tmp :: Property (HasInfo + DebianLike)
tmp = propertyList "tmp.kitenet.net" $ props
& annexWebSite "/srv/git/joey/tmp.git"
"tmp.kitenet.net"
@@ -386,7 +391,7 @@ tmp = propertyList "tmp.kitenet.net" $ props
& pumpRss
-- Twitter, you kill us.
-twitRss :: Property HasInfo
+twitRss :: Property DebianLike
twitRss = combineProperties "twitter rss" $ props
& Git.cloned (User "joey") "git://git.kitenet.net/twitrss.git" dir Nothing
& check (not <$> doesFileExist (dir </> "twitRss")) compiled
@@ -409,11 +414,11 @@ twitRss = combineProperties "twitter rss" $ props
]
-- Work around for expired ssl cert.
-pumpRss :: Property NoInfo
+pumpRss :: Property DebianLike
pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/"
"wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
-ircBouncer :: Property HasInfo
+ircBouncer :: Property (HasInfo + DebianLike)
ircBouncer = propertyList "IRC bouncer" $ props
& Apt.installed ["znc"]
& User.accountFor (User "znc")
@@ -428,20 +433,19 @@ ircBouncer = propertyList "IRC bouncer" $ props
where
conf = "/home/znc/.znc/configs/znc.conf"
-kiteShellBox :: Property NoInfo
-kiteShellBox = propertyList "kitenet.net shellinabox"
- [ Apt.installed ["openssl", "shellinabox", "openssh-client"]
- , File.hasContent "/etc/default/shellinabox"
+kiteShellBox :: Property DebianLike
+kiteShellBox = propertyList "kitenet.net shellinabox" $ props
+ & Apt.installed ["openssl", "shellinabox", "openssh-client"]
+ & File.hasContent "/etc/default/shellinabox"
[ "# Deployed by propellor"
, "SHELLINABOX_DAEMON_START=1"
, "SHELLINABOX_PORT=443"
, "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\""
]
`onChange` Service.restarted "shellinabox"
- , Service.running "shellinabox"
- ]
+ & Service.running "shellinabox"
-githubBackup :: Property HasInfo
+githubBackup :: Property (HasInfo + DebianLike)
githubBackup = propertyList "github-backup box" $ props
& Apt.installed ["github-backup", "moreutils"]
& githubKeys
@@ -462,7 +466,7 @@ githubBackup = propertyList "github-backup box" $ props
] ++ map gitriddance githubMirrors
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
-githubKeys :: Property HasInfo
+githubKeys :: Property (HasInfo + UnixLike)
githubKeys =
let f = "/home/joey/.github-keys"
in File.hasPrivContent f anyContext
@@ -482,12 +486,12 @@ githubMirrors =
where
plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess"
-rsyncNetBackup :: [Host] -> Property NoInfo
+rsyncNetBackup :: [Host] -> Property DebianLike
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *")
(User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "joey")
-backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property NoInfo
+backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property DebianLike
backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc
(Cron.Times "@reboot") (User "joey") "/" cmd
`requires` Ssh.knownHost hosts srchost (User "joey")
@@ -495,9 +499,9 @@ backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc
desc = "backups copied from " ++ srchost ++ " on boot"
cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir </> srchost
-obnamRepos :: [String] -> Property NoInfo
-obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
- (mkbase : map mkrepo rs)
+obnamRepos :: [String] -> Property UnixLike
+obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $
+ toProps (mkbase : map mkrepo rs)
where
mkbase = mkdir "/home/joey/lib/backup"
`requires` mkdir "/home/joey/lib"
@@ -505,13 +509,13 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
mkdir d = File.dirExists d
`before` File.ownerGroup d (User "joey") (Group "joey")
-podcatcher :: Property NoInfo
+podcatcher :: Property DebianLike
podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *")
(User "joey") "/home/joey/lib/sound/podcasts"
"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
`requires` Apt.installed ["git-annex", "myrepos"]
-kiteMailServer :: Property HasInfo
+kiteMailServer :: Property (HasInfo + DebianLike)
kiteMailServer = propertyList "kitenet.net mail server" $ props
& Postfix.installed
& Apt.installed ["postfix-pcre"]
@@ -710,7 +714,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
-- Configures postfix to relay outgoing mail to kitenet.net, with
-- verification via tls cert.
-postfixClientRelay :: Context -> Property HasInfo
+postfixClientRelay :: Context -> Property (HasInfo + DebianLike)
postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
-- Using smtps not smtp because more networks firewall smtp
[ "relayhost = kitenet.net:smtps"
@@ -727,7 +731,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
`requires` hasPostfixCert ctx
-- Configures postfix to have the dkim milter, and no other milters.
-dkimMilter :: Property HasInfo
+dkimMilter :: Property (HasInfo + DebianLike)
dkimMilter = Postfix.mainCfFile `File.containsLines`
[ "smtpd_milters = inet:localhost:8891"
, "non_smtpd_milters = inet:localhost:8891"
@@ -740,7 +744,7 @@ dkimMilter = Postfix.mainCfFile `File.containsLines`
-- This does not configure postfix to use the dkim milter,
-- nor does it set up domainkey DNS.
-dkimInstalled :: Property HasInfo
+dkimInstalled :: Property (HasInfo + DebianLike)
dkimInstalled = go `onChange` Service.restarted "opendkim"
where
go = propertyList "opendkim installed" $ props
@@ -763,17 +767,16 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
-hasJoeyCAChain :: Property HasInfo
+hasJoeyCAChain :: Property (HasInfo + UnixLike)
hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
Context "joeyca.pem"
-hasPostfixCert :: Context -> Property HasInfo
-hasPostfixCert ctx = combineProperties "postfix tls cert installed"
- [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
- , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
- ]
+hasPostfixCert :: Context -> Property (HasInfo + UnixLike)
+hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props
+ & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
+ & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
-kitenetHttps :: Property HasInfo
+kitenetHttps :: Property (HasInfo + DebianLike)
kitenetHttps = propertyList "kitenet.net https certs" $ props
& File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
& File.hasPrivContent "/etc/ssl/private/web.pem" ctx
@@ -784,7 +787,7 @@ kitenetHttps = propertyList "kitenet.net https certs" $ props
-- Legacy static web sites and redirections from kitenet.net to newer
-- sites.
-legacyWebSites :: Property HasInfo
+legacyWebSites :: Property (HasInfo + DebianLike)
legacyWebSites = propertyList "legacy web sites" $ props
& Apt.serviceInstalledRunning "apache2"
& Apache.modEnabled "rewrite"
@@ -944,7 +947,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
-userDirHtml :: Property NoInfo
+userDirHtml :: Property DebianLike
userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
`onChange` Apache.reloaded
`requires` Apache.modEnabled "userdir"
@@ -956,10 +959,9 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
-- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/>
--
-- oncalendar example value: "*-*-* 7:30"
-alarmClock :: String -> User -> String -> Property NoInfo
-alarmClock oncalendar (User user) command = combineProperties
- "goodmorning timer installed"
- [ "/etc/systemd/system/goodmorning.timer" `File.hasContent`
+alarmClock :: String -> User -> String -> Property DebianLike
+alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props
+ & "/etc/systemd/system/goodmorning.timer" `File.hasContent`
[ "[Unit]"
, "Description=good morning"
, ""
@@ -974,7 +976,7 @@ alarmClock oncalendar (User user) command = combineProperties
]
`onChange` (Systemd.daemonReloaded
`before` Systemd.restarted "goodmorning.timer")
- , "/etc/systemd/system/goodmorning.service" `File.hasContent`
+ & "/etc/systemd/system/goodmorning.service" `File.hasContent`
[ "[Unit]"
, "Description=good morning"
, "RefuseManualStart=true"
@@ -987,8 +989,7 @@ alarmClock oncalendar (User user) command = combineProperties
, "ExecStart=/bin/systemd-inhibit --what=handle-lid-switch --why=goodmorning /bin/su " ++ user ++ " -c \"" ++ command ++ "\""
]
`onChange` Systemd.daemonReloaded
- , Systemd.enabled "goodmorning.timer"
- , Systemd.started "goodmorning.timer"
- , "/etc/systemd/logind.conf" `ConfFile.containsIniSetting`
+ & Systemd.enabled "goodmorning.timer"
+ & Systemd.started "goodmorning.timer"
+ & "/etc/systemd/logind.conf" `ConfFile.containsIniSetting`
("Login", "LidSwitchIgnoreInhibited", "no")
- ]
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 26cdbeb7..6e1690d2 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}
module Propellor.Property.Ssh (
installed,
@@ -47,10 +47,13 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-installed :: Property NoInfo
-installed = Apt.installed ["ssh"]
+installed :: Property UnixLike
+installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS)
+ where
+ aptinstall :: Property DebianLike
+ aptinstall = Apt.installed ["ssh"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "ssh"
sshBool :: Bool -> String
@@ -62,10 +65,10 @@ sshdConfig = "/etc/ssh/sshd_config"
type ConfigKeyword = String
-setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo
+setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
-setSshdConfig :: ConfigKeyword -> String -> Property NoInfo
+setSshdConfig :: ConfigKeyword -> String -> Property DebianLike
setSshdConfig setting val = File.fileProperty desc f sshdConfig
`onChange` restarted
where
@@ -84,19 +87,19 @@ data RootLogin
| WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods
| ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key
-permitRootLogin :: RootLogin -> Property NoInfo
+permitRootLogin :: RootLogin -> Property DebianLike
permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b
permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password"
permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only"
-passwordAuthentication :: Bool -> Property NoInfo
+passwordAuthentication :: Bool -> Property DebianLike
passwordAuthentication = setSshdConfigBool "PasswordAuthentication"
-- | Configure ssh to not allow password logins.
--
-- To prevent lock-out, this is done only once root's
-- authorized_keys is in place.
-noPasswords :: Property NoInfo
+noPasswords :: Property DebianLike
noPasswords = check (hasAuthorizedKeys (User "root")) $
passwordAuthentication False
@@ -114,7 +117,7 @@ dotFile f user = do
-- ports it is configured to listen on.
--
-- Revert to prevent it listening on a particular port.
-listenPort :: Port -> RevertableProperty NoInfo
+listenPort :: Port -> RevertableProperty DebianLike DebianLike
listenPort port = enable <!> disable
where
portline = "Port " ++ fromPort port
@@ -133,16 +136,17 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys"
-- | Blows away existing host keys and make new ones.
-- Useful for systems installed from an image that might reuse host keys.
-- A flag file is used to only ever do this once.
-randomHostKeys :: Property NoInfo
+randomHostKeys :: Property DebianLike
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restarted
where
- prop = property "ssh random host keys" $ do
+ prop :: Property UnixLike
+ prop = property' "ssh random host keys" $ \w -> do
void $ liftIO $ boolSystem "sh"
[ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*"
]
- ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
+ ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
`assume` MadeChange
-- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI"
@@ -153,43 +157,51 @@ type PubKeyText = String
-- The corresponding private keys come from the privdata.
--
-- Any host keys that are not in the list are removed from the host.
-hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
-hostKeys ctx l = propertyList desc $ catMaybes $
- map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike)
+hostKeys ctx l = go `before` cleanup
where
desc = "ssh host keys configured " ++ typelist (map fst l)
+ go :: Property (HasInfo + DebianLike)
+ go = propertyList desc $ toProps $ catMaybes $
+ map (\(t, pub) -> Just $ hostKey ctx t pub) l
typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")"
alltypes = [minBound..maxBound]
staletypes = let have = map fst l in filter (`notElem` have) alltypes
- removestale b = map (File.notPresent . flip keyFile b) staletypes
+ removestale :: Bool -> [Property DebianLike]
+ removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
+ cleanup :: Property DebianLike
cleanup
- | null staletypes || null l = Nothing
- | otherwise = Just $ toProp $
- property ("any other ssh host keys removed " ++ typelist staletypes) $
- ensureProperty $
- combineProperties desc (removestale True ++ removestale False)
- `onChange` restarted
+ | null staletypes || null l = doNothing
+ | otherwise =
+ combineProperties ("any other ssh host keys removed " ++ typelist staletypes)
+ (toProps $ removestale True ++ removestale False)
+ `onChange` restarted
-- | Installs a single ssh host key of a particular type.
--
-- The public key is provided to this function;
-- the private key comes from the privdata;
-hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
-hostKey context keytype pub = combineProperties desc
- [ hostPubKey keytype pub
- , toProp $ property desc $ install File.hasContent True (lines pub)
- , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
- property desc $ getkey $
- install File.hasContentProtected False . privDataLines
- ]
- `onChange` restarted
+hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike)
+hostKey context keytype pub = go `onChange` restarted
where
+ go = combineProperties desc $ props
+ & hostPubKey keytype pub
+ & installpub
+ & installpriv
desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
- install writer ispub keylines = do
- let f = keyFile keytype ispub
- ensureProperty $ writer f (keyFileContent keylines)
keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
+ installpub :: Property UnixLike
+ installpub = keywriter File.hasContent True (lines pub)
+ installpriv :: Property (HasInfo + UnixLike)
+ installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
+ property' desc $ \w -> getkey $
+ ensureProperty w
+ . keywriter File.hasContentProtected False
+ . privDataLines
+ keywriter p ispub keylines = do
+ let f = keyFile keytype ispub
+ p f (keyFileContent keylines)
-- Make sure that there is a newline at the end;
-- ssh requires this for some types of private keys.
@@ -204,7 +216,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
-- | Indicates the host key that is used by a Host, but does not actually
-- configure the host to use it. Normally this does not need to be used;
-- use 'hostKey' instead.
-hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo
+hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike)
hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
@@ -224,7 +236,7 @@ instance Monoid HostKeyInfo where
-- parameter when there is a duplicate key
HostKeyInfo (new `M.union` old)
-userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo
+userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike)
userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $
UserKeyInfo (M.singleton u (S.fromList l))
@@ -248,8 +260,8 @@ instance Monoid UserKeyInfo where
--
-- The public keys are added to the Info, so other properties like
-- `authorizedKeysFrom` can use them.
-userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
-userKeys user@(User name) context ks = combineProperties desc $
+userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike)
+userKeys user@(User name) context ks = combineProperties desc $ toProps $
userPubKeys user ks : map (userKeyAt Nothing user context) ks
where
desc = unwords
@@ -264,7 +276,7 @@ userKeys user@(User name) context ks = combineProperties desc $
-- A file can be specified to write the key to somewhere other than
-- the default locations. Allows a user to have multiple keys for
-- different roles.
-userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo
+userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike)
userKeyAt dest user@(User u) context (keytype, pubkeytext) =
combineProperties desc $ props
& pubkey
@@ -276,17 +288,21 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) =
, dest
, Just $ "(" ++ fromKeyType keytype ++ ")"
]
- pubkey = property desc $ install File.hasContent ".pub" [pubkeytext]
- privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
- property desc $ getkey $
- install File.hasContentProtected "" . privDataLines
- install writer ext key = do
+ pubkey :: Property UnixLike
+ pubkey = property' desc $ \w ->
+ ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext]
+ privkey :: Property (HasInfo + UnixLike)
+ privkey = withPrivData (SshPrivKey keytype u) context privkey'
+ privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike)
+ privkey' getkey = property' desc $ \w -> getkey $ \k ->
+ ensureProperty w
+ =<< installprop File.hasContentProtected "" (privDataLines k)
+ installprop writer ext key = do
f <- liftIO $ keyfile ext
- ensureProperty $ combineProperties desc
- [ writer f (keyFileContent key)
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ return $ combineProperties desc $ props
+ & writer f (keyFileContent key)
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
keyfile ext = case dest of
Nothing -> do
home <- homeDirectory <$> getUserEntryForName u
@@ -301,33 +317,34 @@ fromKeyType SshEd25519 = "ed25519"
-- | Puts some host's ssh public key(s), as set using `hostPubKey`
-- or `hostKey` into the known_hosts file for a user.
-knownHost :: [Host] -> HostName -> User -> Property NoInfo
-knownHost hosts hn user@(User u) = property desc $
- go =<< knownHostLines hosts hn
+knownHost :: [Host] -> HostName -> User -> Property UnixLike
+knownHost hosts hn user@(User u) = property' desc $ \w ->
+ go w =<< knownHostLines hosts hn
where
desc = u ++ " knows ssh key for " ++ hn
- go [] = do
+ go _ [] = do
warningMessage $ "no configured ssh host keys for " ++ hn
return FailedChange
- go ls = do
+ go w ls = do
f <- liftIO $ dotFile "known_hosts" user
- modKnownHost user f $
+ ensureProperty w $ modKnownHost user f $
f `File.containsLines` ls
`requires` File.dirExists (takeDirectory f)
-- | Reverts `knownHost`
-unknownHost :: [Host] -> HostName -> User -> Property NoInfo
-unknownHost hosts hn user@(User u) = property desc $
- go =<< knownHostLines hosts hn
+unknownHost :: [Host] -> HostName -> User -> Property UnixLike
+unknownHost hosts hn user@(User u) = property' desc $ \w ->
+ go w =<< knownHostLines hosts hn
where
desc = u ++ " does not know ssh key for " ++ hn
- go [] = return NoChange
- go ls = do
+ go _ [] = return NoChange
+ go w ls = do
f <- liftIO $ dotFile "known_hosts" user
ifM (liftIO $ doesFileExist f)
- ( modKnownHost user f $ f `File.lacksLines` ls
+ ( ensureProperty w $ modKnownHost user f $
+ f `File.lacksLines` ls
, return NoChange
)
@@ -337,8 +354,8 @@ knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey
keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m)
keylines Nothing = []
-modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result
-modKnownHost user f p = ensureProperty $ p
+modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike
+modKnownHost user f p = p
`requires` File.ownerGroup f user (userGroup user)
`requires` File.ownerGroup (takeDirectory f) user (userGroup user)
@@ -348,30 +365,30 @@ modKnownHost user f p = ensureProperty $ p
-- The ssh keys of the remote user can be set using `keysImported`
--
-- Any other lines in the authorized_keys file are preserved as-is.
-authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
- property desc (go =<< authorizedKeyLines remoteuser remotehost)
+ property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
desc = ln ++ " authorized_keys from " ++ remote
- go [] = do
+ go _ [] = do
warningMessage $ "no configured ssh user keys for " ++ remote
return FailedChange
- go ls = ensureProperty $ combineProperties desc $
- map (authorizedKey localuser) ls
+ go w ls = ensureProperty w $ combineProperties desc $ toProps $
+ map (setupRevertableProperty . authorizedKey localuser) ls
-- | Reverts `authorizedKeysFrom`
-unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) =
- property desc (go =<< authorizedKeyLines remoteuser remotehost)
+ property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
desc = ln ++ " unauthorized_keys from " ++ remote
- go [] = return NoChange
- go ls = ensureProperty $ combineProperties desc $
- map (revert . authorizedKey localuser) ls
+ go _ [] = return NoChange
+ go w ls = ensureProperty w $ combineProperties desc $ toProps $
+ map (undoRevertableProperty . authorizedKey localuser) ls
authorizedKeyLines :: User -> Host -> Propellor [File.Line]
authorizedKeyLines remoteuser remotehost =
@@ -380,37 +397,37 @@ authorizedKeyLines remoteuser remotehost =
-- | Makes a user have authorized_keys from the PrivData
--
-- This removes any other lines from the file.
-authorizedKeys :: IsContext c => User -> c -> Property HasInfo
+authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike)
authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get ->
- property desc $ get $ \v -> do
+ property' desc $ \w -> get $ \v -> do
f <- liftIO $ dotFile "authorized_keys" user
- ensureProperty $ combineProperties desc
- [ File.hasContentProtected f (keyFileContent (privDataLines v))
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ ensureProperty w $ combineProperties desc $ props
+ & File.hasContentProtected f (keyFileContent (privDataLines v))
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
where
desc = u ++ " has authorized_keys"
-- | Ensures that a user's authorized_keys contains a line.
-- Any other lines in the file are preserved as-is.
-authorizedKey :: User -> String -> RevertableProperty NoInfo
+authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike
authorizedKey user@(User u) l = add <!> remove
where
- add = property (u ++ " has authorized_keys") $ do
+ add = property' (u ++ " has authorized_keys") $ \w -> do
f <- liftIO $ dotFile "authorized_keys" user
- modAuthorizedKey f user $
+ ensureProperty w $ modAuthorizedKey f user $
f `File.containsLine` l
`requires` File.dirExists (takeDirectory f)
- remove = property (u ++ " lacks authorized_keys") $ do
+ remove = property' (u ++ " lacks authorized_keys") $ \w -> do
f <- liftIO $ dotFile "authorized_keys" user
ifM (liftIO $ doesFileExist f)
- ( modAuthorizedKey f user $ f `File.lacksLine` l
+ ( ensureProperty w $ modAuthorizedKey f user $
+ f `File.lacksLine` l
, return NoChange
)
-modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result
-modAuthorizedKey f user p = ensureProperty $ p
+modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike
+modAuthorizedKey f user p = p
`before` File.mode f (combineModes [ownerWriteMode, ownerReadMode])
`before` File.ownerGroup f user (userGroup user)
`before` File.ownerGroup (takeDirectory f) user (userGroup user)
diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs
index ed6ba2d5..45ab8af2 100644
--- a/src/Propellor/Property/Sudo.hs
+++ b/src/Propellor/Property/Sudo.hs
@@ -9,12 +9,13 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user.
-enabledFor :: User -> Property NoInfo
-enabledFor user@(User u) = property desc go `requires` Apt.installed ["sudo"]
+enabledFor :: User -> Property DebianLike
+enabledFor user@(User u) = go `requires` Apt.installed ["sudo"]
where
- go = do
+ go :: Property UnixLike
+ go = property' desc $ \w -> do
locked <- liftIO $ isLockedPassword user
- ensureProperty $
+ ensureProperty w $
fileProperty desc
(modify locked . filter (wanted locked))
"/etc/sudoers"
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 2234ad5c..e0b7d572 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
module Propellor.Property.Systemd (
-- * Services
@@ -25,6 +25,7 @@ module Propellor.Property.Systemd (
MachineName,
Container,
container,
+ debContainer,
nspawned,
-- * Container configuration
containerCfg,
@@ -43,6 +44,7 @@ module Propellor.Property.Systemd (
import Propellor.Base
import Propellor.Types.Chroot
import Propellor.Types.Container
+import Propellor.Container
import Propellor.Types.Info
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Apt as Apt
@@ -61,23 +63,23 @@ type MachineName = String
data Container = Container MachineName Chroot.Chroot Host
deriving (Show)
-instance PropAccum Container where
- (Container n c h) `addProp` p = Container n c (h `addProp` p)
- (Container n c h) `addPropFront` p = Container n c (h `addPropFront` p)
- getProperties (Container _ _ h) = hostProperties h
+instance IsContainer Container where
+ containerProperties (Container _ _ h) = containerProperties h
+ containerInfo (Container _ _ h) = containerInfo h
+ setContainerProperties (Container n c h) ps = Container n c (setContainerProperties h ps)
-- | Starts a systemd service.
--
-- Note that this does not configure systemd to start the service on boot,
-- it only ensures that the service is currently running.
-started :: ServiceName -> Property NoInfo
-started n = cmdProperty "systemctl" ["start", n]
+started :: ServiceName -> Property Linux
+started n = tightenTargets $ cmdProperty "systemctl" ["start", n]
`assume` NoChange
`describe` ("service " ++ n ++ " started")
-- | Stops a systemd service.
-stopped :: ServiceName -> Property NoInfo
-stopped n = cmdProperty "systemctl" ["stop", n]
+stopped :: ServiceName -> Property Linux
+stopped n = tightenTargets $ cmdProperty "systemctl" ["stop", n]
`assume` NoChange
`describe` ("service " ++ n ++ " stopped")
@@ -85,35 +87,35 @@ stopped n = cmdProperty "systemctl" ["stop", n]
--
-- This does not ensure the service is started, it only configures systemd
-- to start it on boot.
-enabled :: ServiceName -> Property NoInfo
-enabled n = cmdProperty "systemctl" ["enable", n]
+enabled :: ServiceName -> Property Linux
+enabled n = tightenTargets $ cmdProperty "systemctl" ["enable", n]
`assume` NoChange
`describe` ("service " ++ n ++ " enabled")
-- | Disables a systemd service.
-disabled :: ServiceName -> Property NoInfo
-disabled n = cmdProperty "systemctl" ["disable", n]
+disabled :: ServiceName -> Property Linux
+disabled n = tightenTargets $ cmdProperty "systemctl" ["disable", n]
`assume` NoChange
`describe` ("service " ++ n ++ " disabled")
-- | Masks a systemd service.
-masked :: ServiceName -> RevertableProperty NoInfo
+masked :: ServiceName -> RevertableProperty Linux Linux
masked n = systemdMask <!> systemdUnmask
where
- systemdMask = cmdProperty "systemctl" ["mask", n]
+ systemdMask = tightenTargets $ cmdProperty "systemctl" ["mask", n]
`assume` NoChange
`describe` ("service " ++ n ++ " masked")
- systemdUnmask = cmdProperty "systemctl" ["unmask", n]
+ systemdUnmask = tightenTargets $ cmdProperty "systemctl" ["unmask", n]
`assume` NoChange
`describe` ("service " ++ n ++ " unmasked")
-- | Ensures that a service is both enabled and started
-running :: ServiceName -> Property NoInfo
+running :: ServiceName -> Property Linux
running n = started n `requires` enabled n
-- | Restarts a systemd service.
-restarted :: ServiceName -> Property NoInfo
-restarted n = cmdProperty "systemctl" ["restart", n]
+restarted :: ServiceName -> Property Linux
+restarted n = tightenTargets $ cmdProperty "systemctl" ["restart", n]
`assume` NoChange
`describe` ("service " ++ n ++ " restarted")
@@ -126,16 +128,15 @@ journald :: ServiceName
journald = "systemd-journald"
-- | Enables persistent storage of the journal.
-persistentJournal :: Property NoInfo
+persistentJournal :: Property DebianLike
persistentJournal = check (not <$> doesDirectoryExist dir) $
- combineProperties "persistent systemd journal"
- [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
+ combineProperties "persistent systemd journal" $ props
+ & cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
`assume` MadeChange
- , cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir]
+ & Apt.installed ["acl"]
+ & cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir]
`assume` MadeChange
- , started "systemd-journal-flush"
- ]
- `requires` Apt.installed ["acl"]
+ & started "systemd-journal-flush"
where
dir = "/var/log/journal"
@@ -148,11 +149,10 @@ type Option = String
-- currently the case for files like journald.conf and system.conf.
-- And it assumes the file already exists with
-- the right [Header], so new lines can just be appended to the end.
-configured :: FilePath -> Option -> String -> Property NoInfo
-configured cfgfile option value = combineProperties desc
- [ File.fileProperty desc (mapMaybe removeother) cfgfile
- , File.containsLine cfgfile line
- ]
+configured :: FilePath -> Option -> String -> Property Linux
+configured cfgfile option value = tightenTargets $ combineProperties desc $ props
+ & File.fileProperty desc (mapMaybe removeother) cfgfile
+ & File.containsLine cfgfile line
where
setting = option ++ "="
line = setting ++ value
@@ -162,43 +162,59 @@ configured cfgfile option value = combineProperties desc
| otherwise = Just l
-- | Causes systemd to reload its configuration files.
-daemonReloaded :: Property NoInfo
-daemonReloaded = cmdProperty "systemctl" ["daemon-reload"]
+daemonReloaded :: Property Linux
+daemonReloaded = tightenTargets $ cmdProperty "systemctl" ["daemon-reload"]
`assume` NoChange
-- | Configures journald, restarting it so the changes take effect.
-journaldConfigured :: Option -> String -> Property NoInfo
+journaldConfigured :: Option -> String -> Property Linux
journaldConfigured option value =
configured "/etc/systemd/journald.conf" option value
`onChange` restarted journald
-- | Ensures machined and machinectl are installed
-machined :: Property NoInfo
-machined = withOS "machined installed" $ \o ->
+machined :: Property Linux
+machined = withOS "machined installed" $ \w o ->
case o of
-- Split into separate debian package since systemd 225.
(Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
+ | not (isStable suite) -> ensureProperty w $
Apt.installed ["systemd-container"]
_ -> noChange
--- | Defines a container with a given machine name, and operating system,
+-- | Defines a container with a given machine name,
-- and how to create its chroot if not already present.
--
--- Properties can be added to configure the Container.
+-- Properties can be added to configure the Container. At a minimum,
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
--- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty)
+-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
+-- > & osDebian Unstable "amd64"
-- > & Apt.installedRunning "apache2"
-- > & ...
-container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container
-container name system mkchroot = Container name c h
- & os system
- & resolvConfed
- & linkJournal
+container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
+container name mkchroot =
+ let c = Container name chroot (host name (containerProps chroot))
+ in setContainerProps c $ containerProps c
+ &^ resolvConfed
+ &^ linkJournal
where
- c = mkchroot (containerDir name)
- & os system
- h = Host name [] mempty
+ chroot = mkchroot (containerDir name)
+
+-- | Defines a container with a given machine name, with the chroot
+-- created using debootstrap.
+--
+-- Properties can be added to configure the Container. At a minimum,
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
+--
+-- > debContainer "webserver" $ props
+-- > & osDebian Unstable "amd64"
+-- > & Apt.installedRunning "apache2"
+-- > & ...
+debContainer :: MachineName -> Props metatypes -> Container
+debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps
-- | Runs a container using systemd-nspawn.
--
@@ -214,13 +230,14 @@ container name system mkchroot = Container name c h
--
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
-nspawned :: Container -> RevertableProperty HasInfo
+nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux
nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
p `describe` ("nspawned " ++ name)
where
+ p :: RevertableProperty (HasInfo + Linux) Linux
p = enterScript c
`before` chrootprovisioned
- `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
+ `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h)
`before` containerprovisioned
-- Chroot provisioning is run in systemd-only mode,
@@ -230,8 +247,9 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
+ containerprovisioned :: RevertableProperty Linux Linux
containerprovisioned =
- Chroot.propellChroot chroot (enterContainerProcess c) False
+ tightenTargets (Chroot.propellChroot chroot (enterContainerProcess c) False)
<!>
doNothing
@@ -239,7 +257,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- | Sets up the service file for the container, and then starts
-- it running.
-nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo
+nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService (Container name _ _) cfg = setup <!> teardown
where
service = nspawnServiceName name
@@ -264,10 +282,12 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
<$> servicefilecontent
<*> catchDefaultIO "" (readFile servicefile)
+ writeservicefile :: Property Linux
writeservicefile = property servicefile $ makeChange $ do
c <- servicefilecontent
File.viaStableTmp (\t -> writeFile t c) servicefile
+ setupservicefile :: Property Linux
setupservicefile = check (not <$> goodservicefile) $
-- if it's running, it has the wrong configuration,
-- so stop it
@@ -275,8 +295,12 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
`requires` daemonReloaded
`requires` writeservicefile
- setup = started service `requires` setupservicefile `requires` machined
+ setup :: Property Linux
+ setup = started service
+ `requires` setupservicefile
+ `requires` machined
+ teardown :: Property Linux
teardown = check (doesFileExist servicefile) $
disabled service `requires` stopped service
@@ -290,11 +314,12 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
--
-- This uses nsenter to enter the container, by looking up the pid of the
-- container's init process and using its namespace.
-enterScript :: Container -> RevertableProperty NoInfo
-enterScript c@(Container name _ _) = setup <!> teardown
+enterScript :: Container -> RevertableProperty Linux Linux
+enterScript c@(Container name _ _) =
+ tightenTargets setup <!> tightenTargets teardown
where
- setup = combineProperties ("generated " ++ enterScriptFile c)
- [ scriptfile `File.hasContent`
+ setup = combineProperties ("generated " ++ enterScriptFile c) $ props
+ & scriptfile `File.hasContent`
[ "#!/usr/bin/perl"
, "# Generated by propellor"
, "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;"
@@ -309,8 +334,7 @@ enterScript c@(Container name _ _) = setup <!> teardown
, "}"
, "exit(1);"
]
- , scriptfile `File.mode` combineModes (readModes ++ executeModes)
- ]
+ & scriptfile `File.mode` combineModes (readModes ++ executeModes)
teardown = File.notPresent scriptfile
scriptfile = enterScriptFile c
@@ -336,11 +360,14 @@ mungename = replace "/" "_"
-- When there is no leading dash, "--" is prepended to the parameter.
--
-- Reverting the property will remove a parameter, if it's present.
-containerCfg :: String -> RevertableProperty HasInfo
+containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg p = RevertableProperty (mk True) (mk False)
where
- mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
- mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
+ mk b = tightenTargets $
+ pureInfoProperty desc $
+ mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
+ where
+ desc = "container configuration " ++ (if b then "" else "without ") ++ p'
p' = case p of
('-':_) -> p
_ -> "--" ++ p
@@ -348,18 +375,18 @@ containerCfg p = RevertableProperty (mk True) (mk False)
-- | Bind mounts </etc/resolv.conf> from the host into the container.
--
-- This property is enabled by default. Revert it to disable it.
-resolvConfed :: RevertableProperty HasInfo
+resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
resolvConfed = containerCfg "bind=/etc/resolv.conf"
-- | Link the container's journal to the host's if possible.
-- (Only works if the host has persistent journal enabled.)
--
-- This property is enabled by default. Revert it to disable it.
-linkJournal :: RevertableProperty HasInfo
+linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
linkJournal = containerCfg "link-journal=try-guest"
-- | Disconnect networking of the container from the host.
-privateNetwork :: RevertableProperty HasInfo
+privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
privateNetwork = containerCfg "private-network"
class Publishable a where
@@ -397,7 +424,7 @@ instance Publishable (Proto, Bound Port) where
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)
-- > & Apt.installedRunning "apache2"
-publish :: Publishable p => p -> RevertableProperty HasInfo
+publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
publish p = containerCfg $ "--port=" ++ toPublish p
class Bindable a where
@@ -410,9 +437,9 @@ instance Bindable (Bound FilePath) where
toBind v = hostSide v ++ ":" ++ containerSide v
-- | Bind mount a file or directory from the host into the container.
-bind :: Bindable p => p -> RevertableProperty HasInfo
+bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bind p = containerCfg $ "--bind=" ++ toBind p
-- | Read-only mind mount.
-bindRo :: Bindable p => p -> RevertableProperty HasInfo
+bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bindRo p = containerCfg $ "--bind-ro=" ++ toBind p
diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs
index 7842f177..0290bce5 100644
--- a/src/Propellor/Property/Systemd/Core.hs
+++ b/src/Propellor/Property/Systemd/Core.hs
@@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
-- dbus is only a Recommends of systemd, but is needed for communication
-- from the systemd inside a container to the one outside, so make sure it
-- gets installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["systemd", "dbus"]
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 0c040f95..92dbd507 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.Tor where
import Propellor.Base
@@ -19,7 +21,7 @@ type NodeName = String
-- | Sets up a tor bridge. (Not a relay or exit node.)
--
-- Uses port 443
-isBridge :: Property NoInfo
+isBridge :: Property DebianLike
isBridge = configured
[ ("BridgeRelay", "1")
, ("Exitpolicy", "reject *:*")
@@ -31,7 +33,7 @@ isBridge = configured
-- | Sets up a tor relay.
--
-- Uses port 443
-isRelay :: Property NoInfo
+isRelay :: Property DebianLike
isRelay = configured
[ ("BridgeRelay", "0")
, ("Exitpolicy", "reject *:*")
@@ -44,21 +46,21 @@ isRelay = configured
--
-- This can be moved to a different IP without needing to wait to
-- accumulate trust.
-named :: NodeName -> Property HasInfo
+named :: NodeName -> Property (HasInfo + DebianLike)
named n = configured [("Nickname", n')]
`describe` ("tor node named " ++ n')
`requires` torPrivKey (Context ("tor " ++ n))
where
n' = saneNickname n
-torPrivKey :: Context -> Property HasInfo
+torPrivKey :: Context -> Property (HasInfo + DebianLike)
torPrivKey context = f `File.hasPrivContent` context
`onChange` File.ownerGroup f user (userGroup user)
`requires` torPrivKeyDirExists
where
f = torPrivKeyDir </> "secret_id_key"
-torPrivKeyDirExists :: Property NoInfo
+torPrivKeyDirExists :: Property DebianLike
torPrivKeyDirExists = File.dirExists torPrivKeyDir
`onChange` setperms
`requires` installed
@@ -71,20 +73,20 @@ torPrivKeyDir = "/var/lib/tor/keys"
-- | A tor server (bridge, relay, or exit)
-- Don't use if you just want to run tor for personal use.
-server :: Property NoInfo
+server :: Property DebianLike
server = configured [("SocksPort", "0")]
`requires` installed
`requires` Apt.installed ["ntp"]
`describe` "tor server"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["tor"]
-- | Specifies configuration settings. Any lines in the config file
-- that set other values for the specified settings will be removed,
-- while other settings are left as-is. Tor is restarted when
-- configuration is changed.
-configured :: [(String, String)] -> Property NoInfo
+configured :: [(String, String)] -> Property DebianLike
configured settings = File.fileProperty "tor configured" go mainConfig
`onChange` restarted
where
@@ -105,19 +107,19 @@ data BwLimit
--
-- For example, PerSecond "30 kibibytes" is the minimum limit
-- for a useful relay.
-bandwidthRate :: BwLimit -> Property NoInfo
+bandwidthRate :: BwLimit -> Property DebianLike
bandwidthRate (PerSecond s) = bandwidthRate' s 1
bandwidthRate (PerDay s) = bandwidthRate' s (24*60*60)
bandwidthRate (PerMonth s) = bandwidthRate' s (31*24*60*60)
-bandwidthRate' :: String -> Integer -> Property NoInfo
+bandwidthRate' :: String -> Integer -> Property DebianLike
bandwidthRate' s divby = case readSize dataUnits s of
Just sz -> let v = show (sz `div` divby) ++ " bytes"
in configured [("BandwidthRate", v)]
`describe` ("tor BandwidthRate " ++ v)
Nothing -> property ("unable to parse " ++ s) noChange
-hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
+hiddenServiceAvailable :: HiddenServiceName -> Int -> Property DebianLike
hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
where
hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
@@ -126,7 +128,7 @@ hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
warningMessage $ unwords ["hidden service hostname:", h]
return r
-hiddenService :: HiddenServiceName -> Int -> Property NoInfo
+hiddenService :: HiddenServiceName -> Int -> Property DebianLike
hiddenService hn port = ConfFile.adjustSection
(unwords ["hidden service", hn, "available on port", show port])
(== oniondir)
@@ -139,18 +141,18 @@ hiddenService hn port = ConfFile.adjustSection
oniondir = unwords ["HiddenServiceDir", varLib </> hn]
onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
-hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
-hiddenServiceData hn context = combineProperties desc
- [ installonion "hostname"
- , installonion "private_key"
- ]
+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property (HasInfo + DebianLike)
+hiddenServiceData hn context = combineProperties desc $ props
+ & installonion "hostname"
+ & installonion "private_key"
where
desc = unwords ["hidden service data available in", varLib </> hn]
+ installonion :: FilePath -> Property (HasInfo + DebianLike)
installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent ->
- property desc $ getcontent $ install $ varLib </> hn </> f
- install f privcontent = ifM (liftIO $ doesFileExist f)
+ property' desc $ \w -> getcontent $ install w $ varLib </> hn </> f
+ install w f privcontent = ifM (liftIO $ doesFileExist f)
( noChange
- , ensureProperties
+ , ensureProperty w $ propertyList desc $ toProps
[ property desc $ makeChange $ do
createDirectoryIfMissing True (takeDirectory f)
writeFileProtected f (unlines (privDataLines privcontent))
@@ -161,7 +163,7 @@ hiddenServiceData hn context = combineProperties desc
]
)
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "tor"
mainConfig :: FilePath
diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs
index f1280b0e..23a5b30d 100644
--- a/src/Propellor/Property/Unbound.hs
+++ b/src/Propellor/Property/Unbound.hs
@@ -41,13 +41,13 @@ type UnboundValue = String
type ZoneType = String
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["unbound"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "unbound"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "unbound"
dValue :: BindDomain -> String
@@ -90,7 +90,7 @@ config = "/etc/unbound/unbound.conf.d/propellor.conf"
-- > , (AbsDomain "myrouter.example.com", PTR $ reverseIP $ IPv4 "192.168.1.1")
-- > , (AbsDomain "mylaptop.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2")
-- > ]
-cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property NoInfo
+cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property DebianLike
cachingDnsServer sections zones hosts =
config `hasContent` (comment : otherSections ++ serverSection)
`onChange` restarted
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index c9c91a77..76eae647 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -7,8 +7,8 @@ import qualified Propellor.Property.File as File
data Eep = YesReallyDeleteHome
-accountFor :: User -> Property NoInfo
-accountFor user@(User u) = check nohomedir go
+accountFor :: User -> Property DebianLike
+accountFor user@(User u) = tightenTargets $ check nohomedir go
`describe` ("account for " ++ u)
where
nohomedir = isNothing <$> catchMaybeIO (homedir user)
@@ -18,11 +18,11 @@ accountFor user@(User u) = check nohomedir go
, u
]
-systemAccountFor :: User -> Property NoInfo
+systemAccountFor :: User -> Property DebianLike
systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u))
-systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property NoInfo
-systemAccountFor' (User u) mhome mgroup = check nouser go
+systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike
+systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
`describe` ("system account for " ++ u)
where
nouser = isNothing <$> catchMaybeIO (getUserEntryForName u)
@@ -43,8 +43,8 @@ systemAccountFor' (User u) mhome mgroup = check nouser go
]
-- | Removes user home directory!! Use with caution.
-nuked :: User -> Eep -> Property NoInfo
-nuked user@(User u) _ = check hashomedir go
+nuked :: User -> Eep -> Property DebianLike
+nuked user@(User u) _ = tightenTargets $ check hashomedir go
`describe` ("nuked user " ++ u)
where
hashomedir = isJust <$> catchMaybeIO (homedir user)
@@ -55,13 +55,13 @@ nuked user@(User u) _ = check hashomedir go
-- | Only ensures that the user has some password set. It may or may
-- not be a password from the PrivData.
-hasSomePassword :: User -> Property HasInfo
+hasSomePassword :: User -> Property (HasInfo + DebianLike)
hasSomePassword user = hasSomePassword' user hostContext
-- | While hasSomePassword uses the name of the host as context,
-- this allows specifying a different context. This is useful when
-- you want to use the same password on multiple hosts, for example.
-hasSomePassword' :: IsContext c => User -> c -> Property HasInfo
+hasSomePassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike)
hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword' user context
@@ -71,12 +71,14 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us
-- A user's password can be stored in the PrivData in either of two forms;
-- the full cleartext <Password> or a <CryptPassword> hash. The latter
-- is obviously more secure.
-hasPassword :: User -> Property HasInfo
+hasPassword :: User -> Property (HasInfo + DebianLike)
hasPassword user = hasPassword' user hostContext
-hasPassword' :: IsContext c => User -> c -> Property HasInfo
-hasPassword' (User u) context = go `requires` shadowConfig True
+hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike)
+hasPassword' (User u) context = go
+ `requires` shadowConfig True
where
+ go :: Property (HasInfo + UnixLike)
go = withSomePrivData srcs context $
property (u ++ " has password") . setPassword
srcs =
@@ -94,7 +96,7 @@ setPassword getpassword = getpassword $ go
-- | Makes a user's password be the passed String. Highly insecure:
-- The password is right there in your config file for anyone to see!
-hasInsecurePassword :: User -> String -> Property NoInfo
+hasInsecurePassword :: User -> String -> Property DebianLike
hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
chpasswd u p []
@@ -104,9 +106,10 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc
hPutStrLn h $ user ++ ":" ++ v
hClose h
-lockedPassword :: User -> Property NoInfo
-lockedPassword user@(User u) = check (not <$> isLockedPassword user) go
- `describe` ("locked " ++ u ++ " password")
+lockedPassword :: User -> Property DebianLike
+lockedPassword user@(User u) = tightenTargets $
+ check (not <$> isLockedPassword user) go
+ `describe` ("locked " ++ u ++ " password")
where
go = cmdProperty "passwd"
[ "--lock"
@@ -130,8 +133,8 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: User -> IO FilePath
homedir (User user) = homeDirectory <$> getUserEntryForName user
-hasGroup :: User -> Group -> Property NoInfo
-hasGroup (User user) (Group group') = check test go
+hasGroup :: User -> Group -> Property DebianLike
+hasGroup (User user) (Group group') = tightenTargets $ check test go
`describe` unwords ["user", user, "in group", group']
where
test = not . elem group' . words <$> readProcess "groups" [user]
@@ -145,12 +148,13 @@ hasGroup (User user) (Group group') = check test go
--
-- Note that some groups may only exit after installation of other
-- software. When a group does not exist yet, the user won't be added to it.
-hasDesktopGroups :: User -> Property NoInfo
-hasDesktopGroups user@(User u) = property desc $ do
+hasDesktopGroups :: User -> Property DebianLike
+hasDesktopGroups user@(User u) = property' desc $ \o -> do
existinggroups <- map (fst . break (== ':')) . lines
<$> liftIO (readFile "/etc/group")
let toadd = filter (`elem` existinggroups) desktopgroups
- ensureProperty $ propertyList desc $ map (hasGroup user . Group) toadd
+ ensureProperty o $ propertyList desc $ toProps $
+ map (hasGroup user . Group) toadd
where
desc = "user " ++ u ++ " is in standard desktop groups"
-- This list comes from user-setup's debconf
@@ -170,11 +174,11 @@ hasDesktopGroups user@(User u) = property desc $ do
]
-- | Controls whether shadow passwords are enabled or not.
-shadowConfig :: Bool -> Property NoInfo
-shadowConfig True = check (not <$> shadowExists)
+shadowConfig :: Bool -> Property DebianLike
+shadowConfig True = tightenTargets $ check (not <$> shadowExists)
(cmdProperty "shadowconfig" ["on"])
`describe` "shadow passwords enabled"
-shadowConfig False = check shadowExists
+shadowConfig False = tightenTargets $ check shadowExists
(cmdProperty "shadowconfig" ["off"])
`describe` "shadow passwords disabled"
@@ -183,11 +187,11 @@ shadowExists = doesFileExist "/etc/shadow"
-- | Ensures that a user has a specified login shell, and that the shell
-- is enabled in /etc/shells.
-hasLoginShell :: User -> FilePath -> Property NoInfo
+hasLoginShell :: User -> FilePath -> Property DebianLike
hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell
-shellSetTo :: User -> FilePath -> Property NoInfo
-shellSetTo (User u) loginshell = check needchangeshell
+shellSetTo :: User -> FilePath -> Property DebianLike
+shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell
(cmdProperty "chsh" ["--shell", loginshell, u])
`describe` (u ++ " has login shell " ++ loginshell)
where
@@ -196,5 +200,6 @@ shellSetTo (User u) loginshell = check needchangeshell
return (currshell /= loginshell)
-- | Ensures that /etc/shells contains a shell.
-shellEnabled :: FilePath -> Property NoInfo
-shellEnabled loginshell = "/etc/shells" `File.containsLine` loginshell
+shellEnabled :: FilePath -> Property DebianLike
+shellEnabled loginshell = tightenTargets $
+ "/etc/shells" `File.containsLine` loginshell
diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs
index f76d6a0f..4eb94103 100644
--- a/src/Propellor/Property/Uwsgi.hs
+++ b/src/Propellor/Property/Uwsgi.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type AppName = String
-appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo
+appEnabled :: AppName -> ConfigFile -> RevertableProperty DebianLike DebianLike
appEnabled an cf = enable <!> disable
where
enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an
@@ -24,9 +24,9 @@ appEnabled an cf = enable <!> disable
`requires` installed
`onChange` reloaded
-appAvailable :: AppName -> ConfigFile -> Property NoInfo
+appAvailable :: AppName -> ConfigFile -> Property DebianLike
appAvailable an cf = ("uwsgi app available " ++ an) ==>
- appCfg an `File.hasContent` (comment : cf)
+ tightenTargets (appCfg an `File.hasContent` (comment : cf))
where
comment = "# deployed with propellor, do not modify"
@@ -39,11 +39,11 @@ appVal an = "/etc/uwsgi/apps-enabled/" </> an <.> "ini"
appValRelativeCfg :: AppName -> File.LinkTarget
appValRelativeCfg an = File.LinkTarget $ "../apps-available" </> an <.> "ini"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["uwsgi"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "uwsgi"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "uwsgi"
diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs
index 5ceaf9ba..47d5a9d1 100644
--- a/src/Propellor/Property/ZFS/Properties.hs
+++ b/src/Propellor/Property/ZFS/Properties.hs
@@ -3,6 +3,7 @@
-- Functions defining zfs Properties.
module Propellor.Property.ZFS.Properties (
+ ZFSOS,
zfsExists,
zfsSetProperties
) where
@@ -11,9 +12,12 @@ import Propellor.Base
import Data.List (intercalate)
import qualified Propellor.Property.ZFS.Process as ZP
+-- | OS's that support ZFS
+type ZFSOS = Linux + FreeBSD
+
-- | Will ensure that a ZFS volume exists with the specified mount point.
-- This requires the pool to exist as well, but we don't create pools yet.
-zfsExists :: ZFS -> Property NoInfo
+zfsExists :: ZFS -> Property ZFSOS
zfsExists z = check (not <$> ZP.zfsExists z) create
`describe` unwords ["Creating", zfsName z]
where
@@ -21,16 +25,16 @@ zfsExists z = check (not <$> ZP.zfsExists z) create
create = cmdProperty p a
-- | Sets the given properties. Returns True if all were successfully changed, False if not.
-zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo
+zfsSetProperties :: ZFS -> ZFSProperties -> Property ZFSOS
zfsSetProperties z setProperties = setall
`requires` zfsExists z
where
spcmd :: String -> String -> (String, [String])
spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z
- setprop :: (String, String) -> Property NoInfo
+ setprop :: (String, String) -> Property ZFSOS
setprop (p, v) = check (ZP.zfsExists z) $
cmdProperty (fst (spcmd p v)) (snd (spcmd p v))
setall = combineProperties (unwords ["Setting properties on", zfsName z]) $
- map setprop $ toPropertyList setProperties
+ toProps $ map setprop $ toPropertyList setProperties
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 5f103b8a..944696dd 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do
error "remote propellor failed"
where
hn = fromMaybe target relay
- sys = case getInfo (hostInfo hst) of
+ sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
@@ -170,7 +170,7 @@ getSshTarget target hst
return ip
configips = map fromIPAddr $ mapMaybe getIPAddr $
- S.toList $ fromDnsInfo $ getInfo $ hostInfo hst
+ S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 542a1f66..6d6b14ea 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,264 +1,156 @@
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
-module Propellor.Types
- ( Host(..)
- , Property
- , Info
- , HasInfo
- , NoInfo
- , CInfo
+module Propellor.Types (
+ -- * Core data types
+ Host(..)
+ , Property(..)
+ , property
, Desc
- , infoProperty
- , simpleProperty
- , adjustPropertySatisfy
- , propertyInfo
- , propertyDesc
- , propertyChildren
, RevertableProperty(..)
- , MkRevertableProperty(..)
- , IsProp(..)
+ , (<!>)
+ , Propellor(..)
+ , LiftPropellor(..)
+ , Info
+ -- * Types of properties
+ , UnixLike
+ , Linux
+ , DebianLike
+ , Debian
+ , Buntish
+ , FreeBSD
+ , HasInfo
+ , type (+)
+ , TightenTargets(..)
+ -- * Combining and modifying properties
, Combines(..)
, CombinedType
, ResultCombiner
- , Propellor(..)
- , LiftPropellor(..)
- , EndAction(..)
+ , adjustPropertySatisfy
+ -- * Other included types
, module Propellor.Types.OS
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
- , propertySatisfy
- , ignoreInfo
) where
import Data.Monoid
-import "mtl" Control.Monad.RWS.Strict
-import Control.Monad.Catch
-import Data.Typeable
-import Control.Applicative
-import Prelude
+import Propellor.Types.Core
import Propellor.Types.Info
import Propellor.Types.OS
import Propellor.Types.Dns
import Propellor.Types.Result
+import Propellor.Types.MetaTypes
import Propellor.Types.ZFS
--- | Everything Propellor knows about a system: Its hostname,
--- properties and their collected info.
-data Host = Host
- { hostName :: HostName
- , hostProperties :: [Property HasInfo]
- , hostInfo :: Info
- }
- deriving (Show, Typeable)
-
--- | Propellor's monad provides read-only access to info about the host
--- it's running on, and a writer to accumulate EndActions.
-newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
- deriving
- ( Monad
- , Functor
- , Applicative
- , MonadReader Host
- , MonadWriter [EndAction]
- , MonadIO
- , MonadCatch
- , MonadThrow
- , MonadMask
- )
-
-class LiftPropellor m where
- liftPropellor :: m a -> Propellor a
-
-instance LiftPropellor Propellor where
- liftPropellor = id
-
-instance LiftPropellor IO where
- liftPropellor = liftIO
-
-instance Monoid (Propellor Result) where
- mempty = return NoChange
- -- | The second action is only run if the first action does not fail.
- mappend x y = do
- rx <- x
- case rx of
- FailedChange -> return FailedChange
- _ -> do
- ry <- y
- return (rx <> ry)
-
--- | An action that Propellor runs at the end, after trying to satisfy all
--- properties. It's passed the combined Result of the entire Propellor run.
-data EndAction = EndAction Desc (Result -> Propellor Result)
-
-type Desc = String
-
-- | The core data type of Propellor, this represents a property
--- that the system should have, and an action to ensure it has the
--- property.
+-- that the system should have, with a descrition, and an action to ensure
+-- it has the property.
+-- that have the property.
+--
+-- There are different types of properties that target different OS's,
+-- and so have different metatypes.
+-- For example: "Property DebianLike" and "Property FreeBSD".
--
--- A property can have associated `Info` or not. This is tracked at the
--- type level with Property `NoInfo` and Property `HasInfo`.
+-- Also, some properties have associated `Info`, which is indicated in
+-- their type: "Property (HasInfo + DebianLike)"
--
--- There are many instances and type families, which are mostly used
+-- There are many associated type families, which are mostly used
-- internally, so you needn't worry about them.
-data Property i where
- IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
- SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
-
--- | Indicates that a Property has associated Info.
-data HasInfo
--- | Indicates that a Property does not have Info.
-data NoInfo
-
--- | Type level calculation of the combination of HasInfo and/or NoInfo
-type family CInfo x y
-type instance CInfo HasInfo HasInfo = HasInfo
-type instance CInfo HasInfo NoInfo = HasInfo
-type instance CInfo NoInfo HasInfo = HasInfo
-type instance CInfo NoInfo NoInfo = NoInfo
-
--- | Constructs a Property with associated Info.
-infoProperty
- :: Desc -- ^ description of the property
- -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
- -> Info -- ^ info associated with the property
- -> [Property i] -- ^ child properties
- -> Property HasInfo
-infoProperty d a i cs = IProperty d a i (map toIProperty cs)
+data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
--- | Constructs a Property with no Info.
-simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
-simpleProperty = SProperty
+instance Show (Property metatypes) where
+ show p = "property " ++ show (getDesc p)
-toIProperty :: Property i -> Property HasInfo
-toIProperty p@(IProperty {}) = p
-toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
-
-toSProperty :: Property i -> Property NoInfo
-toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
-toSProperty p@(SProperty {}) = p
-
--- | Makes a version of a Proprty without its Info.
--- Use with caution!
-ignoreInfo :: Property i -> Property NoInfo
-ignoreInfo = toSProperty
-
--- | Gets the action that can be run to satisfy a Property.
--- You should never run this action directly. Use
--- 'Propellor.Engine.ensureProperty` instead.
-propertySatisfy :: Property i -> Propellor Result
-propertySatisfy (IProperty _ a _ _) = a
-propertySatisfy (SProperty _ a _) = a
+-- | Constructs a Property, from a description and an action to run to
+-- ensure the Property is met.
+--
+-- Due to the polymorphic return type of this function, most uses will need
+-- to specify a type signature. This lets you specify what OS the property
+-- targets, etc.
+--
+-- For example:
+--
+-- > foo :: Property Debian
+-- > foo = property "foo" $ do
+-- > ...
+-- > return MadeChange
+property
+ :: SingI metatypes
+ => Desc
+ -> Propellor Result
+ -> Property (MetaTypes metatypes)
+property d a = Property sing d a mempty mempty
-- | Changes the action that is performed to satisfy a property.
-adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
-adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
-adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs
-
-propertyInfo :: Property i -> Info
-propertyInfo (IProperty _ _ i _) = i
-propertyInfo (SProperty {}) = mempty
-
-propertyDesc :: Property i -> Desc
-propertyDesc (IProperty d _ _ _) = d
-propertyDesc (SProperty d _ _) = d
-
-instance Show (Property i) where
- show p = "property " ++ show (propertyDesc p)
-
--- | A Property can include a list of child properties that it also
--- satisfies. This allows them to be introspected to collect their info, etc.
-propertyChildren :: Property i -> [Property i]
-propertyChildren (IProperty _ _ _ cs) = cs
-propertyChildren (SProperty _ _ cs) = cs
+adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
+adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
-data RevertableProperty i = RevertableProperty
- { setupRevertableProperty :: Property i
- , undoRevertableProperty :: Property i
+data RevertableProperty setupmetatypes undometatypes = RevertableProperty
+ { setupRevertableProperty :: Property setupmetatypes
+ , undoRevertableProperty :: Property undometatypes
}
-instance Show (RevertableProperty i) where
+instance Show (RevertableProperty setupmetatypes undometatypes) where
show (RevertableProperty p _) = show p
-class MkRevertableProperty i1 i2 where
- -- | Shorthand to construct a revertable property.
- (<!>) :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2)
-
-instance MkRevertableProperty HasInfo HasInfo where
- x <!> y = RevertableProperty x y
-instance MkRevertableProperty NoInfo NoInfo where
- x <!> y = RevertableProperty x y
-instance MkRevertableProperty NoInfo HasInfo where
- x <!> y = RevertableProperty (toProp x) y
-instance MkRevertableProperty HasInfo NoInfo where
- x <!> y = RevertableProperty x (toProp y)
-
--- | Class of types that can be used as properties of a host.
-class IsProp p where
- setDesc :: p -> Desc -> p
- toProp :: p -> Property HasInfo
- getDesc :: p -> Desc
- -- | Gets the info of the property, combined with all info
- -- of all children properties.
- getInfoRecursive :: p -> Info
-
-instance IsProp (Property HasInfo) where
- setDesc (IProperty _ a i cs) d = IProperty d a i cs
- toProp = id
- getDesc = propertyDesc
- getInfoRecursive (IProperty _ _ i cs) =
- i <> mconcat (map getInfoRecursive cs)
-instance IsProp (Property NoInfo) where
- setDesc (SProperty _ a cs) d = SProperty d a cs
- toProp = toIProperty
- getDesc = propertyDesc
- getInfoRecursive _ = mempty
-
-instance IsProp (RevertableProperty HasInfo) where
- setDesc = setDescR
+-- | Shorthand to construct a revertable property from any two Properties.
+(<!>)
+ :: Property setupmetatypes
+ -> Property undometatypes
+ -> RevertableProperty setupmetatypes undometatypes
+setup <!> undo = RevertableProperty setup undo
+
+instance IsProp (Property metatypes) where
+ setDesc (Property t _ a i c) d = Property t d a i c
+ getDesc (Property _ d _ _ _) = d
+ getChildren (Property _ _ _ _ c) = c
+ addChildren (Property t d a i c) c' = Property t d a i (c ++ c')
+ getInfoRecursive (Property _ _ _ i c) =
+ i <> mconcat (map getInfoRecursive c)
+ getInfo (Property _ _ _ i _) = i
+ toChildProperty (Property _ d a i c) = ChildProperty d a i c
+ getSatisfy (Property _ _ a _ _) = a
+
+instance IsProp (RevertableProperty setupmetatypes undometatypes) where
+ -- | Sets the description of both sides.
+ setDesc (RevertableProperty p1 p2) d =
+ RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
getDesc (RevertableProperty p1 _) = getDesc p1
- toProp (RevertableProperty p1 _) = p1
+ getChildren (RevertableProperty p1 _) = getChildren p1
+ -- | Only add children to the active side.
+ addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2
-- | Return the Info of the currently active side.
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
-instance IsProp (RevertableProperty NoInfo) where
- setDesc = setDescR
- getDesc (RevertableProperty p1 _) = getDesc p1
- toProp (RevertableProperty p1 _) = toProp p1
- getInfoRecursive (RevertableProperty _ _) = mempty
-
--- | Sets the description of both sides.
-setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i
-setDescR (RevertableProperty p1 p2) d =
- RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
+ getInfo (RevertableProperty p1 _p2) = getInfo p1
+ toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
+ getSatisfy (RevertableProperty p1 _) = getSatisfy p1
-- | Type level calculation of the type that results from combining two
-- types of properties.
type family CombinedType x y
-type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
-type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y)
+type instance CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
+type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) = RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine x' y'))
-- When only one of the properties is revertable, the combined property is
-- not fully revertable, so is not a RevertableProperty.
-type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y)
-type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y)
+type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
+type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y))
type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result
class Combines x y where
-- | Combines together two properties, yielding a property that
- -- has the description and info of the first, and that has the second
- -- property as a child.
+ -- has the description and info of the first, and that has the
+ -- second property as a child property.
combineWith
:: ResultCombiner
-- ^ How to combine the actions to satisfy the properties.
@@ -269,73 +161,37 @@ class Combines x y where
-> y
-> CombinedType x y
-instance Combines (Property HasInfo) (Property HasInfo) where
- combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (f a1 a2) i1 (y : cs1)
-
-instance Combines (Property HasInfo) (Property NoInfo) where
- combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
- IProperty d1 (f a1 a2) i1 (toIProperty y : cs1)
-
-instance Combines (Property NoInfo) (Property HasInfo) where
- combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1)
-
-instance Combines (Property NoInfo) (Property NoInfo) where
- combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
- SProperty d1 (f a1 a2) (y : cs1)
-
-instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where
- combineWith = combineWithRR
-instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where
- combineWith = combineWithRR
-instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where
- combineWith = combineWithRR
-instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where
- combineWith = combineWithRR
-instance Combines (RevertableProperty NoInfo) (Property HasInfo) where
- combineWith = combineWithRP
-instance Combines (RevertableProperty NoInfo) (Property NoInfo) where
- combineWith = combineWithRP
-instance Combines (RevertableProperty HasInfo) (Property HasInfo) where
- combineWith = combineWithRP
-instance Combines (RevertableProperty HasInfo) (Property NoInfo) where
- combineWith = combineWithRP
-instance Combines (Property HasInfo) (RevertableProperty NoInfo) where
- combineWith = combineWithPR
-instance Combines (Property NoInfo) (RevertableProperty NoInfo) where
- combineWith = combineWithPR
-instance Combines (Property HasInfo) (RevertableProperty HasInfo) where
- combineWith = combineWithPR
-instance Combines (Property NoInfo) (RevertableProperty HasInfo) where
- combineWith = combineWithPR
-
-combineWithRR
- :: Combines (Property x) (Property y)
- => ResultCombiner
- -> ResultCombiner
- -> RevertableProperty x
- -> RevertableProperty y
- -> RevertableProperty (CInfo x y)
-combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
- RevertableProperty
- (combineWith sf tf s1 s2)
- (combineWith tf sf t1 t2)
-
-combineWithRP
- :: Combines (Property i) y
- => (Propellor Result -> Propellor Result -> Propellor Result)
- -> (Propellor Result -> Propellor Result -> Propellor Result)
- -> RevertableProperty i
- -> y
- -> CombinedType (Property i) y
-combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y
-
-combineWithPR
- :: Combines x (Property i)
- => (Propellor Result -> Propellor Result -> Propellor Result)
- -> (Propellor Result -> Propellor Result -> Propellor Result)
- -> x
- -> RevertableProperty i
- -> CombinedType x (Property i)
-combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y
+instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
+ combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =
+ Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1)
+instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+ combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
+ RevertableProperty
+ (combineWith sf tf s1 s2)
+ (combineWith tf sf t1 t2)
+instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
+ combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
+instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+ combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
+
+class TightenTargets p where
+ -- | Tightens the MetaType list of a Property (or similar),
+ -- to contain fewer targets.
+ --
+ -- For example, to make a property that uses apt-get, which is only
+ -- available on DebianLike systems:
+ --
+ -- > upgraded :: Property DebianLike
+ -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
+ tightenTargets
+ ::
+ -- Note that this uses PolyKinds
+ ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
+ , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
+ , SingI tightened
+ )
+ => p (MetaTypes untightened)
+ -> p (MetaTypes tightened)
+
+instance TightenTargets Property where
+ tightenTargets (Property _ d a i c) = Property sing d a i c
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
new file mode 100644
index 00000000..fa939d2b
--- /dev/null
+++ b/src/Propellor/Types/Core.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Types.Core where
+
+import Propellor.Types.Info
+import Propellor.Types.OS
+import Propellor.Types.Result
+
+import Data.Monoid
+import "mtl" Control.Monad.RWS.Strict
+import Control.Monad.Catch
+import Control.Applicative
+import Prelude
+
+-- | Everything Propellor knows about a system: Its hostname,
+-- properties and their collected info.
+data Host = Host
+ { hostName :: HostName
+ , hostProperties :: [ChildProperty]
+ , hostInfo :: Info
+ }
+ deriving (Show, Typeable)
+
+-- | Propellor's monad provides read-only access to info about the host
+-- it's running on, and a writer to accumulate EndActions.
+newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
+ deriving
+ ( Monad
+ , Functor
+ , Applicative
+ , MonadReader Host
+ , MonadWriter [EndAction]
+ , MonadIO
+ , MonadCatch
+ , MonadThrow
+ , MonadMask
+ )
+
+class LiftPropellor m where
+ liftPropellor :: m a -> Propellor a
+
+instance LiftPropellor Propellor where
+ liftPropellor = id
+
+instance LiftPropellor IO where
+ liftPropellor = liftIO
+
+instance Monoid (Propellor Result) where
+ mempty = return NoChange
+ -- | The second action is only run if the first action does not fail.
+ mappend x y = do
+ rx <- x
+ case rx of
+ FailedChange -> return FailedChange
+ _ -> do
+ ry <- y
+ return (rx <> ry)
+
+-- | An action that Propellor runs at the end, after trying to satisfy all
+-- properties. It's passed the combined Result of the entire Propellor run.
+data EndAction = EndAction Desc (Result -> Propellor Result)
+
+type Desc = String
+
+-- | Props is a combination of a list of properties, with their combined
+-- metatypes.
+data Props metatypes = Props [ChildProperty]
+
+-- | Since there are many different types of Properties, they cannot be put
+-- into a list. The simplified ChildProperty can be put into a list.
+data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
+
+instance Show ChildProperty where
+ show = getDesc
+
+class IsProp p where
+ setDesc :: p -> Desc -> p
+ getDesc :: p -> Desc
+ getChildren :: p -> [ChildProperty]
+ addChildren :: p -> [ChildProperty] -> p
+ -- | Gets the info of the property, combined with all info
+ -- of all children properties.
+ getInfoRecursive :: p -> Info
+ -- | Info, not including info from children.
+ getInfo :: p -> Info
+ -- | Gets a ChildProperty representing the Property.
+ -- You should not normally need to use this.
+ toChildProperty :: p -> ChildProperty
+ -- | Gets the action that can be run to satisfy a Property.
+ -- You should never run this action directly. Use
+ -- 'Propellor.EnsureProperty.ensureProperty` instead.
+ getSatisfy :: p -> Propellor Result
+
+instance IsProp ChildProperty where
+ setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
+ getDesc (ChildProperty d _ _ _) = d
+ getChildren (ChildProperty _ _ _ c) = c
+ addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c')
+ getInfoRecursive (ChildProperty _ _ i c) =
+ i <> mconcat (map getInfoRecursive c)
+ getInfo (ChildProperty _ _ i _) = i
+ toChildProperty = id
+ getSatisfy (ChildProperty _ a _ _) = a
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index 53fa9e77..2e188ae5 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -4,7 +4,8 @@ module Propellor.Types.Info (
Info,
IsInfo(..),
addInfo,
- getInfo,
+ toInfo,
+ fromInfo,
mapInfo,
propagatableInfo,
InfoVal(..),
@@ -18,6 +19,9 @@ import Data.Monoid
import Prelude
-- | Information about a Host, which can be provided by its properties.
+--
+-- Many different types of data can be contained in the same Info value
+-- at the same time. See `toInfo` and `fromInfo`.
newtype Info = Info [InfoEntry]
deriving (Monoid, Show)
@@ -46,9 +50,14 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where
addInfo :: IsInfo v => Info -> v -> Info
addInfo (Info l) v = Info (InfoEntry v:l)
+-- | Converts any value in the `IsInfo` type class into an Info,
+-- which is otherwise empty.
+toInfo :: IsInfo v => v -> Info
+toInfo = addInfo mempty
+
-- The list is reversed here because addInfo builds it up in reverse order.
-getInfo :: IsInfo v => Info -> v
-getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
+fromInfo :: IsInfo v => Info -> v
+fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
-- | Maps a function over all values stored in the Info that are of the
-- appropriate type.
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
new file mode 100644
index 00000000..e064d76f
--- /dev/null
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -0,0 +1,213 @@
+{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-}
+
+module Propellor.Types.MetaTypes (
+ MetaType(..),
+ UnixLike,
+ Linux,
+ DebianLike,
+ Debian,
+ Buntish,
+ FreeBSD,
+ HasInfo,
+ MetaTypes,
+ type (+),
+ sing,
+ SingI,
+ IncludesInfo,
+ Targets,
+ NonTargets,
+ NotSuperset,
+ Combine,
+ CheckCombine(..),
+ CheckCombinable,
+ type (&&),
+ Not,
+ EqT,
+ Union,
+) where
+
+import Propellor.Types.Singletons
+import Propellor.Types.OS
+
+data MetaType
+ = Targeting TargetOS -- ^ A target OS of a Property
+ | WithInfo -- ^ Indicates that a Property has associated Info
+ deriving (Show, Eq, Ord)
+
+-- | Any unix-like system
+type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ]
+-- | Any linux system
+type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
+-- | Debian and derivatives.
+type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
+type Debian = MetaTypes '[ 'Targeting 'OSDebian ]
+type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ]
+type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]
+
+-- | Used to indicate that a Property adds Info to the Host where it's used.
+type HasInfo = MetaTypes '[ 'WithInfo ]
+
+type family IncludesInfo t :: Bool
+type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l
+
+type MetaTypes = Sing
+
+-- This boilerplate would not be needed if the singletons library were
+-- used. However, we're targeting too old a version of ghc to use it yet.
+data instance Sing (x :: MetaType) where
+ OSDebianS :: Sing ('Targeting 'OSDebian)
+ OSBuntishS :: Sing ('Targeting 'OSBuntish)
+ OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD)
+ WithInfoS :: Sing 'WithInfo
+instance SingI ('Targeting 'OSDebian) where sing = OSDebianS
+instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS
+instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS
+instance SingI 'WithInfo where sing = WithInfoS
+instance SingKind ('KProxy :: KProxy MetaType) where
+ type DemoteRep ('KProxy :: KProxy MetaType) = MetaType
+ fromSing OSDebianS = Targeting OSDebian
+ fromSing OSBuntishS = Targeting OSBuntish
+ fromSing OSFreeBSDS = Targeting OSFreeBSD
+ fromSing WithInfoS = WithInfo
+
+-- | Convenience type operator to combine two `MetaTypes` lists.
+--
+-- For example:
+--
+-- > HasInfo + Debian
+--
+-- Which is shorthand for this type:
+--
+-- > MetaTypes '[WithInfo, Targeting OSDebian]
+type family a + b :: ab
+type instance (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b)
+
+type family Concat (list1 :: [a]) (list2 :: [a]) :: [a]
+type instance Concat '[] bs = bs
+type instance Concat (a ': as) bs = a ': (Concat as bs)
+
+-- | Combine two MetaTypes lists, yielding a list
+-- that has targets present in both, and nontargets present in either.
+type family Combine (list1 :: [a]) (list2 :: [a]) :: [a]
+type instance Combine (list1 :: [a]) (list2 :: [a]) =
+ (Concat
+ (NonTargets list1 `Union` NonTargets list2)
+ (Targets list1 `Intersect` Targets list2)
+ )
+
+-- | Checks if two MetaTypes lists can be safely combined.
+--
+-- This should be used anywhere Combine is used, as an additional
+-- constraint. For example:
+--
+-- > foo :: (CheckCombinable x y ~ 'CanCombine) => x -> y -> Combine x y
+type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine
+-- As a special case, if either list is empty, let it be combined with the
+-- other. This relies on MetaTypes list always containing at least
+-- one target, so can only happen if there's already been a type error.
+-- This special case lets the type checker show only the original type
+-- error, and not an extra error due to a later CheckCombinable constraint.
+type instance CheckCombinable '[] list2 = 'CanCombine
+type instance CheckCombinable list1 '[] = 'CanCombine
+type instance CheckCombinable (l1 ': list1) (l2 ': list2) =
+ CheckCombinable' (Combine (l1 ': list1) (l2 ': list2))
+type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine
+type instance CheckCombinable' '[] = 'CannotCombineTargets
+type instance CheckCombinable' (a ': rest)
+ = If (IsTarget a)
+ 'CanCombine
+ (CheckCombinable' rest)
+
+data CheckCombine = CannotCombineTargets | CanCombine
+
+-- | Every item in the subset must be in the superset.
+--
+-- The name of this was chosen to make type errors more understandable.
+type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine
+type instance NotSuperset superset '[] = 'CanCombine
+type instance NotSuperset superset (s ': rest) =
+ If (Elem s superset)
+ (NotSuperset superset rest)
+ 'CannotCombineTargets
+
+type family IsTarget (a :: t) :: Bool
+type instance IsTarget ('Targeting a) = 'True
+type instance IsTarget 'WithInfo = 'False
+
+type family Targets (l :: [a]) :: [a]
+type instance Targets '[] = '[]
+type instance Targets (x ': xs) =
+ If (IsTarget x)
+ (x ': Targets xs)
+ (Targets xs)
+
+type family NonTargets (l :: [a]) :: [a]
+type instance NonTargets '[] = '[]
+type instance NonTargets (x ': xs) =
+ If (IsTarget x)
+ (NonTargets xs)
+ (x ': NonTargets xs)
+
+-- | Type level elem
+type family Elem (a :: t) (list :: [t]) :: Bool
+type instance Elem a '[] = 'False
+type instance Elem a (b ': bs) = EqT a b || Elem a bs
+
+-- | Type level union.
+type family Union (list1 :: [a]) (list2 :: [a]) :: [a]
+type instance Union '[] list2 = list2
+type instance Union (a ': rest) list2 =
+ If (Elem a list2 || Elem a rest)
+ (Union rest list2)
+ (a ': Union rest list2)
+
+-- | Type level intersection. Duplicate list items are eliminated.
+type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a]
+type instance Intersect '[] list2 = '[]
+type instance Intersect (a ': rest) list2 =
+ If (Elem a list2 && Not (Elem a rest))
+ (a ': Intersect rest list2)
+ (Intersect rest list2)
+
+-- | Type level equality
+--
+-- This is a very clumsy implmentation, but it works back to ghc 7.6.
+type family EqT (a :: t) (b :: t) :: Bool
+type instance EqT ('Targeting a) ('Targeting b) = EqT a b
+type instance EqT 'WithInfo 'WithInfo = 'True
+type instance EqT 'WithInfo ('Targeting b) = 'False
+type instance EqT ('Targeting a) 'WithInfo = 'False
+type instance EqT 'OSDebian 'OSDebian = 'True
+type instance EqT 'OSBuntish 'OSBuntish = 'True
+type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True
+type instance EqT 'OSDebian 'OSBuntish = 'False
+type instance EqT 'OSDebian 'OSFreeBSD = 'False
+type instance EqT 'OSBuntish 'OSDebian = 'False
+type instance EqT 'OSBuntish 'OSFreeBSD = 'False
+type instance EqT 'OSFreeBSD 'OSDebian = 'False
+type instance EqT 'OSFreeBSD 'OSBuntish = 'False
+-- More modern version if the combinatiorial explosion gets too bad later:
+--
+-- type family Eq (a :: MetaType) (b :: MetaType) where
+-- Eq a a = True
+-- Eq a b = False
+
+-- | An equivilant to the following is in Data.Type.Bool in
+-- modern versions of ghc, but is included here to support ghc 7.6.
+type family If (cond :: Bool) (tru :: a) (fls :: a) :: a
+type instance If 'True tru fls = tru
+type instance If 'False tru fls = fls
+type family (a :: Bool) || (b :: Bool) :: Bool
+type instance 'False || 'False = 'False
+type instance 'True || 'True = 'True
+type instance 'True || 'False = 'True
+type instance 'False || 'True = 'True
+type family (a :: Bool) && (b :: Bool) :: Bool
+type instance 'False && 'False = 'False
+type instance 'True && 'True = 'True
+type instance 'True && 'False = 'False
+type instance 'False && 'True = 'False
+type family Not (a :: Bool) :: Bool
+type instance Not 'False = 'True
+type instance Not 'True = 'False
+
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index a1ba14d4..d7df5490 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -3,6 +3,7 @@
module Propellor.Types.OS (
System(..),
Distribution(..),
+ TargetOS(..),
DebianSuite(..),
FreeBSDRelease(..),
FBSDVersion(..),
@@ -16,6 +17,7 @@ module Propellor.Types.OS (
userGroup,
Port(..),
fromPort,
+ systemToTargetOS,
) where
import Network.BSD (HostName)
@@ -28,10 +30,23 @@ data System = System Distribution Architecture
data Distribution
= Debian 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/>)
+ | 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)
+-- | Properties can target one or more OS's; the targets are part
+-- of the type of the property, so need to be kept fairly simple.
+data TargetOS
+ = OSDebian
+ | OSBuntish
+ | OSFreeBSD
+ deriving (Show, Eq, Ord)
+
+systemToTargetOS :: System -> TargetOS
+systemToTargetOS (System (Debian _) _) = OSDebian
+systemToTargetOS (System (Buntish _) _) = OSBuntish
+systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD
+
-- | Debian has several rolling suites, and a number of stable releases,
-- such as Stable "jessie".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
@@ -39,10 +54,10 @@ data DebianSuite = Experimental | Unstable | Testing | Stable Release
-- | FreeBSD breaks their releases into "Production" and "Legacy".
data FreeBSDRelease = FBSDProduction FBSDVersion | FBSDLegacy FBSDVersion
- deriving (Show, Eq)
+ deriving (Show, Eq)
data FBSDVersion = FBSD101 | FBSD102 | FBSD093
- deriving (Eq)
+ deriving (Eq)
instance IsString FBSDVersion where
fromString "10.1-RELEASE" = FBSD101
diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs
index 4c6524ee..f03c174f 100644
--- a/src/Propellor/Types/ResultCheck.hs
+++ b/src/Propellor/Types/ResultCheck.hs
@@ -22,6 +22,9 @@ import Data.Monoid
-- and `FailedChange` is still an error.
data UncheckedProperty i = UncheckedProperty (Property i)
+instance TightenTargets UncheckedProperty where
+ tightenTargets (UncheckedProperty p) = UncheckedProperty (tightenTargets p)
+
-- | Use to indicate that a Property is unchecked.
unchecked :: Property i -> UncheckedProperty i
unchecked = UncheckedProperty
diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs
new file mode 100644
index 00000000..f2089ee8
--- /dev/null
+++ b/src/Propellor/Types/Singletons.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-}
+
+-- | Simple implementation of singletons, portable back to ghc 7.6.3
+
+module Propellor.Types.Singletons (
+ module Propellor.Types.Singletons,
+ KProxy(..)
+) where
+
+#if __GLASGOW_HASKELL__ > 707
+import Data.Proxy (KProxy(..))
+#else
+data KProxy (a :: *) = KProxy
+#endif
+
+-- | The data family of singleton types.
+data family Sing (x :: k)
+
+-- | A class used to pass singleton values implicitly.
+class SingI t where
+ sing :: Sing t
+
+-- Lists of singletons
+data instance Sing (x :: [k]) where
+ Nil :: Sing '[]
+ Cons :: Sing x -> Sing xs -> Sing (x ': xs)
+instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing
+instance SingI '[] where sing = Nil
+
+data instance Sing (x :: Bool) where
+ TrueS :: Sing 'True
+ FalseS :: Sing 'False
+instance SingI 'True where sing = TrueS
+instance SingI 'False where sing = FalseS
+
+class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where
+ type DemoteRep kparam :: *
+ -- | From singleton to value.
+ fromSing :: Sing (a :: k) -> DemoteRep kparam
+
+instance SingKind ('KProxy :: KProxy a) => SingKind ('KProxy :: KProxy [a]) where
+ type DemoteRep ('KProxy :: KProxy [a]) = [DemoteRep ('KProxy :: KProxy a)]
+ fromSing Nil = []
+ fromSing (Cons x xs) = fromSing x : fromSing xs
+
+instance SingKind ('KProxy :: KProxy Bool) where
+ type DemoteRep ('KProxy :: KProxy Bool) = Bool
+ fromSing FalseS = False
+ fromSing TrueS = True
diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs
deleted file mode 100644
index 12447637..00000000
--- a/src/System/Console/Concurrent.hs
+++ /dev/null
@@ -1,44 +0,0 @@
--- |
--- Copyright: 2015 Joey Hess <id@joeyh.name>
--- License: BSD-2-clause
---
--- Concurrent output handling.
---
--- > import Control.Concurrent.Async
--- > import System.Console.Concurrent
--- >
--- > main = withConcurrentOutput $
--- > outputConcurrent "washed the car\n"
--- > `concurrently`
--- > outputConcurrent "walked the dog\n"
--- > `concurrently`
--- > createProcessConcurrent (proc "ls" [])
-
-{-# LANGUAGE CPP #-}
-
-module System.Console.Concurrent (
- -- * Concurrent output
- withConcurrentOutput,
- Outputable(..),
- outputConcurrent,
- errorConcurrent,
- ConcurrentProcessHandle,
-#ifndef mingw32_HOST_OS
- createProcessConcurrent,
-#endif
- waitForProcessConcurrent,
- createProcessForeground,
- flushConcurrentOutput,
- lockOutput,
- -- * Low level access to the output buffer
- OutputBuffer,
- StdHandle(..),
- bufferOutputSTM,
- outputBufferWaiterSTM,
- waitAnyBuffer,
- waitCompleteLines,
- emitOutputBuffer,
-) where
-
-import System.Console.Concurrent.Internal
-
diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs
deleted file mode 100644
index 5b9cf454..00000000
--- a/src/System/Console/Concurrent/Internal.hs
+++ /dev/null
@@ -1,556 +0,0 @@
-{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
-{-# LANGUAGE CPP #-}
-
--- |
--- Copyright: 2015 Joey Hess <id@joeyh.name>
--- License: BSD-2-clause
---
--- Concurrent output handling, internals.
---
--- May change at any time.
-
-module System.Console.Concurrent.Internal where
-
-import System.IO
-#ifndef mingw32_HOST_OS
-import System.Posix.IO
-#endif
-import System.Directory
-import System.Exit
-import Control.Monad
-import Control.Monad.IO.Class (liftIO, MonadIO)
-import System.IO.Unsafe (unsafePerformIO)
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Concurrent.Async
-import Data.Maybe
-import Data.List
-import Data.Monoid
-import qualified System.Process as P
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Control.Applicative
-import Prelude
-import System.Log.Logger
-
-import Utility.Monad
-import Utility.Exception
-
-data OutputHandle = OutputHandle
- { outputLock :: TMVar Lock
- , outputBuffer :: TMVar OutputBuffer
- , errorBuffer :: TMVar OutputBuffer
- , outputThreads :: TMVar Integer
- , processWaiters :: TMVar [Async ()]
- , waitForProcessLock :: TMVar ()
- }
-
-data Lock = Locked
-
--- | A shared global variable for the OutputHandle.
-{-# NOINLINE globalOutputHandle #-}
-globalOutputHandle :: OutputHandle
-globalOutputHandle = unsafePerformIO $ OutputHandle
- <$> newEmptyTMVarIO
- <*> newTMVarIO (OutputBuffer [])
- <*> newTMVarIO (OutputBuffer [])
- <*> newTMVarIO 0
- <*> newTMVarIO []
- <*> newEmptyTMVarIO
-
--- | Holds a lock while performing an action. This allows the action to
--- perform its own output to the console, without using functions from this
--- module.
---
--- While this is running, other threads that try to lockOutput will block.
--- Any calls to `outputConcurrent` and `createProcessConcurrent` will not
--- block, but the output will be buffered and displayed only once the
--- action is done.
-lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
-lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock)
-
--- | Blocks until we have the output lock.
-takeOutputLock :: IO ()
-takeOutputLock = void $ takeOutputLock' True
-
--- | Tries to take the output lock, without blocking.
-tryTakeOutputLock :: IO Bool
-tryTakeOutputLock = takeOutputLock' False
-
-withLock :: (TMVar Lock -> STM a) -> IO a
-withLock a = atomically $ a (outputLock globalOutputHandle)
-
-takeOutputLock' :: Bool -> IO Bool
-takeOutputLock' block = do
- locked <- withLock $ \l -> do
- v <- tryTakeTMVar l
- case v of
- Just Locked
- | block -> retry
- | otherwise -> do
- -- Restore value we took.
- putTMVar l Locked
- return False
- Nothing -> do
- putTMVar l Locked
- return True
- when locked $ do
- (outbuf, errbuf) <- atomically $ (,)
- <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])
- <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])
- emitOutputBuffer StdOut outbuf
- emitOutputBuffer StdErr errbuf
- return locked
-
--- | Only safe to call after taking the output lock.
-dropOutputLock :: IO ()
-dropOutputLock = withLock $ void . takeTMVar
-
--- | Use this around any actions that use `outputConcurrent`
--- or `createProcessConcurrent`
---
--- This is necessary to ensure that buffered concurrent output actually
--- gets displayed before the program exits.
-withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a
-withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput
-
--- | Blocks until any processes started by `createProcessConcurrent` have
--- finished, and any buffered output is displayed. Also blocks while
--- `lockOutput` is is use.
---
--- `withConcurrentOutput` calls this at the end, so you do not normally
--- need to use this.
-flushConcurrentOutput :: IO ()
-flushConcurrentOutput = do
- atomically $ do
- r <- takeTMVar (outputThreads globalOutputHandle)
- if r <= 0
- then putTMVar (outputThreads globalOutputHandle) r
- else retry
- -- Take output lock to wait for anything else that might be
- -- currently generating output.
- lockOutput $ return ()
-
--- | Values that can be output.
-class Outputable v where
- toOutput :: v -> T.Text
-
-instance Outputable T.Text where
- toOutput = id
-
-instance Outputable String where
- toOutput = toOutput . T.pack
-
--- | Displays a value to stdout.
---
--- No newline is appended to the value, so if you want a newline, be sure
--- to include it yourself.
---
--- Uses locking to ensure that the whole output occurs atomically
--- even when other threads are concurrently generating output.
---
--- When something else is writing to the console at the same time, this does
--- not block. It buffers the value, so it will be displayed once the other
--- writer is done.
-outputConcurrent :: Outputable v => v -> IO ()
-outputConcurrent = outputConcurrent' StdOut
-
--- | Like `outputConcurrent`, but displays to stderr.
---
--- (Does not throw an exception.)
-errorConcurrent :: Outputable v => v -> IO ()
-errorConcurrent = outputConcurrent' StdErr
-
-outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()
-outputConcurrent' stdh v = bracket setup cleanup go
- where
- setup = tryTakeOutputLock
- cleanup False = return ()
- cleanup True = dropOutputLock
- go True = do
- T.hPutStr h (toOutput v)
- hFlush h
- go False = do
- oldbuf <- atomically $ takeTMVar bv
- newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf
- atomically $ putTMVar bv newbuf
- h = toHandle stdh
- bv = bufferFor stdh
-
-newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
-
-toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h)
-
--- | Use this to wait for processes started with
--- `createProcessConcurrent` and `createProcessForeground`, and get their
--- exit status.
---
--- Note that such processes are actually automatically waited for
--- internally, so not calling this explicitly will not result
--- in zombie processes. This behavior differs from `P.waitForProcess`
-waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
-waitForProcessConcurrent (ConcurrentProcessHandle h) =
- bracket lock unlock checkexit
- where
- lck = waitForProcessLock globalOutputHandle
- lock = atomically $ tryPutTMVar lck ()
- unlock True = atomically $ takeTMVar lck
- unlock False = return ()
- checkexit locked = maybe (waitsome locked) return
- =<< P.getProcessExitCode h
- waitsome True = do
- let v = processWaiters globalOutputHandle
- l <- atomically $ readTMVar v
- if null l
- -- Avoid waitAny [] which blocks forever
- then P.waitForProcess h
- else do
- -- Wait for any of the running
- -- processes to exit. It may or may not
- -- be the one corresponding to the
- -- ProcessHandle. If it is,
- -- getProcessExitCode will succeed.
- void $ tryIO $ waitAny l
- checkexit True
- waitsome False = do
- -- Another thread took the lck first. Wait for that thread to
- -- wait for one of the running processes to exit.
- atomically $ do
- putTMVar lck ()
- takeTMVar lck
- checkexit False
-
--- Registers an action that waits for a process to exit,
--- adding it to the processWaiters list, and removing it once the action
--- completes.
-asyncProcessWaiter :: IO () -> IO ()
-asyncProcessWaiter waitaction = do
- regdone <- newEmptyTMVarIO
- waiter <- async $ do
- self <- atomically (takeTMVar regdone)
- waitaction `finally` unregister self
- register waiter regdone
- where
- v = processWaiters globalOutputHandle
- register waiter regdone = atomically $ do
- l <- takeTMVar v
- putTMVar v (waiter:l)
- putTMVar regdone waiter
- unregister waiter = atomically $ do
- l <- takeTMVar v
- putTMVar v (filter (/= waiter) l)
-
--- | Wrapper around `System.Process.createProcess` that prevents
--- multiple processes that are running concurrently from writing
--- to stdout/stderr at the same time.
---
--- If the process does not output to stdout or stderr, it's run
--- by createProcess entirely as usual. Only processes that can generate
--- output are handled specially:
---
--- A process is allowed to write to stdout and stderr in the usual
--- way, assuming it can successfully take the output lock.
---
--- When the output lock is held (ie, by another concurrent process,
--- or because `outputConcurrent` is being called at the same time),
--- the process is instead run with its stdout and stderr
--- redirected to a buffer. The buffered output will be displayed as soon
--- as the output lock becomes free.
---
--- Currently only available on Unix systems, not Windows.
-#ifndef mingw32_HOST_OS
-createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-createProcessConcurrent p
- | willOutput (P.std_out p) || willOutput (P.std_err p) =
- ifM tryTakeOutputLock
- ( fgProcess p
- , bgProcess p
- )
- | otherwise = do
- r@(_, _, _, h) <- P.createProcess p
- asyncProcessWaiter $
- void $ tryIO $ P.waitForProcess h
- return (toConcurrentProcessHandle r)
-#endif
-
--- | Wrapper around `System.Process.createProcess` that makes sure a process
--- is run in the foreground, with direct access to stdout and stderr.
--- Useful when eg, running an interactive process.
-createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-createProcessForeground p = do
- takeOutputLock
- fgProcess p
-
-fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-fgProcess p = do
- r@(_, _, _, h) <- P.createProcess p
- `onException` dropOutputLock
- registerOutputThread
- debug ["fgProcess", showProc p]
- -- Wait for the process to exit and drop the lock.
- asyncProcessWaiter $ do
- void $ tryIO $ P.waitForProcess h
- unregisterOutputThread
- dropOutputLock
- debug ["fgProcess done", showProc p]
- return (toConcurrentProcessHandle r)
-
-debug :: [String] -> IO ()
-debug = debugM "concurrent-output" . unwords
-
-showProc :: P.CreateProcess -> String
-showProc = go . P.cmdspec
- where
- go (P.ShellCommand s) = s
- go (P.RawCommand c ps) = show (c, ps)
-
-#ifndef mingw32_HOST_OS
-bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-bgProcess p = do
- (toouth, fromouth) <- pipe
- (toerrh, fromerrh) <- pipe
- debug ["bgProcess", showProc p]
- let p' = p
- { P.std_out = rediroutput (P.std_out p) toouth
- , P.std_err = rediroutput (P.std_err p) toerrh
- }
- registerOutputThread
- r@(_, _, _, h) <- P.createProcess p'
- `onException` unregisterOutputThread
- asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h
- outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth
- errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh
- void $ async $ bufferWriter [outbuf, errbuf]
- return (toConcurrentProcessHandle r)
- where
- pipe = do
- (from, to) <- createPipe
- (,) <$> fdToHandle to <*> fdToHandle from
- rediroutput ss h
- | willOutput ss = P.UseHandle h
- | otherwise = ss
-#endif
-
-willOutput :: P.StdStream -> Bool
-willOutput P.Inherit = True
-willOutput _ = False
-
--- | Buffered output.
-data OutputBuffer = OutputBuffer [OutputBufferedActivity]
- deriving (Eq)
-
-data StdHandle = StdOut | StdErr
-
-toHandle :: StdHandle -> Handle
-toHandle StdOut = stdout
-toHandle StdErr = stderr
-
-bufferFor :: StdHandle -> TMVar OutputBuffer
-bufferFor StdOut = outputBuffer globalOutputHandle
-bufferFor StdErr = errorBuffer globalOutputHandle
-
-data OutputBufferedActivity
- = Output T.Text
- | InTempFile
- { tempFile :: FilePath
- , endsInNewLine :: Bool
- }
- deriving (Eq)
-
-data AtEnd = AtEnd
- deriving Eq
-
-data BufSig = BufSig
-
-setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-setupOutputBuffer h toh ss fromh = do
- hClose toh
- buf <- newMVar (OutputBuffer [])
- bufsig <- atomically newEmptyTMVar
- bufend <- atomically newEmptyTMVar
- void $ async $ outputDrainer ss fromh buf bufsig bufend
- return (h, buf, bufsig, bufend)
-
--- Drain output from the handle, and buffer it.
-outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
-outputDrainer ss fromh buf bufsig bufend
- | willOutput ss = go
- | otherwise = atend
- where
- go = do
- t <- T.hGetChunk fromh
- if T.null t
- then atend
- else do
- modifyMVar_ buf $ addOutputBuffer (Output t)
- changed
- go
- atend = do
- atomically $ putTMVar bufend AtEnd
- hClose fromh
- changed = atomically $ do
- void $ tryTakeTMVar bufsig
- putTMVar bufsig BufSig
-
-registerOutputThread :: IO ()
-registerOutputThread = do
- let v = outputThreads globalOutputHandle
- atomically $ putTMVar v . succ =<< takeTMVar v
-
-unregisterOutputThread :: IO ()
-unregisterOutputThread = do
- let v = outputThreads globalOutputHandle
- atomically $ putTMVar v . pred =<< takeTMVar v
-
--- Wait to lock output, and once we can, display everything
--- that's put into the buffers, until the end.
---
--- If end is reached before lock is taken, instead add the command's
--- buffers to the global outputBuffer and errorBuffer.
-bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO ()
-bufferWriter ts = do
- activitysig <- atomically newEmptyTMVar
- worker1 <- async $ lockOutput $
- ifM (atomically $ tryPutTMVar activitysig ())
- ( void $ mapConcurrently displaybuf ts
- , noop -- buffers already moved to global
- )
- worker2 <- async $ void $ globalbuf activitysig worker1
- void $ async $ do
- void $ waitCatch worker1
- void $ waitCatch worker2
- unregisterOutputThread
- where
- displaybuf v@(outh, buf, bufsig, bufend) = do
- change <- atomically $
- (Right <$> takeTMVar bufsig)
- `orElse`
- (Left <$> takeTMVar bufend)
- l <- takeMVar buf
- putMVar buf (OutputBuffer [])
- emitOutputBuffer outh l
- case change of
- Right BufSig -> displaybuf v
- Left AtEnd -> return ()
- globalbuf activitysig worker1 = do
- ok <- atomically $ do
- -- signal we're going to handle it
- -- (returns false if the displaybuf already did)
- ok <- tryPutTMVar activitysig ()
- -- wait for end of all buffers
- when ok $
- mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts
- return ok
- when ok $ do
- -- add all of the command's buffered output to the
- -- global output buffer, atomically
- bs <- forM ts $ \(outh, buf, _bufsig, _bufend) ->
- (outh,) <$> takeMVar buf
- atomically $
- forM_ bs $ \(outh, b) ->
- bufferOutputSTM' outh b
- -- worker1 might be blocked waiting for the output
- -- lock, and we've already done its job, so cancel it
- cancel worker1
-
--- Adds a value to the OutputBuffer. When adding Output to a Handle,
--- it's cheaper to combine it with any already buffered Output to that
--- same Handle.
---
--- When the total buffered Output exceeds 1 mb in size, it's moved out of
--- memory, to a temp file. This should only happen rarely, but is done to
--- avoid some verbose process unexpectedly causing excessive memory use.
-addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
-addOutputBuffer (Output t) (OutputBuffer buf)
- | T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other)
- | otherwise = do
- tmpdir <- getTemporaryDirectory
- (tmp, h) <- openTempFile tmpdir "output.tmp"
- let !endnl = endsNewLine t'
- let i = InTempFile
- { tempFile = tmp
- , endsInNewLine = endnl
- }
- T.hPutStr h t'
- hClose h
- return $ OutputBuffer (i : other)
- where
- !t' = T.concat (mapMaybe getOutput this) <> t
- !(this, other) = partition isOutput buf
- isOutput v = case v of
- Output _ -> True
- _ -> False
- getOutput v = case v of
- Output t'' -> Just t''
- _ -> Nothing
-addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf)
-
--- | Adds a value to the output buffer for later display.
---
--- Note that buffering large quantities of data this way will keep it
--- resident in memory until it can be displayed. While `outputConcurrent`
--- uses temp files if the buffer gets too big, this STM function cannot do
--- so.
-bufferOutputSTM :: Outputable v => StdHandle -> v -> STM ()
-bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)])
-
-bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()
-bufferOutputSTM' h (OutputBuffer newbuf) = do
- (OutputBuffer buf) <- takeTMVar bv
- putTMVar bv (OutputBuffer (newbuf ++ buf))
- where
- bv = bufferFor h
-
--- | A STM action that waits for some buffered output to become
--- available, and returns it.
---
--- The function can select a subset of output when only some is desired;
--- the fst part is returned and the snd is left in the buffer.
---
--- This will prevent it from being displayed in the usual way, so you'll
--- need to use `emitOutputBuffer` to display it yourself.
-outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)
-outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr
- where
- waitgetbuf h = do
- let bv = bufferFor h
- (selected, rest) <- selector <$> takeTMVar bv
- when (selected == OutputBuffer [])
- retry
- putTMVar bv rest
- return (h, selected)
-
-waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)
-waitAnyBuffer b = (b, OutputBuffer [])
-
--- | Use with `outputBufferWaiterSTM` to make it only return buffered
--- output that ends with a newline. Anything buffered without a newline
--- is left in the buffer.
-waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer)
-waitCompleteLines (OutputBuffer l) =
- let (selected, rest) = span completeline l
- in (OutputBuffer selected, OutputBuffer rest)
- where
- completeline (v@(InTempFile {})) = endsInNewLine v
- completeline (Output b) = endsNewLine b
-
-endsNewLine :: T.Text -> Bool
-endsNewLine t = not (T.null t) && T.last t == '\n'
-
--- | Emits the content of the OutputBuffer to the Handle
---
--- If you use this, you should use `lockOutput` to ensure you're the only
--- thread writing to the console.
-emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
-emitOutputBuffer stdh (OutputBuffer l) =
- forM_ (reverse l) $ \ba -> case ba of
- Output t -> emit t
- InTempFile tmp _ -> do
- emit =<< T.readFile tmp
- void $ tryWhenExists $ removeFile tmp
- where
- outh = toHandle stdh
- emit t = void $ tryIO $ do
- T.hPutStr outh t
- hFlush outh
diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs
deleted file mode 100644
index 0e00e4fd..00000000
--- a/src/System/Process/Concurrent.hs
+++ /dev/null
@@ -1,34 +0,0 @@
--- |
--- Copyright: 2015 Joey Hess <id@joeyh.name>
--- License: BSD-2-clause
---
--- The functions exported by this module are intended to be drop-in
--- replacements for those from System.Process, when converting a whole
--- program to use System.Console.Concurrent.
-
-module System.Process.Concurrent where
-
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
-import System.Process hiding (createProcess, waitForProcess)
-import System.IO
-import System.Exit
-
--- | Calls `createProcessConcurrent`
---
--- You should use the waitForProcess in this module on the resulting
--- ProcessHandle. Using System.Process.waitForProcess instead can have
--- mildly unexpected results.
-createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess p = do
- (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p
- return (i, o, e, h)
-
--- | Calls `waitForProcessConcurrent`
---
--- You should only use this on a ProcessHandle obtained by calling
--- createProcess from this module. Using this with a ProcessHandle
--- obtained from System.Process.createProcess etc will have extremely
--- unexpected results; it can wait a very long time before returning.
-waitForProcess :: ProcessHandle -> IO ExitCode
-waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle