diff options
97 files changed, 2330 insertions, 2264 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 +standardSystem :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian) +standardSystem suite arch motd = + standardSystemUnhardened suite arch motd + `before` Ssh.noPasswords -standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host -standardSystemUnhardened hn suite arch motd = host hn - & os (System (Debian suite) arch) +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 #-} +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} -module Propellor.Info where +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) +-- | 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 -pureInfoProperty' :: Desc -> Info -> Property HasInfo -pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty +-- | 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" +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 NoInfo +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 + buildchroot (ChrootTarball tb) _ loc = Right $ + tightenTargets $ extractTarball loc tb -extractTarball :: FilePath -> FilePath -> Property HasInfo -extractTarball target src = toProp . - check (unpopulated target) $ - cmdProperty "tar" params - `assume` MadeChange - `requires` File.dirExists target +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) +-- > & 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 -instance PropertyList PropList where - propertyList desc = propertyList desc . getProperties - combineProperties desc = combineProperties desc . getProperties +-- | 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 :: [Property i] -> Result -> Propellor Result +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. -- --- A property can have associated `Info` or not. This is tracked at the --- type level with Property `NoInfo` and Property `HasInfo`. +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- There are many instances and type families, which are mostly used +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- 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 +data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] --- | 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 +instance Show (Property metatypes) where + show p = "property " ++ show (getDesc p) --- | 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) - --- | Constructs a Property with no Info. -simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo -simpleProperty = SProperty - -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 +-- | 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 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 (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 HasInfo) where - setDesc = setDescR +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) +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 -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 +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) -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 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 |