diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,41 @@ +propellor (2.9.0) unstable; urgency=medium + + * Added basic Uwsgi module, maintained by Félix Sipma. + * Add Apt.hasForeignArch. Thanks, Per Olofsson. + * Improved documentation, particularly of the Propellor module. + * The Propellor module no longer exports many of the things it used to, + being now focused on only what's needed to write config.hs. + Use Propellor.Base to get all the things exported by Propellor before. + (API change) + * Some renaming of instance methods, and moving of functions to more + appropriate modules. (API change) + * Added File.isSymlinkedTo. Thanks, Per Olofsson. + * fileProperty, and properties derived from it now write the new + file content via origfile.propellor-new~, instead of to a randomly named + temp file. This allows them to clean up any temp file that may have + been left by an interrupted run of propellor. + * Added Propellor.Property.Spin, which can be used to make a host be a + controller of other hosts, which will automatically spin them each time + propellor is run. + * Ssh.keyImported is replaced with Ssh.userKeys. (API change) + The new property only gets the private key from the privdata; the + public key is provided as a parameter, and so is available as + Info that other properties can use. + * Ssh.keyImported' is renamed to Ssh.userKeyAt, and also changed + to only import the private key from the privdata. (API change) + * While Ssh.keyImported and Ssh.keyImported' avoided updating existing + keys, the new Ssh.userKeys and Ssh.userKeyAt properties will + always update out of date key files. + * Ssh.pubKey renamed to Ssh.hostPubKey. (API change) + * Added --unset-unused + * Fix typo: propigate → propagate. Thanks, Felix Gruber. + (A minor API change) + * Chroot: Converted to use a ChrootBootstrapper type class, so + other ways to bootstrap chroots can easily be added in separate + modules. (API change) + + -- Joey Hess Tue, 20 Oct 2015 15:43:12 -0400 + propellor (2.8.1) unstable; urgency=medium * Guard against power loss etc when building propellor, by updating @@ -272,7 +310,7 @@ propellor (1.2.2) unstable; urgency=medium * Revert ensureProperty warning message, too many false positives in places - where Info is correctly propigated. Better approach needed. + where Info is correctly propagated. Better approach needed. -- Joey Hess Sun, 21 Dec 2014 21:41:11 -0400 diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -3,7 +3,6 @@ module Main where import Propellor -import Propellor.CmdLine import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt @@ -17,9 +16,9 @@ import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Dns as Dns import qualified Propellor.Property.OpenId as OpenId -import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Git as Git import qualified Propellor.Property.Postfix as Postfix +import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg @@ -104,7 +103,11 @@ & ipv4 "167.88.41.194" & CloudAtCost.decruft - & Ssh.randomHostKeys + & Ssh.hostKeys hostContext + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAI3WUq0RaigLlcUivgNG4sXpso2ORZkMvfqKz6zkc60L6dpxvWDNmZVEH8hEjxRSYG07NehcuOgQqeyFnS++xw1hdeGjf37JqCUH49i02lra3Zxv8oPpRxyeqe5MmuzUJhlWvBdlc3O/nqZ4bTUfnxMzSYWyy6++s/BpSHttZplNAAAAFQC1DE0vzgVeNAv9smHLObQWZFe2VQAAAIBECtpJry3GC8NVTFsTHDGWksluoFPIbKiZUFFztZGdM0AO2VwAbiJ6Au6M3VddGFANgTlni6d2/9yS919zO90TaFoIjywZeXhxE2CSuRfU7sx2hqDBk73jlycem/ER0sanFhzpHVpwmLfWneTXImWyq37vhAxatJANOtbj81vQ3AAAAIBV3lcyTT9xWg1Q4vERJbvyF8mCliwZmnIPa7ohveKkxlcgUk5d6dnaqFfjVaiXBPN3Qd08WXoQ/a9k3chBPT9nW2vWgzzM8l36j2MbHLmaxGwevAc9+vx4MXqvnGHzd2ex950mC33ct3j0fzMZlO6vqEsgD4CYmiASxhfefj+JCQ==") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDJybAjUPUWIhvVMmer8K5ZgdfI54DM6vc8Mzw+5KmVKL0TwkvzbR1HAB4heyMGtN1F8YzkWhsI3/Txh+MQUJ+i4u8SvSYc6D1q3j3ZyCi06wZ3DJS25tZrOM/thOOA1DFA4Hhb0uI/1Kg8PguNNNSMXn8F7q3F6cFQizYgszs6z6ktiST/BTC+IXWovhcnn2vQXXU8FTcTsqBFqA5dEjZbp1WDzqp3km84ZyXGmoVlpqzXeMvlkWTIshYiQjXIwPOkALzlGYjp1lw1OaxPVI1IGFcgCbIWQQWoCReb+genX2VaR+odAYXjaOdRx0lQj7UCPTBCpqMyzBMLtT5Yiaqh") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBPhfvcOuw0Yt+MnsFc4TI2gWkKi62Eajxz+TgbHMO/uRTYF8c5V8fOI3o+J/3m5+lT0S5o8j8a7xIC3COvi+AVw=") + ] & Apt.unattendedUpgrades & Network.ipv6to4 @@ -221,8 +224,10 @@ , "--exclude=.*/tmp/" , "--one-file-system" ] Obnam.OnlyClient (Gpg.GpgKeyId "98147487") - `requires` Ssh.keyImported SshRsa (User "root") + `requires` Ssh.userKeys (User "root") (Context "kite.kitenet.net") + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC5Gza2sNqSKfNtUN4dN/Z3rlqw18nijmXFx6df2GtBoZbkIak73uQfDuZLP+AXlyfHocwdkdHEf/zrxgXS4EokQMGLZhJ37Pr3edrEn/NEnqroiffw7kyd7EqaziA6UOezcLTjWGv+Zqg9JhitYs4WWTpNzrPH3yQf1V9FunZnkzb4gJGndts13wGmPEwSuf+QHbgQvjMOMCJwWSNcJGdhDR66hFlxfG26xx50uIczXYAbgLfHp5W6WuR/lcaS9J6i7HAPwcsPDA04XDinrcpl29QwsMW1HyGS/4FSCgrDqNZ2jzP49Bka78iCLRqfl1efyYas/Zo1jQ0x+pxq2RMr root@kite") + ] `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") & Apt.serviceInstalledRunning "ntp" & "/etc/timezone" `File.hasContent` ["US/Eastern"] @@ -299,7 +304,9 @@ & Apt.unattendedUpgrades & Systemd.installed & Systemd.persistentJournal - & Ssh.keyImported SshRsa (User "joey") hostContext + & Ssh.userKeys (User "joey") hostContext + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC4wJuQEGno+nJvtE75IKL6JQ08sJHZ9Bzs9Dvu0zuxSEZE30MWK98/twNwCH9PVf2N9m4apfN7f9GHgHTUongfo8xnLAk4PuBSTV74YgKyOCvNYqANuKKa+76PsS/vFf/or3ct++uTEWsRyYD29cQndufwKA4rthAqHG+fifbLDC53AjcldI0zI1RckpPzT+AMazlnSBFMlpKvGD2uzSXALVRXa3vSqWkWd0z7qmIkpmpq0AAgbDLwrGBcUGV/h0rOa2s8zSeirA0tLmHNROl4cZsX0T/6VBGfBRkrHSxL67xJziATw4WPq6spYlxg84pC/5qJVr9SC5HosppbDqgj joey@elephant") + ] & Apt.serviceInstalledRunning "swapspace" & alias "eubackup.kitenet.net" @@ -322,14 +329,10 @@ & alias "ns3.kitenet.net" & myDnsSecondary - & Docker.configured - & Docker.docked openidProvider - `requires` Apt.serviceInstalledRunning "ntp" - & Docker.docked ancientKitenet - & Docker.docked jerryPlay - & Docker.garbageCollected `period` (Weekly (Just 1)) - & Systemd.nspawned oldusenetShellBox + & Systemd.nspawned ancientKitenet + & Systemd.nspawned openidProvider + `requires` Apt.serviceInstalledRunning "ntp" & JoeySites.scrollBox & alias "scroll.joeyh.name" @@ -349,7 +352,7 @@ & ipv6 "2001:4830:1600:195::2" & Apt.serviceInstalledRunning "aiccu" & Apt.installed ["ssh"] - & Ssh.pubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAACBAIrLX260fY0Jjj/p0syNhX8OyR8hcr6feDPGOj87bMad0k/w/taDSOzpXe0Wet7rvUTbxUjH+Q5wPd4R9zkaSDiR/tCb45OdG6JsaIkmqncwe8yrU+pqSRCxttwbcFe+UU+4AAcinjVedZjVRDj2rRaFPc9BXkPt7ffk8GwEJ31/AAAAFQCG/gOjObsr86vvldUZHCteaJttNQAAAIB5nomvcqOk/TD07DLaWKyG7gAcW5WnfY3WtnvLRAFk09aq1EuiJ6Yba99Zkb+bsxXv89FWjWDg/Z3Psa22JMyi0HEDVsOevy/1sEQ96AGH5ijLzFInfXAM7gaJKXASD7hPbVdjySbgRCdwu0dzmQWHtH+8i1CMVmA2/a5Y/wtlJAAAAIAUZj2US2D378jBwyX1Py7e4sJfea3WSGYZjn4DLlsLGsB88POuh32aOChd1yzF6r6C2sdoPBHQcWBgNGXcx4gF0B5UmyVHg3lIX2NVSG1ZmfuLNJs9iKNu4cHXUmqBbwFYQJBvB69EEtrOw4jSbiTKwHFmqdA/mw1VsMB+khUaVw==" + & Ssh.hostPubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAACBAIrLX260fY0Jjj/p0syNhX8OyR8hcr6feDPGOj87bMad0k/w/taDSOzpXe0Wet7rvUTbxUjH+Q5wPd4R9zkaSDiR/tCb45OdG6JsaIkmqncwe8yrU+pqSRCxttwbcFe+UU+4AAcinjVedZjVRDj2rRaFPc9BXkPt7ffk8GwEJ31/AAAAFQCG/gOjObsr86vvldUZHCteaJttNQAAAIB5nomvcqOk/TD07DLaWKyG7gAcW5WnfY3WtnvLRAFk09aq1EuiJ6Yba99Zkb+bsxXv89FWjWDg/Z3Psa22JMyi0HEDVsOevy/1sEQ96AGH5ijLzFInfXAM7gaJKXASD7hPbVdjySbgRCdwu0dzmQWHtH+8i1CMVmA2/a5Y/wtlJAAAAIAUZj2US2D378jBwyX1Py7e4sJfea3WSGYZjn4DLlsLGsB88POuh32aOChd1yzF6r6C2sdoPBHQcWBgNGXcx4gF0B5UmyVHg3lIX2NVSG1ZmfuLNJs9iKNu4cHXUmqBbwFYQJBvB69EEtrOw4jSbiTKwHFmqdA/mw1VsMB+khUaVw==" & alias "usbackup.kitenet.net" & JoeySites.backupsBackedupFrom hosts "eubackup.kitenet.net" "/home/joey/lib/backup" & Apt.serviceInstalledRunning "anacron" @@ -424,40 +427,36 @@ webserver :: Systemd.Container webserver = standardStableContainer "webserver" & Systemd.bind "/var/www" - & Apt.serviceInstalledRunning "apache2" + & Apache.installed -- My own openid provider. Uses php, so containerized for security -- and administrative sanity. -openidProvider :: Docker.Container -openidProvider = standardStableDockerContainer "openid-provider" - & alias "openid.kitenet.net" - & Docker.publish "8081:80" - & OpenId.providerFor [User "joey", User "liw"] - "openid.kitenet.net:8081" +openidProvider :: Systemd.Container +openidProvider = standardStableContainer "openid-provider" + & alias hn + & OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081)) + where + hn = "openid.kitenet.net" --- Exhibit: kite's 90's website. -ancientKitenet :: Docker.Container -ancientKitenet = standardStableDockerContainer "ancient-kitenet" - & alias "ancient.kitenet.net" - & Docker.publish "1994:80" - & Apt.serviceInstalledRunning "apache2" +-- Exhibit: kite's 90's website on port 1994. +ancientKitenet :: Systemd.Container +ancientKitenet = standardStableContainer "ancient-kitenet" + & alias hn & Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html" (Just "remotes/origin/old-kitenet.net") + & Apache.installed + & Apache.listenPorts [p] + & Apache.virtualHost hn p "/var/www/html" + & Apache.siteDisabled "000-default" + where + p = Port 1994 + hn = "ancient.kitenet.net" oldusenetShellBox :: Systemd.Container oldusenetShellBox = standardStableContainer "oldusenet-shellbox" & alias "shell.olduse.net" & JoeySites.oldUseNetShellBox -jerryPlay :: Docker.Container -jerryPlay = standardDockerContainer "jerryplay" Unstable "amd64" - & alias "jerryplay.kitenet.net" - & Docker.publish "2202:22" - & Docker.publish "8001:80" - & Apt.installed ["ssh"] - & User.hasPassword (User "root") - & Ssh.permitRootLogin (Ssh.RootLogin True) - kiteShellBox :: Systemd.Container kiteShellBox = standardStableContainer "kiteshellbox" & JoeySites.kiteShellBox @@ -505,26 +504,6 @@ standardStableContainer :: Systemd.MachineName -> Systemd.Container standardStableContainer name = standardContainer name (Stable "jessie") "amd64" -standardStableDockerContainer :: Docker.ContainerName -> Docker.Container -standardStableDockerContainer name = standardDockerContainer name (Stable "jessie") "amd64" - -standardDockerContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container -standardDockerContainer name suite arch = Docker.container name (dockerImage system) - & os system - & Apt.stdSourcesList `onChange` Apt.upgrade - & Apt.unattendedUpgrades - & Apt.cacheCleaned - & Docker.tweaked - where - system = System (Debian suite) arch - --- Docker images I prefer to use. -dockerImage :: System -> Docker.Image -dockerImage (System (Debian Unstable) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch) -dockerImage (System (Debian Testing) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch) -dockerImage (System (Debian (Stable _)) arch) = Docker.latestImage ("joeyh/debian-stable-" ++ arch) -dockerImage _ = Docker.latestImage "debian-stable-official" -- does not currently exist! - myDnsSecondary :: Property HasInfo myDnsSecondary = propertyList "dns secondary for all my domains" $ props & Dns.secondary hosts "kitenet.net" @@ -553,11 +532,11 @@ monsters :: [Host] -- Systems I don't manage with propellor, monsters = -- but do want to track their public keys etc. [ host "usw-s002.rsync.net" - & Ssh.pubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ==" + & Ssh.hostPubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ==" , host "github.com" - & Ssh.pubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" + & Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" , host "gitlab.com" - & Ssh.pubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" + & Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" , host "ns6.gandi.net" & ipv4 "217.70.177.40" , host "turtle.kitenet.net" diff --git a/config-simple.hs b/config-simple.hs --- a/config-simple.hs +++ b/config-simple.hs @@ -2,13 +2,12 @@ -- the propellor program. import Propellor -import Propellor.CmdLine -import Propellor.Property.Scheduled 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 @@ -19,25 +18,25 @@ main = defaultMain hosts -- The hosts propellor knows about. --- Edit this to configure propellor! hosts :: [Host] hosts = - [ host "mybox.example.com" - & os (System (Debian 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 * * * *") - - -- add more hosts here... - --, host "foo.example.com" = ... + [ mybox ] + +-- An example host. +mybox :: Host +mybox = host "mybox.example.com" + & os (System (Debian 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 diff --git a/config.hs b/config.hs --- a/config.hs +++ b/config.hs @@ -2,13 +2,12 @@ -- the propellor program. import Propellor -import Propellor.CmdLine -import Propellor.Property.Scheduled 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 @@ -19,25 +18,25 @@ main = defaultMain hosts -- The hosts propellor knows about. --- Edit this to configure propellor! hosts :: [Host] hosts = - [ host "mybox.example.com" - & os (System (Debian 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 * * * *") - - -- add more hosts here... - --, host "foo.example.com" = ... + [ mybox ] + +-- An example host. +mybox :: Host +mybox = host "mybox.example.com" + & os (System (Debian 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 diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,41 @@ +propellor (2.9.0) unstable; urgency=medium + + * Added basic Uwsgi module, maintained by Félix Sipma. + * Add Apt.hasForeignArch. Thanks, Per Olofsson. + * Improved documentation, particularly of the Propellor module. + * The Propellor module no longer exports many of the things it used to, + being now focused on only what's needed to write config.hs. + Use Propellor.Base to get all the things exported by Propellor before. + (API change) + * Some renaming of instance methods, and moving of functions to more + appropriate modules. (API change) + * Added File.isSymlinkedTo. Thanks, Per Olofsson. + * fileProperty, and properties derived from it now write the new + file content via origfile.propellor-new~, instead of to a randomly named + temp file. This allows them to clean up any temp file that may have + been left by an interrupted run of propellor. + * Added Propellor.Property.Spin, which can be used to make a host be a + controller of other hosts, which will automatically spin them each time + propellor is run. + * Ssh.keyImported is replaced with Ssh.userKeys. (API change) + The new property only gets the private key from the privdata; the + public key is provided as a parameter, and so is available as + Info that other properties can use. + * Ssh.keyImported' is renamed to Ssh.userKeyAt, and also changed + to only import the private key from the privdata. (API change) + * While Ssh.keyImported and Ssh.keyImported' avoided updating existing + keys, the new Ssh.userKeys and Ssh.userKeyAt properties will + always update out of date key files. + * Ssh.pubKey renamed to Ssh.hostPubKey. (API change) + * Added --unset-unused + * Fix typo: propigate → propagate. Thanks, Felix Gruber. + (A minor API change) + * Chroot: Converted to use a ChrootBootstrapper type class, so + other ways to bootstrap chroots can easily be added in separate + modules. (API change) + + -- Joey Hess Tue, 20 Oct 2015 15:43:12 -0400 + propellor (2.8.1) unstable; urgency=medium * Guard against power loss etc when building propellor, by updating @@ -272,7 +310,7 @@ propellor (1.2.2) unstable; urgency=medium * Revert ensureProperty warning message, too many false positives in places - where Info is correctly propigated. Better approach needed. + where Info is correctly propagated. Better approach needed. -- Joey Hess Sun, 21 Dec 2014 21:41:11 -0400 diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.8.1 +Version: 2.9.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -69,6 +69,8 @@ Exposed-Modules: Propellor + Propellor.Base + Propellor.Location Propellor.Property Propellor.Property.Aiccu Propellor.Property.Apache @@ -92,6 +94,9 @@ Propellor.Property.Grub Propellor.Property.Journald Propellor.Property.Kerberos + Propellor.Property.List + Propellor.Property.LightDM + Propellor.Property.Logcheck Propellor.Property.Mount Propellor.Property.Network Propellor.Property.Nginx @@ -104,9 +109,7 @@ Propellor.Property.Prosody Propellor.Property.Reboot Propellor.Property.Rsync - Propellor.Property.List - Propellor.Property.LightDM - Propellor.Property.Logcheck + Propellor.Property.Spin Propellor.Property.Scheduled Propellor.Property.Service Propellor.Property.Ssh @@ -116,6 +119,7 @@ Propellor.Property.Tor Propellor.Property.Unbound Propellor.Property.User + Propellor.Property.Uwsgi Propellor.Property.HostingProvider.CloudAtCost Propellor.Property.HostingProvider.DigitalOcean Propellor.Property.HostingProvider.Linode @@ -125,6 +129,7 @@ Propellor.Property.SiteSpecific.Branchable Propellor.Property.SiteSpecific.IABak Propellor.PropAccum + Propellor.Utilities Propellor.CmdLine Propellor.Info Propellor.Message diff --git a/src/Propellor.hs b/src/Propellor.hs --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Pulls in lots of useful modules for building and using Properties. --- --- When propellor runs on a Host, it ensures that its list of Properties --- is satisfied, taking action as necessary when a Property is not +-- | When propellor runs on a Host, it ensures that its Properties +-- are satisfied, taking action as necessary when a Property is not -- currently satisfied. -- -- A simple propellor program example: -- -- > import Propellor --- > import Propellor.CmdLine -- > import qualified Propellor.Property.File as File -- > import qualified Propellor.Property.Apt as Apt -- > @@ -30,54 +27,49 @@ -- git clone module Propellor ( - module Propellor.Types + -- * Core data types + Host(..) + , Property + , RevertableProperty + , () + , module Propellor.Types + -- * Config file + , defaultMain + , host + , (&) + , (!) + -- * Propertries + , describe + -- | Properties are often combined together in your propellor + -- configuration. For example: + -- + -- > "/etc/foo/config" `File.containsLine` "bar=1" + -- > `requires` File.dirExists "/etc/foo" + , requires + , before + , onChange , module Propellor.Property - , module Propellor.Property.List + -- | Everything you need to build your own properties, + -- and useful property combinators , module Propellor.Property.Cmd - , module Propellor.PropAccum + -- | Properties to run shell commands , module Propellor.Info - , module Propellor.PrivData + -- | Properties that set `Info` + , module Propellor.Property.List + -- | Combining a list of properties into a single property , module Propellor.Types.PrivData - , module Propellor.Engine - , module Propellor.Exception - , module Propellor.Message - , localdir + -- | Private data access for properties , module X ) where import Propellor.Types +import Propellor.CmdLine (defaultMain) import Propellor.Property -import Propellor.Engine import Propellor.Property.List import Propellor.Property.Cmd -import Propellor.PrivData import Propellor.Types.PrivData -import Propellor.Message -import Propellor.Exception import Propellor.Info import Propellor.PropAccum -import Utility.PartialPrelude as X -import Utility.Process as X -import Utility.Exception as X -import Utility.Env as X -import Utility.Directory as X -import Utility.Tmp as X -import Utility.Monad as X -import Utility.Misc as X - -import System.Directory as X -import System.IO as X -import System.FilePath as X -import Data.Maybe as X -import Data.Either as X -import Control.Applicative as X -import Control.Monad as X import Data.Monoid as X -import Control.Monad.IfElse as X -import "mtl" Control.Monad.Reader as X - --- | This is where propellor installs itself when deploying a host. -localdir :: FilePath -localdir = "/usr/local/propellor" diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Base.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE PackageImports #-} + +-- | Pulls in lots of useful modules for building and using Properties. + +module Propellor.Base ( + -- * Propellor modules + module Propellor.Types + , module Propellor.Property + , module Propellor.Property.Cmd + , module Propellor.Property.List + , module Propellor.Types.PrivData + , module Propellor.PropAccum + , module Propellor.Info + , module Propellor.PrivData + , module Propellor.Engine + , module Propellor.Exception + , module Propellor.Message + , module Propellor.Location + , module Propellor.Utilities + + -- * System modules + , module System.Directory + , module System.IO + , module System.FilePath + , module Data.Maybe + , module Data.Either + , module Control.Applicative + , module Control.Monad + , module Data.Monoid + , module Control.Monad.IfElse + , module Control.Monad.Reader +) where + +import Propellor.Types +import Propellor.Property +import Propellor.Engine +import Propellor.Property.List +import Propellor.Property.Cmd +import Propellor.PrivData +import Propellor.Types.PrivData +import Propellor.Message +import Propellor.Exception +import Propellor.Info +import Propellor.PropAccum +import Propellor.Location +import Propellor.Utilities + +import System.Directory +import System.IO +import System.FilePath +import Data.Maybe +import Data.Either +import Control.Applicative +import Control.Monad +import Data.Monoid +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -5,7 +5,7 @@ buildPropellor, ) where -import Propellor +import Propellor.Base import System.Posix.Files import Data.List diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -9,7 +9,7 @@ import System.PosixCompat import Network.Socket -import Propellor +import Propellor.Base import Propellor.Gpg import Propellor.Git import Propellor.Bootstrap @@ -27,10 +27,12 @@ , " propellor --spin targethost [--via relayhost]" , " propellor --add-key keyid" , " propellor --rm-key keyid" - , " propellor --set field context" + , " propellor --list-fields" , " propellor --dump field context" , " propellor --edit field context" - , " propellor --list-fields" + , " propellor --set field context" + , " propellor --unset field context" + , " propellor --unset-unused" , " propellor --merge" , " propellor --build" , " propellor --check" @@ -54,6 +56,7 @@ go ("--rm-key":k:[]) = return $ RmKey k go ("--set":f:c:[]) = withprivfield f c Set go ("--unset":f:c:[]) = withprivfield f c Unset + go ("--unset-unused":[]) = return UnsetUnused go ("--dump":f:c:[]) = withprivfield f c Dump go ("--edit":f:c:[]) = withprivfield f c Edit go ("--list-fields":[]) = return ListFields @@ -98,6 +101,7 @@ go _ Check = return () go _ (Set field context) = setPrivData field context go _ (Unset field context) = unsetPrivData field context + go _ (UnsetUnused) = unsetPrivDataUnused hostlist go _ (Dump field context) = dumpPrivData field context go _ (Edit field context) = editPrivData field context go _ ListFields = listPrivDataFields hostlist @@ -113,9 +117,10 @@ go _ Merge = mergeSpin go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin hs r) = do + go False (Spin hs mrelay) = do commitSpin - forM_ hs $ \hn -> withhost hn $ spin hn r + forM_ hs $ \hn -> withhost hn $ + spin (maybe RegularSpin RelaySpin mrelay) hn go False cmdline@(SimpleRun hn) = buildFirst cmdline $ go False (Run hn) go False (Run hn) = ifM ((==) 0 <$> getRealUserID) diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -7,6 +7,7 @@ ensureProperty, ensureProperties, fromHost, + fromHost', onlyProcess, processChainOutput, ) where @@ -26,6 +27,7 @@ import Propellor.Message import Propellor.Exception import Propellor.Info +import Propellor.Property import Utility.Exception import Utility.PartialPrelude import Utility.Monad @@ -62,13 +64,6 @@ (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () return ret --- | 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 - -- | Ensures a list of Properties, with a display of each as it runs. ensureProperties :: [Property NoInfo] -> Propellor Result ensureProperties ps = ensure ps NoChange @@ -79,17 +74,19 @@ r <- actionMessageOn hn (propertyDesc p) (ensureProperty p) ensure ls (r <> rs) --- | Lifts an action into a different host. +-- | Lifts an action into the context of a different host. -- --- > fromHost hosts "otherhost" getPubKey +-- > fromHost hosts "otherhost" Ssh.getHostPubKey fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) fromHost l hn getter = case findHost l hn of Nothing -> return Nothing - Just h -> do - (ret, _s, runlog) <- liftIO $ - runRWST (runWithHost getter) h () - tell runlog - return (Just ret) + Just h -> Just <$> fromHost' h getter + +fromHost' :: Host -> Propellor a -> Propellor a +fromHost' h getter = do + (ret, _s, runlog) <- liftIO $ runRWST (runWithHost getter) h () + tell runlog + return ret onlyProcess :: FilePath -> IO a -> IO a onlyProcess lockfile a = bracket lock unlock (const a) diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -1,6 +1,6 @@ module Propellor.Git where -import Propellor +import Propellor.Base import Propellor.PrivData.Paths import Propellor.Gpg import Utility.FileMode diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -101,3 +101,6 @@ 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/Location.hs b/src/Propellor/Location.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Location.hs @@ -0,0 +1,5 @@ +module Propellor.Location where + +-- | This is where propellor installs itself when deploying a host. +localdir :: FilePath +localdir = "/usr/local/propellor" diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -9,12 +9,14 @@ addPrivData, setPrivData, unsetPrivData, + unsetPrivDataUnused, dumpPrivData, editPrivData, filterPrivData, listPrivDataFields, makePrivDataDir, decryptPrivData, + readPrivData, PrivMap, PrivInfo, forceHostContext, @@ -158,8 +160,21 @@ unsetPrivData :: PrivDataField -> Context -> IO () unsetPrivData field context = do modifyPrivData $ M.delete (field, context) - putStrLn "Private data unset." + descUnset field context +descUnset :: PrivDataField -> Context -> IO () +descUnset field context = + putStrLn $ "Private data unset: " ++ show field ++ " " ++ show context + +unsetPrivDataUnused :: [Host] -> IO () +unsetPrivDataUnused hosts = do + deleted <- modifyPrivData' $ \m -> + let (keep, del) = M.partitionWithKey (\k _ -> k `M.member` usedby) m + in (keep, M.keys del) + mapM_ (uncurry descUnset) deleted + where + usedby = mkUsedByMap hosts + dumpPrivData :: PrivDataField -> Context -> IO () dumpPrivData field context = do maybe (error "Requested privdata is not set.") @@ -199,15 +214,21 @@ , shellEscape context , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby ] - mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $ - S.toList $ fromPrivInfo $ getInfo $ hostInfo host - usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const [hostName h]) hosts + usedby = mkUsedByMap hosts wantedmap = M.fromList $ zip (M.keys usedby) (repeat "") - descmap = M.unions $ map (`mkhostmap` id) hosts + descmap = M.unions $ map (`mkPrivDataMap` id) hosts section desc = putStrLn $ "\n" ++ desc showtable rows = do putStr $ unlines $ formatTable $ tableWithHeader header rows +mkUsedByMap :: [Host] -> M.Map (PrivDataField, Context) [HostName] +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) + setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context (PrivData value) = do modifyPrivData set @@ -216,16 +237,23 @@ set = M.insert (field, context) value modifyPrivData :: (PrivMap -> PrivMap) -> IO () -modifyPrivData f = do +modifyPrivData f = modifyPrivData' (\m -> (f m, ())) + +modifyPrivData' :: (PrivMap -> (PrivMap, a)) -> IO a +modifyPrivData' f = do makePrivDataDir m <- decryptPrivData - let m' = f m + let (m', r) = f m gpgEncrypt privDataFile (show m') void $ boolSystem "git" [Param "add", File privDataFile] + return r decryptPrivData :: IO PrivMap -decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile +decryptPrivData = readPrivData <$> gpgDecrypt privDataFile +readPrivData :: String -> PrivMap +readPrivData = fromMaybe M.empty . readish + makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir @@ -233,10 +261,10 @@ { fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) } deriving (Eq, Ord, Show, Typeable, Monoid) --- PrivInfo is propigated out of containers, so that propellor can see which +-- PrivInfo is propagated out of containers, so that propellor can see which -- hosts need it. instance IsInfo PrivInfo where - propigateInfo _ = True + propagateInfo _ = True -- | Sets the context of any privdata that uses HostContext to the -- provided name. diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -2,11 +2,11 @@ module Propellor.PropAccum ( host - , props , PropAccum(..) + , (&) + , (&^) , (!) - , PropList - , propigateContainer + , propagateContainer ) where import Data.Monoid @@ -25,64 +25,56 @@ host :: HostName -> Host host hn = Host hn [] mempty --- | Starts accumulating a list of properties. --- --- > propertyList "foo" $ props --- > & someproperty --- > ! oldproperty --- > & otherproperty -props :: PropList -props = PropList [] - -- | Something that can accumulate properties. class PropAccum h where -- | Adds a property. - -- - -- Can add Properties and RevertableProperties - (&) :: IsProp p => h -> p -> h + addProp :: IsProp p => h -> p -> h - -- | Like (&), but adds the property at the front of the list. - (&^) :: IsProp p => h -> p -> h + -- | Like addProp, but adds the property at the front of the list. + addPropFront :: IsProp p => h -> p -> h getProperties :: h -> [Property HasInfo] -instance PropAccum Host where - (Host hn ps is) & p = Host hn (ps ++ [toProp p]) - (is <> getInfoRecursive p) - (Host hn ps is) &^ p = Host hn (toProp p : ps) - (getInfoRecursive p <> is) - getProperties = hostProperties - -data PropList = PropList [Property HasInfo] +-- | Adds a property to a `Host` or other `PropAccum` +-- +-- Can add Properties and RevertableProperties +(&) :: (PropAccum h, IsProp p) => h -> p -> h +(&) = addProp -instance PropAccum PropList where - PropList l & p = PropList (toProp p : l) - PropList l &^ p = PropList (l ++ [toProp p]) - getProperties (PropList l) = reverse l +-- | Adds a property before any other properties. +(&^) :: (PropAccum h, IsProp p) => h -> p -> h +(&^) = addPropFront -- | Adds a property in reverted form. (!) :: PropAccum h => h -> RevertableProperty -> h h ! p = h & revert p -infixl 1 &^ 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 propigated out to the Property. +-- 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. -propigateContainer +propagateContainer :: (PropAccum container) => String -> container -> Property HasInfo -> Property HasInfo -propigateContainer containername c prop = infoProperty +propagateContainer containername c prop = infoProperty (propertyDesc prop) (propertySatisfy prop) (propertyInfo prop) @@ -91,6 +83,6 @@ hostprops = map go $ getProperties c go p = let i = mapInfo (forceHostContext containername) - (propigatableInfo (propertyInfo p)) + (propagatableInfo (propertyInfo p)) cs = map go (propertyChildren p) in infoProperty (propertyDesc p) (propertySatisfy p) i cs diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,7 +1,31 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} -module Propellor.Property where +module Propellor.Property ( + -- * Property combinators + requires + , before + , onChange + , onChangeFlagOnFail + , flagFile + , flagFile' + , check + , fallback + , trivial + , revert + -- * Property descriptions + , describe + , (==>) + -- * Constructing properties + , Propellor + , property + , ensureProperty + , withOS + , makeChange + , noChange + , doNothing + , endAction +) where import System.Directory import System.FilePath @@ -12,6 +36,7 @@ import Propellor.Types import Propellor.Info +import Propellor.Exception import Utility.Monad -- | Constructs a Property, from a description and an action to run to @@ -39,6 +64,18 @@ writeFile flagfile "" return r +-- | Indicates that the first property depends on the second, +-- so before the first is ensured, the second must be ensured. +requires :: Combines x y => x -> y -> CombinedType x y +requires = (<<>>) + +-- | Combines together two properties, resulting in one property +-- that ensures the first, and if the first succeeds, ensures the second. +-- +-- The combined property uses the description of the first property. +before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x +before x y = (y `requires` x) `describe` getDesc x + -- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange @@ -88,11 +125,22 @@ writeFile flagfile "" removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile +-- | Changes the description of a property. +describe :: IsProp p => p -> Desc -> p +describe = setDesc + -- | Alias for @flip describe@ (==>) :: IsProp (Property i) => Desc -> Property i -> Property i (==>) = 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 + -- | Makes a Property only need to do anything when a test succeeds. check :: IO Bool -> Property i -> Property i check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c) @@ -125,11 +173,16 @@ -- | Makes a property that is satisfied differently depending on the host's -- operating system. -- --- Note that the operating system may not be declared for some hosts. +-- Note that the operating system may not be declared for all hosts. +-- +-- > myproperty = withOS "foo installed" $ \o -> case o of +-- > (Just (System (Debian suite) arch)) -> ... +-- > (Just (System (Ubuntu release) arch)) -> ... +-- > Nothing -> ... withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS --- | Undoes the effect of a property. +-- | Undoes the effect of a RevertableProperty. revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 @@ -142,6 +195,7 @@ doNothing :: Property NoInfo doNothing = property "noop property" noChange --- | Registers an action that should be run at the very end, +-- | Registers an action that should be run at the very end, after +-- propellor has checks all the properties of a host. endAction :: Desc -> (Result -> Propellor Result) -> Propellor () endAction desc a = tell [EndAction desc a] diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs --- a/src/Propellor/Property/Aiccu.hs +++ b/src/Propellor/Property/Aiccu.hs @@ -9,7 +9,7 @@ hasConfig, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import qualified Propellor.Property.File as File diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -1,10 +1,33 @@ module Propellor.Property.Apache where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service +installed :: Property NoInfo +installed = Apt.installed ["apache2"] + +restarted :: Property NoInfo +restarted = Service.restarted "apache2" + +reloaded :: Property NoInfo +reloaded = Service.reloaded "apache2" + +-- | A basic virtual host, publishing a directory, and logging to +-- the combined apache log file. +virtualHost :: HostName -> Port -> FilePath -> RevertableProperty +virtualHost hn (Port p) docroot = siteEnabled hn + [ "" + , "ServerName "++hn++":"++show p + , "DocumentRoot " ++ docroot + , "ErrorLog /var/log/apache2/error.log" + , "LogLevel warn" + , "CustomLog /var/log/apache2/access.log combined" + , "ServerSignature On" + , "" + ] + type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty @@ -19,13 +42,16 @@ `requires` installed `onChange` reloaded ] - disable = combineProperties - ("apache site disabled " ++ hn) - (map File.notPresent (siteCfg hn)) + disable = siteDisabled hn + isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] + +siteDisabled :: HostName -> Property NoInfo +siteDisabled hn = combineProperties + ("apache site disabled " ++ hn) + (map File.notPresent (siteCfg hn)) `onChange` cmdProperty "a2dissite" ["--quiet", hn] `requires` installed `onChange` reloaded - isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] siteAvailable :: HostName -> ConfigFile -> Property NoInfo siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ @@ -48,6 +74,16 @@ `onChange` reloaded isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname] +-- | Make apache listen on the specified ports. +-- +-- Note that ports are also specified inside a site's config file, +-- so that also needs to be changed. +listenPorts :: [Port] -> Property NoInfo +listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps + `onChange` restarted + where + portline (Port n) = "Listen " ++ show n + -- This is a list of config files because different versions of apache -- use different filenames. Propellor simply writes them all. siteCfg :: HostName -> [FilePath] @@ -57,15 +93,6 @@ -- Debian 2.4+ , "/etc/apache2/sites-available/" ++ hn ++ ".conf" ] - -installed :: Property NoInfo -installed = Apt.installed ["apache2"] - -restarted :: Property NoInfo -restarted = Service.restarted "apache2" - -reloaded :: Property NoInfo -reloaded = Service.reloaded "apache2" -- | Configure apache to use SNI to differentiate between -- https hosts. diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -8,7 +8,7 @@ import System.IO import Control.Monad -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.File (Line) @@ -297,3 +297,11 @@ cacheCleaned :: Property NoInfo cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] `describe` "apt cache cleaned" + +-- | Add a foreign architecture to dpkg and apt. +hasForeignArch :: String -> Property NoInfo +hasForeignArch arch = check notAdded add + `describe` ("dpkg has foreign architecture " ++ arch) + where + notAdded = (not . elem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] + add = cmdProperty "dpkg" ["--add-architecture", arch] `before` update diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, GADTs #-} module Propellor.Property.Chroot ( Chroot(..), - BuilderConf(..), + ChrootBootstrapper(..), + Debootstrapped(..), debootstrapped, + bootstrapped, provisioned, -- * Internal use provisioned', - propigateChrootInfo, + propagateChrootInfo, propellChroot, chain, + chrootSystem, ) where -import Propellor +import Propellor.Base import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info @@ -26,33 +29,57 @@ import Data.List.Utils import System.Posix.Directory -data Chroot = Chroot FilePath System BuilderConf Host - deriving (Show) +-- | Specification of a chroot. Normally you'll use `debootstrapped` or +-- `bootstrapped` to construct a Chroot value. +data Chroot where + Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot -data BuilderConf - = UsingDeboostrap Debootstrap.DebootstrapConfig - deriving (Show) +chrootSystem :: Chroot -> System +chrootSystem (Chroot _ system _ _) = system +instance Show Chroot where + show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system + instance PropAccum Chroot where - (Chroot l s c h) & p = Chroot l s c (h & p) - (Chroot l s c h) &^ p = Chroot l s c (h &^ p) + (Chroot l s c h) `addProp` p = Chroot l s c (h & p) + (Chroot l s c h) `addPropFront` p = Chroot l s 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 Nothing. + buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo) + +-- | Use to bootstrap a chroot with debootstrap. +data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig + +instance ChrootBootstrapper Debootstrapped where + buildchroot (Debootstrapped cf) system loc = case system of + (System (Debian _) _) -> Just debootstrap + (System (Ubuntu _) _) -> Just debootstrap + where + debootstrap = Debootstrap.built loc system cf + -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. -- -- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev" --- > & Apt.installed ["ghc", "haskell-platform"] --- > & ... +-- > & Apt.installed ["ghc", "haskell-platform"] +-- > & ... debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot -debootstrapped system conf location = case system of - (System (Debian _) _) -> mk - (System (Ubuntu _) _) -> mk +debootstrapped system conf = bootstrapped system (Debootstrapped conf) + +-- | Defines a Chroot at the given location, bootstrapped with the +-- specified ChrootBootstrapper. +bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot +bootstrapped system bootstrapper location = + Chroot location system bootstrapper h + & os system where h = Host location [] mempty - mk = Chroot location system (UsingDeboostrap conf) h - & os system -- | Ensures that the chroot exists and is provisioned according to its -- properties. @@ -61,29 +88,29 @@ -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. provisioned :: Chroot -> RevertableProperty -provisioned c = provisioned' (propigateChrootInfo c) c False +provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty -provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = - (propigator $ go "exists" setup) +provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly = + (propigator $ propertyList (chrootDesc c "exists") [setup]) - (go "removed" teardown) + (propertyList (chrootDesc c "removed") [teardown]) where - go desc a = propertyList (chrootDesc c desc) [a] - setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly `requires` toProp built - built = case (system, builderconf) of - ((System (Debian _) _), UsingDeboostrap cf) -> debootstrap cf - ((System (Ubuntu _) _), UsingDeboostrap cf) -> debootstrap cf + built = case buildchroot bootstrapper system loc of + Just p -> p + Nothing -> cantbuild - debootstrap = Debootstrap.built loc system + cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty [] - teardown = toProp (revert built) + teardown = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) -propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo -propigateChrootInfo c@(Chroot location _ _ _) p = propigateContainer location c p' +propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo +propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c p' where p' = infoProperty (propertyDesc p) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs --- a/src/Propellor/Property/Chroot/Util.hs +++ b/src/Propellor/Property/Chroot/Util.hs @@ -2,11 +2,14 @@ import Propellor.Property.Mount +import Utility.Exception import Utility.Env +import Utility.Directory + import Control.Applicative import System.Directory --- When chrooting, it's useful to ensure that PATH has all the standard +-- | When chrooting, it's useful to ensure that PATH has all the standard -- directories in it. This adds those directories to whatever PATH is -- already set. standardPathEnv :: IO [(String, String)] @@ -18,9 +21,13 @@ stdPATH :: String stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" --- Removes the contents of a chroot. First, unmounts any filesystems +-- | Removes the contents of a chroot. First, unmounts any filesystems -- mounted within it. removeChroot :: FilePath -> IO () removeChroot c = do unmountBelow c removeDirectoryRecursive c + +-- | Returns true if a chroot directory is empty. +unpopulated :: FilePath -> IO Bool +unpopulated d = null <$> catchDefaultIO [] (dirContents d) diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs --- a/src/Propellor/Property/ConfFile.hs +++ b/src/Propellor/Property/ConfFile.hs @@ -12,7 +12,7 @@ lacksIniSection, ) where -import Propellor +import Propellor.Base import Propellor.Property.File import Data.List (isPrefixOf, foldl') diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -1,6 +1,6 @@ module Propellor.Property.Cron where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Propellor.Bootstrap diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -7,7 +7,7 @@ , mirrorCdn ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -10,7 +10,7 @@ programPath, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util import Utility.Path @@ -48,19 +48,8 @@ -- -- The System can be any OS and architecture that debootstrap -- and the kernel support. --- --- Reverting this property deletes the chroot and all its contents. --- Anything mounted under the filesystem is first unmounted. --- --- Note that reverting this property does not stop any processes --- currently running in the chroot. -built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty -built target system config = built' (toProp installed) target system config teardown - where - teardown = check (not <$> unpopulated target) teardownprop - - teardownprop = property ("removed debootstrapped " ++ target) $ - makeChange (removeChroot target) +built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo +built target system config = built' (toProp installed) target system config built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) built' installprop target system@(System _ arch) config = @@ -100,9 +89,6 @@ , return False ) -unpopulated :: FilePath -> IO Bool -unpopulated d = null <$> catchDefaultIO [] (dirContents d) - extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -36,7 +36,7 @@ noFinalization, ) where -import Propellor +import Propellor.Base import Propellor.Property.Chroot (Chroot) import Propellor.Property.Chroot.Util (removeChroot) import qualified Propellor.Property.Chroot as Chroot diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -13,7 +13,7 @@ genZone, ) where -import Propellor +import Propellor.Base import Propellor.Types.Dns import Propellor.Types.Info import Propellor.Property.File @@ -524,7 +524,7 @@ genSSHFP :: Domain -> Host -> Propellor [(BindDomain, Record)] genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) where - get = fromHost [h] hostname Ssh.getPubKey + get = fromHost [h] hostname Ssh.getHostPubKey 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) diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -1,6 +1,6 @@ module Propellor.Property.DnsSec where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File -- | Puts the DNSSEC key files in place from PrivData. @@ -71,7 +71,7 @@ , "-3", salt -- The serial number needs to be increased each time the -- zone is resigned, even if there are no other changes, - -- so that it will propigate to secondaries. So, use the + -- so that it will propagate to secondaries. So, use the -- unixtime serial format. , "-N", "unixtime" , "-o", domain diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -45,7 +45,7 @@ chain, ) where -import Propellor hiding (init) +import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container import Propellor.Types.CmdLine @@ -97,8 +97,8 @@ getImageName (Container i _) = i instance PropAccum Container where - (Container i h) & p = Container i (h & p) - (Container i h) &^ p = Container i (h &^ p) + (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. @@ -119,13 +119,13 @@ -- propellor inside the container. -- -- When the container's Properties include DNS info, such as a CNAME, --- that is propigated to the Info of the Host it's docked in. +-- that is propagated to the Info of the Host it's docked in. -- -- Reverting this property ensures that the container is stopped and -- removed. docked :: Container -> RevertableProperty docked ctr@(Container _ h) = - (propigateContainerInfo ctr (go "docked" setup)) + (propagateContainerInfo ctr (go "docked" setup)) (go "undocked" teardown) where @@ -170,8 +170,8 @@ pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] image = getImageName ctr -propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo -propigateContainerInfo ctr@(Container _ h) p = propigateContainer cn ctr p' +propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo +propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty (propertyDesc p) diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -1,6 +1,6 @@ module Propellor.Property.File where -import Propellor +import Propellor.Base import Utility.FileMode import System.Posix.Files @@ -82,12 +82,11 @@ let new = unlines (a (lines old)) if old == new then noChange - else makeChange $ viaTmp updatefile f new + else makeChange $ updatefile new `viaStableTmp` f go False = makeChange $ writer f (unlines $ a []) - -- viaTmp makes the temp file mode 600. -- Replicate the original file's owner and mode. - updatefile f' content = do + updatefile content f' = do writer f' content s <- getFileStatus f setFileMode f' (fileMode s) @@ -98,6 +97,33 @@ dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d +-- | The location that a symbolic link points to. +newtype LinkTarget = LinkTarget FilePath + +-- | Creates or atomically updates a symbolic link. +-- +-- Does not overwrite regular files or directories. +isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo +link `isSymlinkedTo` (LinkTarget target) = property desc $ + go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) + where + desc = link ++ " is symlinked to " ++ target + go (Right stat) = + if isSymbolicLink stat + then checkLink + else nonSymlinkExists + go (Left _) = makeChange $ createSymbolicLink target link + + nonSymlinkExists = do + warningMessage $ link ++ " exists and is not a symlink" + return FailedChange + checkLink = do + target' <- liftIO $ readSymbolicLink link + if target == target' + then noChange + else makeChange updateLink + updateLink = createSymbolicLink target `viaStableTmp` link + -- | Ensures that a file/dir has the specified owner and group. ownerGroup :: FilePath -> User -> Group -> Property NoInfo ownerGroup f (User owner) (Group group) = property (f ++ " owner " ++ og) $ do @@ -113,3 +139,27 @@ mode f v = property (f ++ " mode " ++ show v) $ do liftIO $ modifyFileMode f (const v) noChange + +-- | A temp file to use when writing new content for a file. +-- +-- This is a stable name so it can be removed idempotently. +-- +-- It ends with "~" so that programs that read many config files from a +-- directory will treat it as an editor backup file, and not read it. +stableTmpFor :: FilePath -> FilePath +stableTmpFor f = f ++ ".propellor-new~" + +-- | Creates/updates a file atomically, running the action to create the +-- stable tmp file, and then renaming it into place. +viaStableTmp :: (MonadMask m, MonadIO m) => (FilePath -> m ()) -> FilePath -> m () +viaStableTmp a f = bracketIO setup cleanup go + where + setup = do + createDirectoryIfMissing True (takeDirectory f) + let tmpfile = stableTmpFor f + nukeFile tmpfile + return tmpfile + cleanup tmpfile = tryIO $ removeFile tmpfile + go tmpfile = do + a tmpfile + liftIO $ rename tmpfile f diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -16,7 +16,7 @@ import Data.Char import Data.List -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -1,6 +1,6 @@ module Propellor.Property.Git where -import Propellor +import Propellor.Base import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -1,6 +1,6 @@ module Propellor.Property.Gpg where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import Utility.FileSystemEncoding diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs --- a/src/Propellor/Property/Group.hs +++ b/src/Propellor/Property/Group.hs @@ -1,6 +1,6 @@ module Propellor.Property.Group where -import Propellor +import Propellor.Base type GID = Int diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -1,6 +1,6 @@ module Propellor.Property.Grub where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -1,6 +1,6 @@ module Propellor.Property.HostingProvider.CloudAtCost where -import Propellor +import Propellor.Base import qualified Propellor.Property.Hostname as Hostname import qualified Propellor.Property.File as File import qualified Propellor.Property.User as User diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -2,7 +2,7 @@ distroKernel ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import qualified Propellor.Property.Reboot as Reboot diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -1,6 +1,6 @@ module Propellor.Property.HostingProvider.Linode where -import Propellor +import Propellor.Base import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File import Utility.FileMode diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -1,6 +1,6 @@ module Propellor.Property.Hostname where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import Data.List diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs --- a/src/Propellor/Property/Journald.hs +++ b/src/Propellor/Property/Journald.hs @@ -1,5 +1,6 @@ module Propellor.Property.Journald where -import Propellor + +import Propellor.Base import qualified Propellor.Property.Systemd as Systemd import Utility.DataUnits diff --git a/src/Propellor/Property/Kerberos.hs b/src/Propellor/Property/Kerberos.hs --- a/src/Propellor/Property/Kerberos.hs +++ b/src/Propellor/Property/Kerberos.hs @@ -4,7 +4,7 @@ import Utility.Process -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import Propellor.Property.User diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs --- a/src/Propellor/Property/LightDM.hs +++ b/src/Propellor/Property/LightDM.hs @@ -4,7 +4,7 @@ module Propellor.Property.LightDM where -import Propellor +import Propellor.Base import qualified Propellor.Property.ConfFile as ConfFile -- | Configures LightDM to skip the login screen and autologin as a user. diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} module Propellor.Property.List ( + props, PropertyList(..), PropertyListType, ) where @@ -12,21 +13,32 @@ import Data.Monoid +-- | Starts accumulating a list of properties. +-- +-- > 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 propigate overall success/failure. + -- 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 "foo" $ props - -- > & someproperty - -- > ! oldproperty - -- > & otherproperty + -- use `props` propertyList :: Desc -> l -> Property (PropertyListType l) -- | Combines a list of properties, resulting in one property that diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs --- a/src/Propellor/Property/Logcheck.hs +++ b/src/Propellor/Property/Logcheck.hs @@ -9,7 +9,7 @@ installed, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,6 +1,6 @@ module Propellor.Property.Mount where -import Propellor +import Propellor.Base import Utility.Path type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect) diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -1,6 +1,6 @@ module Propellor.Property.Network where -import Propellor +import Propellor.Base import Propellor.Property.File type Interface = String diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -2,28 +2,21 @@ module Propellor.Property.Nginx where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty siteEnabled hn cf = enable disable where - enable = check test prop + enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn `describe` ("nginx site enabled " ++ hn) `requires` siteAvailable hn cf `requires` installed `onChange` reloaded - where - test = not <$> doesFileExist (siteVal hn) - prop = property "nginx site in place" $ makeChange $ - createSymbolicLink target dir - target = siteValRelativeCfg hn - dir = siteVal hn disable = trivial $ File.notPresent (siteVal hn) `describe` ("nginx site disable" ++ hn) `requires` installed @@ -41,8 +34,8 @@ siteVal :: HostName -> FilePath siteVal hn = "/etc/nginx/sites-enabled/" ++ hn -siteValRelativeCfg :: HostName -> FilePath -siteValRelativeCfg hn = "../sites-available/" ++ hn +siteValRelativeCfg :: HostName -> File.LinkTarget +siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn) installed :: Property NoInfo installed = Apt.installed ["nginx"] diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -7,7 +7,7 @@ oldOSRemoved, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Network as Network diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -1,6 +1,6 @@ module Propellor.Property.Obnam where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Gpg as Gpg diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -1,27 +1,47 @@ module Propellor.Property.OpenId where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Apache as Apache import Data.List -providerFor :: [User] -> String -> Property HasInfo -providerFor users baseurl = propertyList desc $ map toProp - [ Apt.serviceInstalledRunning "apache2" - , Apt.installed ["simpleid"] - `onChange` Service.restarted "apache2" - , File.fileProperty (desc ++ " configured") +-- | Openid provider, using the simpleid PHP CGI, with apache. +-- +-- Runs on usual port by default. When a nonstandard port is specified, +-- apache is limited to listening only on that port. Warning: Specifying +-- a port won't compose well with other apache properties on the same +-- host. +-- +-- 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 users hn mp = propertyList desc $ props + & Apt.serviceInstalledRunning "apache2" + & apacheconfigured + & Apt.installed ["simpleid"] + `onChange` Apache.restarted + & File.fileProperty (desc ++ " configured") (map setbaseurl) "/etc/simpleid/config.inc" - ] ++ map identfile users + & propertyList desc (map identfile users) where + baseurl = hn ++ case mp of + Nothing -> "" + Just (Port p) -> ':' : show p url = "http://"++baseurl++"/simpleid" desc = "openid provider " ++ url setbaseurl l | "SIMPLEID_BASE_URL" `isInfixOf` l = "define('SIMPLEID_BASE_URL', '"++url++"');" | otherwise = l + + apacheconfigured = case mp of + Nothing -> toProp $ + Apache.virtualHost hn (Port 80) "/var/www/html" + Just p -> propertyList desc $ props + & Apache.listenPorts [p] + & Apache.virtualHost hn p "/var/www/html" -- the identities directory controls access, so open up -- file mode diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -21,7 +21,7 @@ installed, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Partition as Partition import Utility.DataUnits diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -2,7 +2,7 @@ module Propellor.Property.Partition where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt -- | Filesystems etc that can be used for a partition. diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -2,7 +2,7 @@ module Propellor.Property.Postfix where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -2,11 +2,10 @@ module Propellor.Property.Prosody where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] @@ -15,18 +14,16 @@ confEnabled :: Conf -> ConfigFile -> RevertableProperty confEnabled conf cf = enable disable where - enable = check test prop + enable = dir `File.isSymlinkedTo` target `describe` ("prosody conf enabled " ++ conf) `requires` confAvailable conf cf `requires` installed `onChange` reloaded where - test = not <$> doesFileExist (confValPath conf) - prop = property "prosody conf in place" $ makeChange $ - createSymbolicLink target dir target = confValRelativePath conf dir = confValPath conf - confValRelativePath conf' = "../conf.avail" conf' <.> "cfg.lua" + confValRelativePath conf' = File.LinkTarget $ + "../conf.avail" conf' <.> "cfg.lua" disable = trivial $ File.notPresent (confValPath conf) `describe` ("prosody conf disabled " ++ conf) `requires` installed diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -1,6 +1,6 @@ module Propellor.Property.Reboot where -import Propellor +import Propellor.Base now :: Property NoInfo now = cmdProperty "reboot" [] diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -1,6 +1,6 @@ module Propellor.Property.Rsync where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt type Src = FilePath diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -9,7 +9,7 @@ , YearDay ) where -import Propellor +import Propellor.Base import Utility.Scheduled import Data.Time.Clock diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -1,6 +1,6 @@ module Propellor.Property.Service where -import Propellor +import Propellor.Base type ServiceName = String diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs --- a/src/Propellor/Property/SiteSpecific/Branchable.hs +++ b/src/Propellor/Property/SiteSpecific/Branchable.hs @@ -1,6 +1,6 @@ module Propellor.Property.SiteSpecific.Branchable where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import qualified Propellor.Property.User as User @@ -50,7 +50,9 @@ , "lru-size = 128" ] & Gpg.keyImported (Gpg.GpgKeyId obnamkey) (User "root") - & Ssh.keyImported SshRsa (User "root") (Context "branchable.com") + & Ssh.userKeys (User "root") (Context "branchable.com") + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC2PqTSupwncqeffNwZQXacdEWp7L+TxllIxH7WjfRMb3U74mQxWI0lwqLVW6Fox430DvhSqF1y5rJBvTHh4i49Tc9lZ7mwAxA6jNOP6bmdfteaKKYmUw5qwtJW0vISBFu28qBO11Nq3uJ1D3Oj6N+b3mM/0D3Y3NoGgF8+2dLdi81u9+l6AQ5Jsnozi2Ni/Osx2oVGZa+IQDO6gX8VEP4OrcJFNJe8qdnvItcGwoivhjbIfzaqNNvswKgGzhYLOAS5KT8HsjvIpYHWkyQ5QUX7W/lqGSbjP+6B8C3tkvm8VLXbmaD+aSkyCaYbuoXC2BoJdS7Jh8phKMwPJmdYVepn") + ] & Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") & Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -2,7 +2,7 @@ module Propellor.Property.SiteSpecific.GitAnnexBuilder where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.User as User import qualified Propellor.Property.Cron as Cron diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -1,6 +1,6 @@ module Propellor.Property.SiteSpecific.GitHome where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import Propellor.Property.User diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs --- a/src/Propellor/Property/SiteSpecific/IABak.hs +++ b/src/Propellor/Property/SiteSpecific/IABak.hs @@ -1,6 +1,6 @@ module Propellor.Property.SiteSpecific.IABak where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Git as Git import qualified Propellor.Property.Cron as Cron @@ -26,7 +26,7 @@ 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") - & Ssh.keyImported SshRsa (User "root") (Context "IA.bak.users.git") + & Ssh.userKeys (User "root") (Context "IA.bak.users.git") sshKeys & Ssh.knownHost knownhosts "gitlab.com" (User "root") & Git.cloned (User "root") userrepo "/usr/local/IA.BAK/pubkeys" (Just "master") & Apt.serviceInstalledRunning "apache2" @@ -45,7 +45,7 @@ registrationServer :: [Host] -> Property HasInfo registrationServer knownhosts = propertyList "iabak registration server" $ props & User.accountFor (User "registrar") - & Ssh.keyImported SshRsa (User "registrar") (Context "IA.bak.users.git") + & Ssh.userKeys (User "registrar") (Context "IA.bak.users.git") sshKeys & Ssh.knownHost knownhosts "gitlab.com" (User "registrar") & Git.cloned (User "registrar") repo "/home/registrar/IA.BAK" (Just "server") & Git.cloned (User "registrar") userrepo "/home/registrar/users" (Just "master") @@ -59,6 +59,11 @@ `requires` File.dirExists "/etc/kgb-bot/" where link = "/usr/lib/cgi-bin/register.cgi" + +sshKeys :: [(SshKeyType, Ssh.PubKeyText)] +sshKeys = + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCoiE+CPiIQyfWnl/E9iKG3eo4QzlH30vi7xAgKolGaTu6qKy4XPtl+8MNm2Dqn9QEYRVyyOT/XH0yP5dRc6uyReT8dBy03MmLkVbj8Q+nKCz5YOMTxrY3sX6RRXU1zVGjeVd0DtC+rKRT7reoCxef42LAJTm8nCyZu/enAuso5qHqBbqulFz2YXEKfU1SEEXLawtvgGck1KmCyg+pqazeI1eHWXrojQf5isTBKfPQLWVppBkWAf5cA4wP5U1vN9dVirIdw66ds1M8vnGlkTBjxP/HLGBWGYhZHE7QXjXRsk2RIXlHN9q6GdNu8+F3HXS22mst47E4UAeRoiXSMMtF5") + ] graphiteServer :: Property HasInfo graphiteServer = propertyList "iabak graphite server" $ props diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -3,7 +3,7 @@ module Propellor.Property.SiteSpecific.JoeySites where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import qualified Propellor.Property.Gpg as Gpg @@ -137,7 +137,10 @@ , "--client-name=spool" , "--ssh-key=" ++ keyfile ] Obnam.OnlyClient - `requires` Ssh.keyImported' (Just keyfile) SshRsa (User "root") (Context "olduse.net") + `requires` Ssh.userKeyAt (Just keyfile) + (User "root") + (Context "olduse.net") + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") keyfile = "/root/.ssh/olduse.net.key" @@ -183,13 +186,18 @@ & Apt.serviceInstalledRunning "mumble-server" & Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") [ "--repository=sftp://2318@usw-s002.rsync.net/~/" ++ hn ++ ".obnam" + , "--ssh-key=" ++ sshkey , "--client-name=mumble" ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa (User "root") (Context hn) + `requires` Ssh.userKeyAt (Just sshkey) + (User "root") + (Context hn) + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDSXXSM3mM8SNu+qel9R/LkDIkjpV3bfpUtRtYv2PTNqicHP+DdoThrr0ColFCtLH+k2vQJvR2n8uMzHn53Dq2IO3TtD27+7rJSsJwAZ8oftNzuTir8IjAwX5g6JYJs+L0Ny4RB0ausd+An0k/CPMRl79zKxpZd2MBMDNXt8hyqu0vS0v1ohq5VBEVhBBvRvmNQvWOCj7PdrKQXpUBHruZOeVVEdUUXZkVc1H0t7LVfJnE+nGKyWbw2jM+7r3Rn5Semc4R1DxsfaF8lKkZyE88/5uZQ/ddomv8ptz6YZ5b+Bg6wfooWPC3RWAALjxnHaC2yN1VONAvHmT0uNn1o6v0b") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") & trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]) where hn = "mumble.debian.net" + sshkey = "/root/.ssh/mumble.debian.net.key" -- git.kitenet.net and git.joeyh.name gitServer :: [Host] -> Property HasInfo @@ -199,7 +207,10 @@ , "--ssh-key=" ++ sshkey , "--client-name=wren" -- historical ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") - `requires` Ssh.keyImported' (Just sshkey) SshRsa (User "root") (Context "git.kitenet.net") + `requires` Ssh.userKeyAt (Just sshkey) + (User "root") + (Context "git.kitenet.net") + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") `requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") `requires` User.accountFor (User "family") diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Spin.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +module Propellor.Property.Spin ( + Spinnable(..), + controllerFor, + controllerKeys, + controlledBy, +) where + +import Propellor.Base +import Propellor.Spin (spin, SpinMode(..)) +import Propellor.Types.Info +import qualified Propellor.Property.Ssh as Ssh + +import qualified Data.Set as S + +-- | A class of things that can be spinned. +class Spinnable t where + toSpin :: t -> Property HasInfo + +instance Spinnable Host where + toSpin h = infoProperty desc go (mkControllingInfo h <> privinfo) [] + `requires` Ssh.knownHost [h] (hostName h) (User "root") + where + desc = cdesc (hostName h) + go = do + thishost <- ask + if isControllerLoop thishost h + then errorMessage $ unwords + [ "controller loop detected involving" + , hostName thishost + , "and" + , hostName h + ] + else do + liftIO $ spin ControllingSpin (hostName h) h + -- Don't know if the spin made a + -- change to the remote host or not, + -- but in any case, the + -- local host was not changed. + noChange + -- Make the controlling host have all the remote host's + -- PrivData, so it can send it on to the remote host + -- when spinning it. + privinfo = addInfo mempty $ + forceHostContext (hostName h) $ + getInfo (hostInfo h) + +-- | Each Host in the list is spinned in turn. Does not stop on spin +-- failure; does propagate overall success/failure. +instance Spinnable [Host] where + toSpin l = propertyList (cdesc $ unwords $ map hostName l) (map toSpin l) + +-- | The Host that has this Property is in control of running propellor on +-- some other Hosts. +-- +-- Making a host a controller eliminates the need to manually run +-- propellor --spin to update the controlled hosts. Each time +-- propellor is run on the controller host, it will in turn run +-- propellor on the controlled Hosts. +-- +-- The controller needs to be able to ssh to the hosts it controls, +-- and run propellor, as root. The controller is automatically configured +-- with `Propellor.Property.Ssh.knownHost` to know the host keys of the +-- hosts that it will ssh to. It's up to you to use `controllerKeys` +-- and `controlledBy` to set up the ssh keys that will let the controller +-- log into the hosts it controls. +-- +-- For example, if you have some webservers and a dnsserver, +-- and want a master that runs propellor on all of them: +-- +-- > import Propellor +-- > import qualified Propellor.Property.Spin as Spin +-- > import qualified Propellor.Property.Ssh as Ssh +-- > import qualified Propellor.Property.Cron as Cron +-- > +-- > main = defaultMain hosts +-- > +-- > hosts = +-- > [ master +-- > , dnsserver +-- > ] ++ webservers +-- > +-- > dnsserver = host "dns.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")] +-- > & Spin.controlledBy master +-- > & ... +-- > +-- > webservers = +-- > [ host "www1.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")] +-- > & Spin.controlledBy master +-- > & ... +-- > , ... +-- > ] +-- > +-- > master = host "master.example.com" +-- > & Spin.controllerKeys [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")] +-- > -- Only update dnsserver once all webservers are successfully updated. +-- > & Spin.controllerFor dnsserver +-- > `requires` Spin.controllerFor webservers +-- > & Cron.runPropellor +-- +-- Multiple controllers can control the same hosts. However, when +-- propellor is already running on a host, a controller will fail +-- to run it. So, if two controllers both try to control the same +-- host at the same time, one will fail. +-- +-- Chains of controllers are supported; host A can control host B which +-- controls host C. Loops of controllers are automatically prevented. +-- +-- Note that a controller can see all PrivInfo of the hosts it controls. +controllerFor :: Spinnable h => h -> Property HasInfo +controllerFor h = toSpin h + `requires` Ssh.installed + +-- | Uses `Propellor.Property.Ssh.keysImported` to set up the ssh keys +-- for the root user on a controller. +-- +-- (The corresponding private keys come from the privdata.) +controllerKeys :: [(SshKeyType, Ssh.PubKeyText)] -> Property HasInfo +controllerKeys ks = Ssh.userKeys (User "root") hostContext ks + `requires` Ssh.installed + +-- | Use this property to let the specified controller Host ssh in +-- and run propellor. +controlledBy :: Host -> Property NoInfo +controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h) + `requires` Ssh.installed + +cdesc :: String -> Desc +cdesc n = "controller for " ++ n + +-- To detect loops of controlled hosts, each Host's info contains a list +-- of the hosts it's controlling. +newtype Controlling = Controlled [Host] + deriving (Typeable, Monoid, Show) + +isControlledBy :: Host -> Controlling -> Bool +h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs) + +instance IsInfo Controlling where + propagateInfo _ = True + +mkControllingInfo :: Host -> Info +mkControllingInfo controlled = addInfo mempty (Controlled [controlled]) + +getControlledBy :: Host -> Controlling +getControlledBy = getInfo . hostInfo + +isControllerLoop :: Host -> Host -> Bool +isControllerLoop controller controlled = go S.empty controlled + where + go checked h + | controller `isControlledBy` c = True + -- avoid checking loops that have been checked before + | hostName h `S.member` checked = False + | otherwise = any (go (S.insert (hostName h) checked)) l + where + c@(Controlled l) = getControlledBy h diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} module Propellor.Property.Ssh ( + installed, + restarted, PubKeyText, + -- * Daemon configuration sshdConfig, ConfigKeyword, setSshdConfigBool, @@ -10,34 +13,43 @@ permitRootLogin, passwordAuthentication, noPasswords, - hasAuthorizedKeys, - authorizedKey, - restarted, + listenPort, + -- * Host keys randomHostKeys, hostKeys, hostKey, - pubKey, - getPubKey, - keyImported, - keyImported', + hostPubKey, + getHostPubKey, + -- * User keys and configuration + userKeys, + userKeyAt, knownHost, + authorizedKeysFrom, authorizedKeys, - listenPort + authorizedKey, + hasAuthorizedKeys, + getUserPubKeys, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Apt as Apt import Propellor.Property.User import Propellor.Types.Info import Utility.FileMode import System.PosixCompat import qualified Data.Map as M +import qualified Data.Set as S import Data.List -type PubKeyText = String +installed :: Property NoInfo +installed = Apt.installed ["ssh"] +restarted :: Property NoInfo +restarted = Service.restarted "ssh" + sshBool :: Bool -> String sshBool True = "yes" sshBool False = "no" @@ -95,14 +107,26 @@ d <- dotDir user return $ d f +-- | Makes the ssh server listen on a given port, in addition to any other +-- ports it is configured to listen on. +-- +-- Revert to prevent it listening on a particular port. +listenPort :: Int -> RevertableProperty +listenPort port = enable disable + where + portline = "Port " ++ show port + enable = sshdConfig `File.containsLine` portline + `describe` ("ssh listening on " ++ portline) + `onChange` restarted + disable = sshdConfig `File.lacksLine` portline + `describe` ("ssh not listening on " ++ portline) + `onChange` restarted + hasAuthorizedKeys :: User -> IO Bool hasAuthorizedKeys = go <=< dotFile "authorized_keys" where go f = not . null <$> catchDefaultIO "" (readFile f) -restarted :: Property NoInfo -restarted = Service.restarted "ssh" - -- | 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. @@ -118,6 +142,9 @@ ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] +-- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" +type PubKeyText = String + -- | Installs the specified list of ssh host keys. -- -- The corresponding private keys come from the privdata. @@ -146,29 +173,25 @@ -- the private key comes from the privdata; hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo hostKey context keytype pub = combineProperties desc - [ pubKey keytype pub - , toProp $ property desc $ install writeFile True (lines pub) + [ hostPubKey keytype pub + , toProp $ property desc $ install File.hasContent True (lines pub) , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> property desc $ getkey $ - install writeFileProtected False . privDataLines + install File.hasContentProtected False . privDataLines ] `onChange` restarted where desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" install writer ispub keylines = do let f = keyFile keytype ispub - have <- liftIO $ catchDefaultIO "" $ readFileStrict f - let want = keyFileContent keylines - if have == want - then noChange - else makeChange $ writer f want + ensureProperty $ writer f (keyFileContent keylines) keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") -- Make sure that there is a newline at the end; -- ssh requires this for some types of private keys. -keyFileContent :: [String] -> String -keyFileContent keylines = unlines (keylines ++ [""]) +keyFileContent :: [String] -> [File.Line] +keyFileContent keylines = keylines ++ [""] keyFile :: SshKeyType -> Bool -> FilePath keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext @@ -178,80 +201,106 @@ -- | 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. -pubKey :: SshKeyType -> PubKeyText -> Property HasInfo -pubKey t = pureInfoProperty "ssh pubkey known" . SshPubKeyInfo . M.singleton t +hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo +hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t -getPubKey :: Propellor (M.Map SshKeyType PubKeyText) -getPubKey = fromSshPubKeyInfo <$> askInfo +getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) +getHostPubKey = fromHostKeyInfo <$> askInfo -newtype SshPubKeyInfo = SshPubKeyInfo - { fromSshPubKeyInfo :: M.Map SshKeyType PubKeyText } - deriving (Eq, Ord, Typeable) +newtype HostKeyInfo = HostKeyInfo + { fromHostKeyInfo :: M.Map SshKeyType PubKeyText } + deriving (Eq, Ord, Typeable, Show) -instance IsInfo SshPubKeyInfo where - propigateInfo _ = False +instance IsInfo HostKeyInfo where + propagateInfo _ = False -instance Monoid SshPubKeyInfo where - mempty = SshPubKeyInfo M.empty - mappend (SshPubKeyInfo old) (SshPubKeyInfo new) = +instance Monoid HostKeyInfo where + mempty = HostKeyInfo M.empty + mappend (HostKeyInfo old) (HostKeyInfo new) = -- new first because union prefers values from the first -- parameter when there is a duplicate key - SshPubKeyInfo (new `M.union` old) + HostKeyInfo (new `M.union` old) --- | Sets up a user with a ssh private key and public key pair from the --- PrivData. --- --- If the user already has a private/public key, it is left unchanged. -keyImported :: IsContext c => SshKeyType -> User -> c -> Property HasInfo -keyImported = keyImported' Nothing +userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo +userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ + UserKeyInfo (M.singleton u (S.fromList l)) --- | A file can be speficied to write the key to somewhere other than --- usual. Allows a user to have multiple keys for different roles. -keyImported' :: IsContext c => Maybe FilePath -> SshKeyType -> User -> c -> Property HasInfo -keyImported' dest keytype user@(User u) context = combineProperties desc - [ installkey (SshPubKey keytype u) (install writeFile ".pub") - , installkey (SshPrivKey keytype u) (install writeFileProtected "") - ] +getUserPubKeys :: User -> Propellor [(SshKeyType, PubKeyText)] +getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo + +newtype UserKeyInfo = UserKeyInfo + { fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) } + deriving (Eq, Ord, Typeable, Show) + +instance IsInfo UserKeyInfo where + propagateInfo _ = False + +instance Monoid UserKeyInfo where + mempty = UserKeyInfo M.empty + mappend (UserKeyInfo old) (UserKeyInfo new) = + UserKeyInfo (M.unionWith S.union old new) + +-- | Sets up a user with the specified public keys, and the corresponding +-- private keys from the privdata. +-- +-- 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 $ + userPubKeys user ks : map (userKeyAt Nothing user context) ks where + desc = unwords + [ name + , "has ssh key" + , "(" ++ unwords (map (fromKeyType . fst) ks) ++ ")" + ] + +-- | Sets up a user with the specified pubic key, and a private +-- key from the privdata. +-- +-- 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 dest user@(User u) context (keytype, pubkeytext) = + combineProperties desc $ props + & pubkey + & privkey + where desc = unwords $ catMaybes [ Just u , Just "has ssh key" , dest , Just $ "(" ++ fromKeyType keytype ++ ")" ] - installkey p a = withPrivData p context $ \getkey -> - property desc $ getkey a + 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 f <- liftIO $ keyfile ext - ifM (liftIO $ doesFileExist f) - ( noChange - , ensureProperties - [ property desc $ makeChange $ do - createDirectoryIfMissing True (takeDirectory f) - writer f (keyFileContent (privDataLines key)) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] - ) + ensureProperty $ combineProperties desc + [ 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 return $ home ".ssh" "id_" ++ fromKeyType keytype ++ ext Just f -> return $ f ++ ext - - fromKeyType :: SshKeyType -> String fromKeyType SshRsa = "rsa" fromKeyType SshDsa = "dsa" fromKeyType SshEcdsa = "ecdsa" fromKeyType SshEd25519 = "ed25519" --- | Puts some host's ssh public key(s), as set using 'pubKey' or 'hostKey' --- into the known_hosts file for a user. +-- | 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 =<< fromHost hosts hn getPubKey + go =<< fromHost hosts hn getHostPubKey where desc = u ++ " knows ssh key for " ++ hn go (Just m) | not (M.null m) = do @@ -264,23 +313,41 @@ , File.ownerGroup (takeDirectory f) user (userGroup user) ] go _ = do - warningMessage $ "no configred pubKey for " ++ hn + warningMessage $ "no configured ssh host keys for " ++ hn return FailedChange +-- | Ensures that a local user's authorized keys contains a line allowing +-- logins from a remote user on the specified Host. +-- +-- 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 +localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = + property desc $ go =<< fromHost' remotehost (getUserPubKeys remoteuser) + where + remote = rn ++ "@" ++ hostName remotehost + desc = ln ++ " authorized_keys from " ++ remote + go [] = do + warningMessage $ "no configured ssh user keys for " ++ remote + return FailedChange + go ks = ensureProperty $ combineProperties desc $ + map (authorizedKey localuser . snd) ks + -- | 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 user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get -> - property (u ++ " has authorized_keys") $ get $ \v -> do + property desc $ get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user - liftIO $ do - createDirectoryIfMissing True (takeDirectory f) - writeFileProtected f (keyFileContent (privDataLines v)) - ensureProperties - [ File.ownerGroup f user (userGroup user) + ensureProperty $ combineProperties desc + [ 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. @@ -295,19 +362,4 @@ , File.ownerGroup (takeDirectory f) user (userGroup user) ] where - desc = u ++ " has autorized_keys" - --- | Makes the ssh server listen on a given port, in addition to any other --- ports it is configured to listen on. --- --- Revert to prevent it listening on a particular port. -listenPort :: Int -> RevertableProperty -listenPort port = enable disable - where - portline = "Port " ++ show port - enable = sshdConfig `File.containsLine` portline - `describe` ("ssh listening on " ++ portline) - `onChange` restarted - disable = sshdConfig `File.lacksLine` portline - `describe` ("ssh not listening on " ++ portline) - `onChange` restarted + desc = u ++ " has authorized_keys" diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs --- a/src/Propellor/Property/Sudo.hs +++ b/src/Propellor/Property/Sudo.hs @@ -2,7 +2,7 @@ import Data.List -import Propellor +import Propellor.Base import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import Propellor.Property.User diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -40,7 +40,7 @@ bindRo, ) where -import Propellor +import Propellor.Base import Propellor.Types.Chroot import Propellor.Types.Container import Propellor.Types.Info @@ -62,8 +62,8 @@ deriving (Show) instance PropAccum Container where - (Container n c h) & p = Container n c (h & p) - (Container n c h) &^ p = Container n c (h &^ p) + (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 -- | Starts a systemd service. @@ -187,7 +187,8 @@ & resolvConfed & linkJournal where - c@(Chroot.Chroot _ system _ _) = mkchroot (containerDir name) + c = mkchroot (containerDir name) + system = Chroot.chrootSystem c h = Host name [] mempty -- | Runs a container using systemd-nspawn. @@ -205,7 +206,7 @@ -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty -nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) = +nspawned c@(Container name (Chroot.Chroot loc system builder _) h) = p `describe` ("nspawned " ++ name) where p = enterScript c @@ -216,7 +217,7 @@ -- Chroot provisioning is run in systemd-only mode, -- which sets up the chroot and ensures systemd and dbus are -- installed, but does not handle the other provisions. - chrootprovisioned = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) chroot True + chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True -- Use nsenter to enter container and and run propellor to -- finish provisioning. @@ -225,7 +226,7 @@ doNothing - chroot = Chroot.Chroot loc system builderconf h + chroot = Chroot.Chroot loc system builder h -- | Sets up the service file for the container, and then starts -- it running. @@ -254,8 +255,9 @@ <$> servicefilecontent <*> catchDefaultIO "" (readFile servicefile) - writeservicefile = property servicefile $ makeChange $ - viaTmp writeFile servicefile =<< servicefilecontent + writeservicefile = property servicefile $ makeChange $ do + c <- servicefilecontent + File.viaStableTmp (\t -> writeFile t c) servicefile setupservicefile = check (not <$> goodservicefile) $ -- if it's running, it has the wrong configuration, @@ -376,8 +378,8 @@ -- -- > foo :: Host -- > foo = host "foo.example.com" --- > & Systemd.running Systemd.networkd -- > & Systemd.nspawned webserver +-- > `requires` Systemd.running Systemd.networkd -- > -- > webserver :: Systemd.container -- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty) diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs --- a/src/Propellor/Property/Systemd/Core.hs +++ b/src/Propellor/Property/Systemd/Core.hs @@ -1,6 +1,6 @@ module Propellor.Property.Systemd.Core where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt -- dbus is only a Recommends of systemd, but is needed for communication diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -1,6 +1,6 @@ module Propellor.Property.Tor where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs --- a/src/Propellor/Property/Unbound.hs +++ b/src/Propellor/Property/Unbound.hs @@ -17,7 +17,7 @@ , cachingDnsServer ) where -import Propellor +import Propellor.Base import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -2,7 +2,7 @@ import System.Posix -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File data Eep = YesReallyDeleteHome diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Uwsgi.hs @@ -0,0 +1,49 @@ +-- | Maintainer: Félix Sipma + +module Propellor.Property.Uwsgi where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +type ConfigFile = [String] + +type AppName = String + +appEnabled :: AppName -> ConfigFile -> RevertableProperty +appEnabled an cf = enable disable + where + enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an + `describe` ("uwsgi app enabled " ++ an) + `requires` appAvailable an cf + `requires` installed + `onChange` reloaded + disable = trivial $ File.notPresent (appVal an) + `describe` ("uwsgi app disable" ++ an) + `requires` installed + `onChange` reloaded + +appAvailable :: AppName -> ConfigFile -> Property NoInfo +appAvailable an cf = ("uwsgi app available " ++ an) ==> + appCfg an `File.hasContent` (comment : cf) + where + comment = "# deployed with propellor, do not modify" + +appCfg :: AppName -> FilePath +appCfg an = "/etc/uwsgi/apps-available/" ++ an + +appVal :: AppName -> FilePath +appVal an = "/etc/uwsgi/apps-enabled/" ++ an + +appValRelativeCfg :: AppName -> File.LinkTarget +appValRelativeCfg an = File.LinkTarget $ "../apps-available/" ++ an + +installed :: Property NoInfo +installed = Apt.installed ["uwsgi"] + +restarted :: Property NoInfo +restarted = Service.restarted "uwsgi" + +reloaded :: Property NoInfo +reloaded = Service.reloaded "uwsgi" diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -11,7 +11,7 @@ import Data.List -import Propellor +import Propellor.Base data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled deriving (Read, Show, Eq) diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -6,7 +6,7 @@ module Propellor.Shim (setup, cleanEnv, file) where -import Propellor +import Propellor.Base import Utility.LinuxMkLibs import Utility.FileMode import Utility.FileSystemEncoding diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -1,5 +1,6 @@ module Propellor.Spin ( commitSpin, + SpinMode(..), spin, update, gitPushHelper, @@ -16,7 +17,7 @@ import qualified Data.Set as S import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr) -import Propellor +import Propellor.Base import Propellor.Protocol import Propellor.PrivData.Paths import Propellor.Git @@ -40,20 +41,26 @@ void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] -spin :: HostName -> Maybe HostName -> Host -> IO () -spin target relay hst = do +data SpinMode + = RegularSpin + | RelaySpin HostName + | ControllingSpin + deriving (Eq) + +spin :: SpinMode -> HostName -> Host -> IO () +spin spinmode target hst = do cacheparams <- if viarelay then pure ["-A"] else toCommand <$> sshCachingParams hn when viarelay $ void $ boolSystem "ssh-add" [] - sshtarget <- ("root@" ++) <$> case relay of - Just r -> pure r - Nothing -> getSshTarget target hst + sshtarget <- ("root@" ++) <$> case spinmode of + RelaySpin r -> pure r + _ -> getSshTarget target hst -- Install, or update the remote propellor. - updateServer target relay hst + updateServer target spinmode hst (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) @@ -61,10 +68,14 @@ unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ error "remote propellor failed" where - hn = fromMaybe target relay + hn = case spinmode of + RelaySpin h -> h + _ -> target - relaying = relay == Just target - viarelay = isJust relay && not relaying + relaying = spinmode == RelaySpin target + viarelay = not relaying && case spinmode of + RelaySpin _ -> True + _ -> False probecmd = intercalate " ; " [ "if [ ! -d " ++ localdir ++ "/.git ]" @@ -169,20 +180,22 @@ updateServer :: HostName - -> Maybe HostName + -> SpinMode -> Host -> CreateProcess -> CreateProcess -> IO () -updateServer target relay hst connect haveprecompiled = +updateServer target spinmode hst connect haveprecompiled = withIOHandles createProcessSuccess connect go where - hn = fromMaybe target relay - relaying = relay == Just target + hn = case spinmode of + RelaySpin h -> h + _ -> target + relaying = spinmode == RelaySpin target go (toh, fromh) = do let loop = go (toh, fromh) - let restart = updateServer hn relay hst connect haveprecompiled + let restart = updateServer hn spinmode hst connect haveprecompiled let done = return () v <- maybe Nothing readish <$> getMarked fromh statusMarker case v of @@ -190,7 +203,7 @@ sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn hst toh relaying + sendPrivData hn toh =<< getprivdata loop (Just NeedGitClone) -> do hClose toh @@ -201,31 +214,36 @@ hClose toh hClose fromh sendPrecompiled hn - updateServer hn relay hst haveprecompiled (error "loop") + updateServer hn spinmode hst haveprecompiled (error "loop") (Just NeedGitPush) -> do sendGitUpdate hn fromh toh hClose fromh hClose toh done Nothing -> done - -sendRepoUrl :: Handle -> IO () -sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) - -sendPrivData :: HostName -> Host -> Handle -> Bool -> IO () -sendPrivData hn hst toh relaying = do - privdata <- getdata - void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do - sendMarked toh privDataMarker privdata - return True - where - getdata + getprivdata | relaying = do let f = privDataRelay hn d <- readFileStrictAnyEncoding f nukeFile f return d - | otherwise = show . filterPrivData hst <$> decryptPrivData + | otherwise = case spinmode of + -- When one host is controlling another, + -- the controlling host's privdata includes the + -- privdata of the controlled host. + ControllingSpin -> show . filterPrivData hst . readPrivData + <$> readFileStrictAnyEncoding privDataLocal + _ -> show . filterPrivData hst <$> decryptPrivData + +sendRepoUrl :: Handle -> IO () +sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) + +sendPrivData :: HostName -> Handle -> String -> IO () +sendPrivData hn toh privdata = void $ actionMessage msg $ do + sendMarked toh privDataMarker privdata + return True + where + msg = "Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn sendGitUpdate :: HostName -> Handle -> Handle -> IO () sendGitUpdate hn fromh toh = diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -1,6 +1,6 @@ module Propellor.Ssh where -import Propellor +import Propellor.Base import Utility.UserInfo import System.PosixCompat diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -10,12 +10,12 @@ module Propellor.Types ( Host(..) - , Desc , Property , Info , HasInfo , NoInfo , CInfo + , Desc , infoProperty , simpleProperty , adjustPropertySatisfy @@ -27,7 +27,6 @@ , IsProp(..) , Combines(..) , CombinedType - , before , combineWith , Propellor(..) , EndAction(..) @@ -93,6 +92,12 @@ -- | The core data type of Propellor, this represents a property -- that the system should have, and an action to ensure it has 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 many instances and 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 @@ -164,17 +169,17 @@ propertyChildren (IProperty _ _ _ cs) = cs propertyChildren (SProperty _ _ cs) = cs --- | A property that can be reverted. +-- | A property that can be reverted. The first Property is run +-- normally and the second is run when it's reverted. data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo) --- | Makes a revertable property; the first Property is run --- normally and the second is run when it's reverted. +-- | Shorthand to construct a revertable property. () :: Property i1 -> Property i2 -> RevertableProperty p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2) +-- | Class of types that can be used as properties of a host. class IsProp p where - -- | Sets description. - describe :: p -> Desc -> p + setDesc :: p -> Desc -> p toProp :: p -> Property HasInfo getDesc :: p -> Desc -- | Gets the info of the property, combined with all info @@ -182,28 +187,28 @@ getInfoRecursive :: p -> Info instance IsProp (Property HasInfo) where - describe (IProperty _ a i cs) d = IProperty d a i cs + 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 - describe (SProperty _ a cs) d = SProperty d a cs + setDesc (SProperty _ a cs) d = SProperty d a cs toProp = toIProperty getDesc = propertyDesc getInfoRecursive _ = mempty instance IsProp RevertableProperty where -- | Sets the description of both sides. - describe (RevertableProperty p1 p2) d = - RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) + setDesc (RevertableProperty p1 p2) d = + RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) getDesc (RevertableProperty p1 _) = getDesc p1 toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 --- | Type level calculation of the type that results from combining two types --- with `requires`. +-- | 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 (Property NoInfo) = RevertableProperty @@ -211,15 +216,11 @@ type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty class Combines x y where - -- | Indicates that the first property depends on the second, - -- so before the first is ensured, the second will be ensured. - requires :: x -> y -> CombinedType x y - --- | Combines together two properties, resulting in one property --- that ensures the first, and if the first succeeds, ensures the second. --- The property uses the description of the first property. -before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x -before x y = (y `requires` x) `describe` getDesc x + -- | Combines two properties. The second property is ensured + -- first, and only once it is successfully ensures will the first + -- be ensured. The combined property will have the description of + -- the first property. + (<<>>) :: x -> y -> CombinedType x y -- | Combines together two properties, yielding a property that -- has the description and info of the first, and that has the second @@ -231,36 +232,36 @@ -> Property x -> Property y -> CombinedType (Property x) (Property y) -combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ -> +combineWith f x y = adjustPropertySatisfy (x <<>> y) $ \_ -> f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y) instance Combines (Property HasInfo) (Property HasInfo) where - requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + (IProperty d1 a1 i1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) = IProperty d1 (a2 <> a1) i1 (y : cs1) instance Combines (Property HasInfo) (Property NoInfo) where - requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = + (IProperty d1 a1 i1 cs1) <<>> y@(SProperty _d2 a2 _cs2) = IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1) instance Combines (Property NoInfo) (Property HasInfo) where - requires (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + (SProperty d1 a1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) = IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1) instance Combines (Property NoInfo) (Property NoInfo) where - requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = + (SProperty d1 a1 cs1) <<>> y@(SProperty _d2 a2 _cs2) = SProperty d1 (a2 <> a1) (y : cs1) instance Combines RevertableProperty (Property HasInfo) where - requires (RevertableProperty p1 p2) y = - RevertableProperty (p1 `requires` y) p2 + (RevertableProperty p1 p2) <<>> y = + RevertableProperty (p1 <<>> y) p2 instance Combines RevertableProperty (Property NoInfo) where - requires (RevertableProperty p1 p2) y = - RevertableProperty (p1 `requires` toIProperty y) p2 + (RevertableProperty p1 p2) <<>> y = + RevertableProperty (p1 <<>> toIProperty y) p2 instance Combines RevertableProperty RevertableProperty where - requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) = + (RevertableProperty x1 x2) <<>> (RevertableProperty y1 y2) = RevertableProperty - (x1 `requires` y1) + (x1 <<>> y1) -- when reverting, run actions in reverse order - (y2 `requires` x2) + (y2 <<>> x2) diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs --- a/src/Propellor/Types/Chroot.hs +++ b/src/Propellor/Types/Chroot.hs @@ -16,7 +16,7 @@ deriving (Show, Typeable) instance IsInfo ChrootInfo where - propigateInfo _ = False + propagateInfo _ = False instance Monoid ChrootInfo where mempty = ChrootInfo mempty mempty diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -5,12 +5,14 @@ import System.Posix.Types +-- | All the command line actions that propellor can perform. data CmdLine = Run HostName | Spin [HostName] (Maybe HostName) | SimpleRun HostName | Set PrivDataField Context | Unset PrivDataField Context + | UnsetUnused | Dump PrivDataField Context | Edit PrivDataField Context | ListFields @@ -27,4 +29,3 @@ | GitPush Fd Fd | Check deriving (Read, Show, Eq) - diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -26,7 +26,7 @@ deriving (Show, Eq, Ord, Monoid, Typeable) instance IsInfo AliasesInfo where - propigateInfo _ = False + propagateInfo _ = False toAliasesInfo :: [HostName] -> AliasesInfo toAliasesInfo l = AliasesInfo (S.fromList l) @@ -40,10 +40,10 @@ toDnsInfo :: S.Set Record -> DnsInfo toDnsInfo = DnsInfo --- | DNS Info is propigated, so that eg, aliases of a container +-- | DNS Info is propagated, so that eg, aliases of a container -- are reflected in the dns for the host where it runs. instance IsInfo DnsInfo where - propigateInfo _ = True + propagateInfo _ = True -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf @@ -155,7 +155,7 @@ deriving (Eq, Ord, Show, Typeable) instance IsInfo NamedConfMap where - propigateInfo _ = False + propagateInfo _ = False -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs --- a/src/Propellor/Types/Docker.hs +++ b/src/Propellor/Types/Docker.hs @@ -16,7 +16,7 @@ deriving (Show, Typeable) instance IsInfo DockerInfo where - propigateInfo _ = False + propagateInfo _ = False instance Monoid DockerInfo where mempty = DockerInfo mempty mempty diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Propellor.Types.Info ( Info, @@ -6,7 +6,7 @@ addInfo, getInfo, mapInfo, - propigatableInfo, + propagatableInfo, InfoVal(..), fromInfoVal, Typeable, @@ -17,59 +17,65 @@ import Data.Maybe -- | Information about a Host, which can be provided by its properties. -data Info = Info [(Dynamic, Bool)] +newtype Info = Info [InfoEntry] + deriving (Monoid, Show) -instance Show Info where - show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l) +data InfoEntry where + InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry -instance Monoid Info where - mempty = Info [] - mappend (Info a) (Info b) = Info (a <> b) +instance Show InfoEntry where + show (InfoEntry v) = show v +-- Extracts the value from an InfoEntry but only when +-- it's of the requested type. +extractInfoEntry :: Typeable v => InfoEntry -> Maybe v +extractInfoEntry (InfoEntry v) = cast v + -- | Values stored in Info must be members of this class. -- -- This is used to avoid accidentially using other data types -- as info, especially type aliases which coud easily lead to bugs. -- We want a little bit of dynamic types here, but not too far.. -class (Typeable v, Monoid v) => IsInfo v where - -- | Should info of this type be propigated out of a +class (Typeable v, Monoid v, Show v) => IsInfo v where + -- | Should info of this type be propagated out of a -- container to its Host? - propigateInfo :: v -> Bool + propagateInfo :: v -> Bool -- | Any value in the `IsInfo` type class can be added to an Info. addInfo :: IsInfo v => Info -> v -> Info -addInfo (Info l) v = Info ((toDyn v, propigateInfo v):l) +addInfo (Info l) v = Info (InfoEntry v:l) +-- The list is reversed here because addInfo builds it up in reverse order. getInfo :: IsInfo v => Info -> v -getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l)) +getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) -- | Maps a function over all values stored in the Info that are of the -- appropriate type. mapInfo :: IsInfo v => (v -> v) -> Info -> Info mapInfo f (Info l) = Info (map go l) where - go (i, p) = case fromDynamic i of - Nothing -> (i, p) - Just v -> (toDyn (f v), p) + go i = case extractInfoEntry i of + Nothing -> i + Just v -> InfoEntry (f v) --- | Filters out parts of the Info that should not propigate out of a +-- | Filters out parts of the Info that should not propagate out of a -- container. -propigatableInfo :: Info -> Info -propigatableInfo (Info l) = Info (filter snd l) +propagatableInfo :: Info -> Info +propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l) -- | Use this to put a value in Info that is not a monoid. --- The last value set will be used. This info does not propigate +-- The last value set will be used. This info does not propagate -- out of a container. data InfoVal v = NoInfoVal | InfoVal v - deriving (Typeable) + deriving (Typeable, Show) instance Monoid (InfoVal v) where mempty = NoInfoVal mappend _ v@(InfoVal _) = v mappend v NoInfoVal = v -instance Typeable v => IsInfo (InfoVal v) where - propigateInfo _ = False +instance (Typeable v, Show v) => IsInfo (InfoVal v) where + propagateInfo _ = False fromInfoVal :: InfoVal v -> Maybe v fromInfoVal NoInfoVal = Nothing diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -40,8 +40,12 @@ type Architecture = String type UserName = String + newtype User = User UserName + deriving (Eq, Ord, Show) + newtype Group = Group String + deriving (Eq, Ord, Show) -- | Makes a Group with the same name as the User. userGroup :: User -> Group diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs --- a/src/Propellor/Types/PrivData.hs +++ b/src/Propellor/Types/PrivData.hs @@ -12,7 +12,7 @@ -- It's fine to add new constructors. data PrivDataField = DockerAuthentication - | SshPubKey SshKeyType UserName + | SshPubKey SshKeyType UserName -- ^ Not used anymore, but retained to avoid breaking serialization of old files | SshPrivKey SshKeyType UserName -- ^ For host key, use empty UserName | SshAuthorizedKeys UserName | Password UserName diff --git a/src/Propellor/Utilities.hs b/src/Propellor/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Utilities.hs @@ -0,0 +1,27 @@ +-- | Re-exports some of propellor's internal utility modules. +-- +-- These are used in the implementation of propellor, including some of its +-- properties. However, there is no API stability; any of these can change +-- or be removed without a major version number increase. +-- +-- Use outside propellor at your own risk. + +module Propellor.Utilities ( + module Utility.PartialPrelude + , module Utility.Process + , module Utility.Exception + , module Utility.Env + , module Utility.Directory + , module Utility.Tmp + , module Utility.Monad + , module Utility.Misc +) where + +import Utility.PartialPrelude +import Utility.Process +import Utility.Exception +import Utility.Env +import Utility.Directory +import Utility.Tmp +import Utility.Monad +import Utility.Misc diff --git a/src/config.hs b/src/config.hs --- a/src/config.hs +++ b/src/config.hs @@ -2,13 +2,12 @@ -- the propellor program. import Propellor -import Propellor.CmdLine -import Propellor.Property.Scheduled 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 @@ -19,25 +18,25 @@ main = defaultMain hosts -- The hosts propellor knows about. --- Edit this to configure propellor! hosts :: [Host] hosts = - [ host "mybox.example.com" - & os (System (Debian 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 * * * *") - - -- add more hosts here... - --, host "foo.example.com" = ... + [ mybox ] + +-- An example host. +mybox :: Host +mybox = host "mybox.example.com" + & os (System (Debian 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