propellor 1.0.0 → 1.2.0

raw patch · 75 files changed

+1367/−433 lines, 75 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +48/−0
• Makefile +9/−4
• config-joey.hs +64/−20
• config-simple.hs +1/−2
• config.hs +1/−2
• debian/changelog +48/−0
• debian/copyright +1/−1
• propellor.1 +0/−15
• propellor.cabal +8/−4
• src/Propellor.hs +2/−0
• src/Propellor/CmdLine.hs +48/−68
• src/Propellor/Engine.hs +77/−20
• src/Propellor/Git.hs +10/−2
• src/Propellor/Gpg.hs +9/−5
• src/Propellor/Message.hs +19/−8
• src/Propellor/PrivData.hs +19/−11
• src/Propellor/PrivData/Paths.hs +3/−0
• src/Propellor/Property.hs +7/−9
• src/Propellor/Property/Apache.hs +7/−4
• src/Propellor/Property/Apt.hs +4/−2
• src/Propellor/Property/Chroot.hs +5/−2
• src/Propellor/Property/Chroot/Util.hs +16/−0
• src/Propellor/Property/Cmd.hs +1/−5
• src/Propellor/Property/Cron.hs +1/−1
• src/Propellor/Property/Debootstrap.hs +40/−17
• src/Propellor/Property/Docker.hs +7/−6
• src/Propellor/Property/File.hs +7/−7
• src/Propellor/Property/Firewall.hs +1/−2
• src/Propellor/Property/Git.hs +23/−2
• src/Propellor/Property/Group.hs +14/−0
• src/Propellor/Property/Grub.hs +40/−2
• src/Propellor/Property/HostingProvider/DigitalOcean.hs +3/−3
• src/Propellor/Property/Mount.hs +23/−0
• src/Propellor/Property/OS.hs +232/−0
• src/Propellor/Property/OpenId.hs +1/−1
• src/Propellor/Property/Reboot.hs +23/−0
• src/Propellor/Property/Service.hs +7/−10
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +1/−1
• src/Propellor/Property/Ssh.hs +17/−4
• src/Propellor/Property/Systemd.hs +1/−2
• src/Propellor/Property/Tor.hs +1/−1
• src/Propellor/Property/User.hs +47/−11
• src/Propellor/Protocol.hs +1/−1
• src/Propellor/Server.hs +0/−139
• src/Propellor/Shim.hs +21/−4
• src/Propellor/Spin.hs +299/−0
• src/Propellor/Ssh.hs +3/−2
• src/Propellor/Types.hs +42/−6
• src/Propellor/Types/Chroot.hs +11/−1
• src/Propellor/Types/Dns.hs +4/−0
• src/Propellor/Types/Docker.hs +7/−0
• src/Propellor/Types/Empty.hs +16/−0
• src/Propellor/Types/OS.hs +14/−3
• src/Propellor/Types/PrivData.hs +32/−1
• src/Utility/Applicative.hs +1/−1
• src/Utility/Data.hs +1/−1
• src/Utility/Directory.hs +1/−1
• src/Utility/Env.hs +1/−1
• src/Utility/Exception.hs +1/−1
• src/Utility/FileMode.hs +1/−1
• src/Utility/FileSystemEncoding.hs +1/−1
• src/Utility/LinuxMkLibs.hs +1/−1
• src/Utility/Misc.hs +1/−1
• src/Utility/Monad.hs +1/−1
• src/Utility/Path.hs +1/−1
• src/Utility/PosixFiles.hs +1/−1
• src/Utility/Process.hs +1/−1
• src/Utility/QuickCheck.hs +1/−1
• src/Utility/SafeCommand.hs +1/−1
• src/Utility/Scheduled.hs +1/−1
• src/Utility/Table.hs +1/−1
• src/Utility/ThreadScheduler.hs +1/−1
• src/Utility/Tmp.hs +1/−1
• src/Utility/UserInfo.hs +1/−1
• src/config.hs +1/−2

@@ -1,3 +1,51 @@+propellor (1.2.0) unstable; urgency=medium++  * Display a warning when ensureProperty is used on a property which has+    Info and is so prevented from propigating it.+  * Removed boolProperty; instead the new toResult can be used. (API change)+  * Include Propellor.Property.OS, which was accidentially left out of the+    cabal file in the last release.+  * Fix Apache.siteEnabled to update the config file and reload apache when+    configuration has changed.++ -- Joey Hess <id@joeyh.name>  Tue, 09 Dec 2014 00:05:09 -0400++propellor (1.1.0) unstable; urgency=medium++  * --spin target --via relay causes propellor to bounce through an+    intermediate relay host, which handles any necessary uploads+    when provisioning the target host.+  * --spin can be passed multiple hosts, and it will provision each host+    in turn.+  * Add --merge, to combine multiple --spin commits into a single, more useful+    commit.+  * Hostname parameters not containing dots are looked up in the DNS to+    find the full hostname.+  * propellor --spin can now deploy propellor to hosts that do not have +    git, ghc, or apt-get. This is accomplished by uploading a fairly+    portable precompiled tarball of propellor.+  * Propellor.Property.OS contains properties that can be used to do a clean+    reinstall of the OS of an existing host. This can be used, for example,+    to do an in-place conversion from Fedora to Debian.+    This is experimental; use with caution!+  * Added group-related properties. Thanks, Félix Sipma.+  * Added Git.barerepo. Thanks, Félix Sipma.+  * Added Grub.installed and Grub.boots properties.+  * New HostContext can be specified when a PrivData value varies per host.+  * hasSomePassword and hasPassword now default to using HostContext.+    To specify a different context, use hasSomePassword' and+    hasPassword' (API change)+  * hasSomePassword and hasPassword now make sure shadow passwords are enabled.+  * cron.runPropellor now runs propellor, rather than using its Makefile.+    This is more robust.+  * propellor.debug can be set in the git config to enable more persistent+    debugging output.+  * Run apt-cache policy with LANG=C so it works on other locales.+  * endAction can be used to register an action to run once propellor+    has successfully run on a host.++ -- Joey Hess <id@joeyh.name>  Sun, 07 Dec 2014 15:23:59 -0400+ propellor (1.0.0) unstable; urgency=medium    * propellor --spin can now be used to update remote hosts, without

@@ -2,6 +2,8 @@  DEBDEPS=gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev +# this target is provided to keep old versions of the propellor cron job+# working, and will eventually be removed run: deps build 	./propellor @@ -16,10 +18,10 @@ 	@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || (cabal update; cabal install async); fi || true  dist/setup-config: propellor.cabal-	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi-	$(CABAL) configure+	@if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi+	@$(CABAL) configure -install:+install: propellor.1 	install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor 	install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor 	mkdir -p dist/gittmp@@ -34,8 +36,11 @@ 		&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head 	rm -rf dist/gittmp +propellor.1: doc/usage.mdwn doc/mdwn2man+	doc/mdwn2man propellor 1 < doc/usage.mdwn > propellor.1+ clean:-	rm -rf dist Setup tags propellor privdata/local+	rm -rf dist Setup tags propellor propellor.1 privdata/local 	find -name \*.o -exec rm {} \; 	find -name \*.hi -exec rm {} \; 

@@ -24,8 +24,10 @@ import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg-import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.Systemd as Systemd+import qualified Propellor.Property.Chroot as Chroot+import qualified Propellor.Property.Debootstrap as Debootstrap+import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode@@ -46,8 +48,27 @@ 	, kite 	, diatom 	, elephant+	, alien+	, testvm 	] ++ monsters +testvm :: Host+testvm = host "testvm.kitenet.net"+	& os (System (Debian Unstable) "amd64")+	& OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net")+	 	`onChange` propertyList "fixing up after clean install"+	 		[ OS.preserveRootSshAuthorized+			, OS.preserveResolvConf+			, Apt.update+			, Grub.boots "/dev/sda"+				`requires` Grub.installed Grub.PC+	 		]+	& Hostname.sane+	& Hostname.searchDomain+	& Apt.installed ["linux-image-amd64"]+	& Apt.installed ["ssh"]+	& User.hasPassword "root"+ darkstar :: Host darkstar = host "darkstar.kitenet.net" 	& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel@@ -55,7 +76,21 @@ 	& Apt.buildDep ["git-annex"] `period` Daily 	& Docker.configured 	! Docker.docked gitAnnexAndroidDev+	& website "foo" +website :: String -> RevertableProperty+website hn = Apache.siteEnabled hn apachecfg+        where+          apachecfg = [ "<VirtualHost *>"+                      , "DocumentRoot /tmp/xx"+                      , "<Directory  /tmp/xx>"+                      , "  Options Indexes FollowSymLinks Multiviews"+                      , "  Order allow,deny"+                      , Apache.allowAll+                      , "</Directory>"+                      , "</VirtualHost>"+                      ]+ clam :: Host clam = standardSystem "clam.kitenet.net" Unstable "amd64" 	[ "Unreliable server. Anything here may be lost at any time!" ]@@ -81,19 +116,22 @@ 	! Ssh.listenPort 80 	! Ssh.listenPort 443 -	! Chroot.provisioned testChroot 	& Systemd.persistentJournal-	& Systemd.nspawned meow+	! Systemd.nspawned meow 	 meow :: Systemd.Container meow = Systemd.container "meow" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty) 	& Apt.serviceInstalledRunning "uptimed" 	& alias "meow.kitenet.net"-	-testChroot :: Chroot.Chroot-testChroot = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty "/tmp/chroot"-	& File.hasContent "/foo" ["hello"] +alien :: Host+alien = host "alientest.kitenet.net"+	& ipv4 "104.131.106.199"+	& Chroot.provisioned+		( Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.MinBase "/debian"+			& Apt.serviceInstalledRunning "uptimed"+		)+ orca :: Host orca = standardSystem "orca.kitenet.net" Unstable "amd64" 	[ "Main git-annex build box." ]@@ -101,6 +139,7 @@  	& Apt.unattendedUpgrades 	& Postfix.satellite+	& Systemd.persistentJournal 	& Docker.configured 	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h") 	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")@@ -114,7 +153,7 @@ -- multiuser system with eg, user passwords that are not deployed -- with propellor. kite :: Host-kite = standardSystemUnhardened "kite.kitenet.net" Unstable "amd64"+kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" 	[ "Welcome to the new kitenet.net server!" 	] 	& ipv4 "66.228.36.95"@@ -125,7 +164,8 @@ 	& Apt.installed ["linux-image-amd64"] 	& Linode.chainPVGrub 5 	& Apt.unattendedUpgrades-	& Apt.installed ["systemd"]+	& Systemd.installed+	& Systemd.persistentJournal 	& Ssh.hostKeys (Context "kitenet.net") 	& Ssh.passwordAuthentication True 	-- Since ssh password authentication is allowed:@@ -183,7 +223,7 @@ 	& ipv4 "107.170.31.195"  	& DigitalOcean.distroKernel-	& Ssh.hostKeys (Context "diatom.kitenet.net")+	& Ssh.hostKeys hostContext 	& Apt.unattendedUpgrades 	& Apt.serviceInstalledRunning "ntp" 	& Postfix.satellite@@ -241,20 +281,25 @@ 	, "(Encrypt all data stored here.)" 	] 	& ipv4 "193.234.225.114"-		& Grub.chainPVGrub "hd0,0" "xen/xvda1" 30++	& Grub.chainPVGrub "hd0,0" "xen/xvda1" 30 	& Postfix.satellite 	& Apt.unattendedUpgrades-	& Ssh.hostKeys ctx+	& Systemd.installed+	& Systemd.persistentJournal+	& Ssh.hostKeys hostContext 	& sshPubKey "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBAJkoPRhUGT8EId6m37uBdYEtq42VNwslKnc9mmO+89ody066q6seHKeFY6ImfwjcyIjM30RTzEwftuVNQnbEB0="-	& Ssh.keyImported SshRsa "joey" ctx+	& Ssh.keyImported SshRsa "joey" hostContext 	& Apt.serviceInstalledRunning "swapspace"-		& alias "eubackup.kitenet.net"++	& alias "eubackup.kitenet.net" 	& Apt.installed ["obnam", "sshfs", "rsync"] 	& JoeySites.obnamRepos ["wren", "pell", "kite"] 	& JoeySites.githubBackup 	& JoeySites.rsyncNetBackup hosts 	& JoeySites.backupsBackedupTo hosts "usbackup.kitenet.net" "lib/backup/eubackup"-		& alias "podcatcher.kitenet.net"++	& alias "podcatcher.kitenet.net" 	& JoeySites.podcatcher 	 	& alias "znc.kitenet.net"@@ -262,7 +307,8 @@ 	-- I'd rather this were on diatom, but it needs unstable. 	& alias "kgb.kitenet.net" 	& JoeySites.kgbServer-		& alias "mumble.kitenet.net"+	+	& alias "mumble.kitenet.net" 	& JoeySites.mumbleServer hosts 	 	& alias "ns3.kitenet.net"@@ -283,8 +329,6 @@ 	-- that port for ssh, for traveling on bad networks that 	-- block 22. 	& Ssh.listenPort 80-  where-	ctx = Context "elephant.kitenet.net"   	    --'                        __|II|      ,.@@ -353,9 +397,9 @@ 	& Apt.installed ["etckeeper"] 	& Apt.installed ["ssh"] 	& GitHome.installedFor "root"-	& User.hasSomePassword "root" (Context hn)+	& User.hasSomePassword "root" 	& User.accountFor "joey"-	& User.hasSomePassword "joey" (Context hn)+	& User.hasSomePassword "joey" 	& Sudo.enabledFor "joey" 	& GitHome.installedFor "joey" 	& Apt.installed ["vim", "screen", "less"]

@@ -12,7 +12,6 @@ --import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User --import qualified Propellor.Property.Hostname as Hostname---import qualified Propellor.Property.Reboot as Reboot --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker @@ -29,7 +28,7 @@ 		& Apt.unattendedUpgrades 		& Apt.installed ["etckeeper"] 		& Apt.installed ["ssh"]-		& User.hasSomePassword "root" (Context "mybox.example.com")+		& User.hasSomePassword "root" 		& Network.ipv6to4 		& File.dirExists "/var/www" 		& Docker.docked webserverContainer

@@ -12,7 +12,6 @@ --import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User --import qualified Propellor.Property.Hostname as Hostname---import qualified Propellor.Property.Reboot as Reboot --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker @@ -29,7 +28,7 @@ 		& Apt.unattendedUpgrades 		& Apt.installed ["etckeeper"] 		& Apt.installed ["ssh"]-		& User.hasSomePassword "root" (Context "mybox.example.com")+		& User.hasSomePassword "root" 		& Network.ipv6to4 		& File.dirExists "/var/www" 		& Docker.docked webserverContainer

@@ -1,3 +1,51 @@+propellor (1.2.0) unstable; urgency=medium++  * Display a warning when ensureProperty is used on a property which has+    Info and is so prevented from propigating it.+  * Removed boolProperty; instead the new toResult can be used. (API change)+  * Include Propellor.Property.OS, which was accidentially left out of the+    cabal file in the last release.+  * Fix Apache.siteEnabled to update the config file and reload apache when+    configuration has changed.++ -- Joey Hess <id@joeyh.name>  Tue, 09 Dec 2014 00:05:09 -0400++propellor (1.1.0) unstable; urgency=medium++  * --spin target --via relay causes propellor to bounce through an+    intermediate relay host, which handles any necessary uploads+    when provisioning the target host.+  * --spin can be passed multiple hosts, and it will provision each host+    in turn.+  * Add --merge, to combine multiple --spin commits into a single, more useful+    commit.+  * Hostname parameters not containing dots are looked up in the DNS to+    find the full hostname.+  * propellor --spin can now deploy propellor to hosts that do not have +    git, ghc, or apt-get. This is accomplished by uploading a fairly+    portable precompiled tarball of propellor.+  * Propellor.Property.OS contains properties that can be used to do a clean+    reinstall of the OS of an existing host. This can be used, for example,+    to do an in-place conversion from Fedora to Debian.+    This is experimental; use with caution!+  * Added group-related properties. Thanks, Félix Sipma.+  * Added Git.barerepo. Thanks, Félix Sipma.+  * Added Grub.installed and Grub.boots properties.+  * New HostContext can be specified when a PrivData value varies per host.+  * hasSomePassword and hasPassword now default to using HostContext.+    To specify a different context, use hasSomePassword' and+    hasPassword' (API change)+  * hasSomePassword and hasPassword now make sure shadow passwords are enabled.+  * cron.runPropellor now runs propellor, rather than using its Makefile.+    This is more robust.+  * propellor.debug can be set in the git config to enable more persistent+    debugging output.+  * Run apt-cache policy with LANG=C so it works on other locales.+  * endAction can be used to register an action to run once propellor+    has successfully run on a host.++ -- Joey Hess <id@joeyh.name>  Sun, 07 Dec 2014 15:23:59 -0400+ propellor (1.0.0) unstable; urgency=medium    * propellor --spin can now be used to update remote hosts, without

@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2014 Joey Hess <id@joeyh.name>+Copyright: © 2010-2014 Joey Hess <id@joeyh.name> and contributors License: BSD-2-clause  License: BSD-2-clause

@@ -1,15 +0,0 @@-.\" -*- nroff -*--.TH propellor 1 "Commands"-.SH NAME-propellor \- property-based host configuration management in haskell-.SH SYNOPSIS-.B propellor [options] host-.SH DESCRIPTION-.I propellor-is a property-based host configuration management program written -and configured in haskell.-.PP-The first time you run propellor, it will set up a ~/.propellor/-repository. Edit ~/.propellor/config.hs to configure it.-.SH AUTHOR -Joey Hess <joey@kitenet.net>

@@ -1,8 +1,8 @@ Name: propellor-Version: 1.0.0+Version: 1.2.0 Cabal-Version: >= 1.6 License: BSD3-Maintainer: Joey Hess <joey@kitenet.net>+Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable Copyright: 2014 Joey Hess@@ -18,7 +18,6 @@   config-simple.hs   config-joey.hs   config.hs-  propellor.1   debian/changelog   debian/README.Debian   debian/compat@@ -83,11 +82,14 @@     Propellor.Property.Firewall     Propellor.Property.Git     Propellor.Property.Gpg+    Propellor.Property.Group     Propellor.Property.Grub+    Propellor.Property.Mount     Propellor.Property.Network     Propellor.Property.Nginx     Propellor.Property.Obnam     Propellor.Property.OpenId+    Propellor.Property.OS     Propellor.Property.Postfix     Propellor.Property.Prosody     Propellor.Property.Reboot@@ -116,16 +118,18 @@     Propellor.Types.Chroot     Propellor.Types.Docker     Propellor.Types.Dns+    Propellor.Types.Empty     Propellor.Types.OS     Propellor.Types.PrivData   Other-Modules:     Propellor.Git     Propellor.Gpg-    Propellor.Server+    Propellor.Spin     Propellor.Ssh     Propellor.PrivData.Paths     Propellor.Protocol     Propellor.Shim+    Propellor.Property.Chroot.Util     Utility.Applicative     Utility.Data     Utility.Directory

@@ -36,6 +36,7 @@ 	, module Propellor.Host 	, module Propellor.Info 	, module Propellor.PrivData+	, module Propellor.Types.PrivData 	, module Propellor.Engine 	, module Propellor.Exception 	, module Propellor.Message@@ -49,6 +50,7 @@ import Propellor.Engine import Propellor.Property.Cmd import Propellor.PrivData+import Propellor.Types.PrivData import Propellor.Message import Propellor.Exception import Propellor.Info

@@ -7,13 +7,12 @@ import Data.List import System.Exit import System.PosixCompat+import qualified Network.BSD  import Propellor-import Propellor.Protocol import Propellor.Gpg import Propellor.Git-import Propellor.Ssh-import Propellor.Server+import Propellor.Spin import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim@@ -24,12 +23,13 @@ 	[ "Usage:" 	, "  propellor" 	, "  propellor hostname"-	, "  propellor --spin hostname"+	, "  propellor --spin targethost [--via relayhost]" 	, "  propellor --add-key keyid" 	, "  propellor --set field context" 	, "  propellor --dump field context" 	, "  propellor --edit field context" 	, "  propellor --list-fields"+	, "  propellor --merge" 	]  usageError :: [String] -> IO a@@ -40,25 +40,29 @@ processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs   where-	go ("--run":h:[]) = return $ Run h-	go ("--spin":h:[]) = return $ Spin h+	go ("--spin":ps) = case reverse ps of+		(r:"--via":hs) -> Spin +			<$> mapM hostname (reverse hs) +			<*> pure (Just r)+		_ -> Spin <$> mapM hostname ps <*> pure Nothing 	go ("--add-key":k:[]) = return $ AddKey k 	go ("--set":f:c:[]) = withprivfield f c Set 	go ("--dump":f:c:[]) = withprivfield f c Dump 	go ("--edit":f:c:[]) = withprivfield f c Edit 	go ("--list-fields":[]) = return ListFields+	go ("--merge":[]) = return Merge 	go ("--help":_) = do	 		usage stdout 		exitFailure-	go ("--update":h:[]) = return $ Update h-	go ("--boot":h:[]) = return $ Update h -- for back-compat-	go ("--continue":s:[]) = case readish s of-		Just cmdline -> return $ Continue cmdline-		Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"+	go ("--update":_:[]) = return $ Update Nothing+	go ("--boot":_:[]) = return $ Update Nothing -- for back-compat+	go ("--serialized":s:[]) = serialized Serialized s+	go ("--continue":s:[]) = serialized Continue s 	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)+	go ("--run":h:[]) = go [h] 	go (h:[]) 		| "--" `isPrefixOf` h = usageError [h]-		| otherwise = return $ Run h+		| otherwise = Run <$> hostname h 	go [] = do 		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] 		if null s@@ -70,6 +74,10 @@ 		Just pf -> return $ f pf (Context c) 		Nothing -> errorMessage $ "Unknown privdata field " ++ s +	serialized mk s = case readish s of+		Just cmdline -> return $ mk cmdline+		Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"+ -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = do@@ -79,6 +87,7 @@ 	debug ["command line: ", show cmdline] 	go True cmdline   where+	go _ (Serialized cmdline) = go True cmdline 	go _ (Continue cmdline) = go False cmdline 	go _ (Set field context) = setPrivData field context 	go _ (Dump field context) = dumpPrivData field context@@ -89,15 +98,19 @@ 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid 	go _ (DockerInit hn) = Docker.init hn 	go _ (GitPush fin fout) = gitPushHelper fin fout-	go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)-	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline+	go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))+	go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h))+	go _ Merge = mergeSpin+	go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline 	go True cmdline = updateFirst cmdline $ go False cmdline-	go False (Spin hn) = withhost hn $ spin hn+	go False (Spin hs r) = do+		commitSpin+		forM_ hs $ \hn -> withhost hn $ spin hn r 	go False cmdline@(SimpleRun hn) = buildFirst cmdline $ 		go False (Run hn) 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID) 		( onlyprocess $ withhost hn mainProperties-		, go True (Spin hn)+		, go True (Spin [hn] Nothing) 		)  	withhost :: HostName -> (Host -> IO ()) -> IO ()@@ -114,16 +127,19 @@ 	]  buildFirst :: CmdLine -> IO () -> IO ()-buildFirst cmdline next = do-	oldtime <- getmtime-	ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])-		( do-			newtime <- getmtime-			if newtime == oldtime-				then next-				else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]-		, errorMessage "Propellor build failed!" -		)+buildFirst cmdline next = ifM (doesFileExist "Makefile")+	( do+		oldtime <- getmtime+		ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])+			( do+				newtime <- getmtime+				if newtime == oldtime+					then next+					else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]+			, errorMessage "Propellor build failed!" +			)+	, next+	)   where 	getmtime = catchMaybeIO $ getModificationTime "propellor" @@ -145,45 +161,9 @@ 	, next 	) -spin :: HostName -> Host -> IO ()-spin hn hst = do-	void $ actionMessage "Git commit" $-		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]-	-- Push to central origin repo first, if possible.-	-- The remote propellor will pull from there, which avoids-	-- us needing to send stuff directly to the remote host.-	whenM hasOrigin $-		void $ actionMessage "Push to central git repository" $-			boolSystem "git" [Param "push"]-	-	cacheparams <- toCommand <$> sshCachingParams hn--	-- Install, or update the remote propellor.-	updateServer hn hst $ withBothHandles createProcessSuccess-		(proc "ssh" $ cacheparams ++ [user, updatecmd])--	-- And now we can run it.-	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $-		error $ "remote propellor failed"-  where-	user = "root@"++hn--	mkcmd = shellWrap . intercalate " ; "--	updatecmd = mkcmd-		[ "if [ ! -d " ++ localdir ++ " ]"-		, "then " ++ intercalate " && "-			[ "apt-get update"-			, "apt-get --no-install-recommends --no-upgrade -y install git make"-			, "echo " ++ toMarked statusMarker (show NeedGitClone)-			]-		, "else " ++ intercalate " && "-			[ "cd " ++ localdir-			, "if ! test -x ./propellor; then make deps build; fi"-			, "./propellor --boot " ++ hn-			]-		, "fi"-		]--	runcmd = mkcmd-		[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]+hostname :: String -> IO HostName+hostname s+	| "." `isInfixOf` s = pure s+	| otherwise = do+		h <- Network.BSD.getHostByName s+		return (Network.BSD.hostName h)

@@ -1,19 +1,29 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Engine where+module Propellor.Engine (+	mainProperties,+	runPropellor,+	ensureProperty,+	ensureProperties,+	fromHost,+	onlyProcess,+	processChainOutput,+) where  import System.Exit import System.IO import Data.Monoid import Control.Applicative import System.Console.ANSI-import "mtl" Control.Monad.Reader+import "mtl" Control.Monad.RWS.Strict import Control.Exception (bracket) import System.PosixCompat import System.Posix.IO-import Data.Maybe+import System.FilePath+import System.Directory  import Propellor.Types+import Propellor.Types.Empty import Propellor.Message import Propellor.Exception import Propellor.Info@@ -21,44 +31,81 @@ import Utility.PartialPrelude import Utility.Monad -runPropellor :: Host -> Propellor a -> IO a-runPropellor host a = runReaderT (runWithHost a) host-+-- | Gets the Properties of a Host, and ensures them all,+-- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do-	r <- runPropellor host $-		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]-	setTitle "propellor: done"+	ret <- runPropellor host $+		ensureProperties [Property "overall" (ensurePropertiesWith ensureProperty' $ hostProperties host) mempty]+	h <- mkMessageHandle+        whenConsole h $+		setTitle "propellor: done" 	hFlush stdout-	case r of+	case ret of 		FailedChange -> exitWith (ExitFailure 1) 		_ -> exitWith ExitSuccess +-- | Runs a Propellor action with the specified host.+--+-- If the Result is not FailedChange, any EndActions+-- that were accumulated while running the action+-- are then also run.+runPropellor :: Host -> Propellor Result -> IO Result+runPropellor host a = do+	(res, _s, endactions) <- runRWST (runWithHost a) host ()+	endres <- mapM (runEndAction host res) endactions+	return $ mconcat (res:endres)++runEndAction :: Host -> Result -> EndAction -> IO Result+runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc $ do+	(ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host ()+	return ret++-- | For when code running in the Propellor monad needs to ensure a+-- Property.+--+-- Note that any info of the Property is not propigated out to+-- the enclosing Property, and so will not be available for propellor to+-- use. A warning message will be printed if this is detected.+ensureProperty :: Property -> Propellor Result+ensureProperty p = do+	unless (isEmpty (getInfo p)) $+		warningMessage $ "ensureProperty called on " ++ show p ++ "; will not propigate its info: " ++ show (getInfo p)+	ensureProperty' p++ensureProperty' :: Property -> Propellor Result+ensureProperty' = catchPropellor . propertySatisfy++-- | Ensures a list of Properties, with a display of each as it runs. ensureProperties :: [Property] -> Propellor Result-ensureProperties ps = ensure ps NoChange+ensureProperties = ensurePropertiesWith ensureProperty++ensurePropertiesWith :: (Property -> Propellor Result) -> [Property] -> Propellor Result+ensurePropertiesWith a ps = ensure ps NoChange   where 	ensure [] rs = return rs-	ensure (l:ls) rs = do+	ensure (p:ls) rs = do 		hn <- asks hostName-		r <- actionMessageOn hn (propertyDesc l) (ensureProperty l)+		r <- actionMessageOn hn (propertyDesc p) (a p) 		ensure ls (r <> rs) -ensureProperty :: Property -> Propellor Result-ensureProperty = catchPropellor . propertySatisfy- -- | Lifts an action into a different host. -- -- For example, `fromHost hosts "otherhost" getSshPubKey` fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) fromHost l hn getter = case findHost l hn of 	Nothing -> return Nothing-	Just h -> liftIO $ Just <$>-		runReaderT (runWithHost getter) h+	Just h -> do+		(ret, _s, runlog) <- liftIO $+			runRWST (runWithHost getter) h ()+		tell runlog+		return (Just ret)  onlyProcess :: FilePath -> IO a -> IO a onlyProcess lockfile a = bracket lock unlock (const a)   where 	lock = do+		createDirectoryIfMissing True (takeDirectory lockfile) 		l <- createFile lockfile stdFileMode 		setLock l (WriteLock, AbsoluteSeek, 0, 0) 			`catchIO` const alreadyrunning@@ -73,9 +120,19 @@   where 	go lastline = do 		v <- catchMaybeIO (hGetLine h)+		debug ["read from chained propellor: ", show v] 		case v of-			Nothing -> pure $ fromMaybe FailedChange $-				readish =<< lastline+			Nothing -> case lastline of+				Nothing -> do+					debug ["chained propellor output nothing; assuming it failed"]+					return FailedChange+				Just l -> case readish l of+					Just r -> pure r+					Nothing -> do+						debug ["chained propellor output did not end with a Result; assuming it failed"]+						putStrLn l+						hFlush stdout+						return FailedChange 			Just s -> do 				maybe noop (\l -> unless (null l) (putStrLn l)) lastline 				hFlush stdout

@@ -10,8 +10,13 @@ getCurrentBranch = takeWhile (/= '\n')  	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] +getCurrentBranchRef :: IO String+getCurrentBranchRef = takeWhile (/= '\n') +	<$> readProcess "git" ["symbolic-ref", "HEAD"]+ getCurrentGitSha1 :: String -> IO String-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]+getCurrentGitSha1 branchref = takeWhile (/= '\n')+	<$> readProcess "git" ["show-ref", "--hash", branchref]  setRepoUrl :: String -> IO () setRepoUrl "" = return ()@@ -38,9 +43,12 @@ 			_ -> Nothing  hasOrigin :: IO Bool-hasOrigin = do+hasOrigin = catchDefaultIO False $ do 	rs <- lines <$> readProcess "git" ["remote"] 	return $ "origin" `elem` rs++hasGitRepo :: IO Bool+hasGitRepo = doesFileExist ".git/HEAD"  {- To verify origin branch commit's signature, have to convince gpg  - to use our keyring.

@@ -83,14 +83,18 @@ 		, Param "propellor addkey" 		] +-- Adds --gpg-sign if there's a keyring.+gpgSignParams :: [CommandParam] -> IO [CommandParam]+gpgSignParams ps = ifM (doesFileExist keyring)+	( return (ps ++ [Param "--gpg-sign"])+	, return ps+	)+ -- Automatically sign the commit if there'a a keyring. gitCommit :: [CommandParam] -> IO Bool gitCommit ps = do-	k <- doesFileExist keyring-	boolSystem "git" $ catMaybes $-		[ Just (Param "commit")-		, if k then Just (Param "--gpg-sign") else Nothing-		] ++ map Just ps+	ps' <- gpgSignParams ps+	boolSystem "git" (Param "commit" : ps')  gpgDecrypt :: FilePath -> IO String gpgDecrypt f = ifM (doesFileExist f)

@@ -11,10 +11,14 @@ import "mtl" Control.Monad.Reader import Data.Maybe import Control.Applicative+import System.Directory+import Control.Monad.IfElse  import Propellor.Types import Utility.Monad import Utility.Env+import Utility.Process+import Utility.Exception  data MessageHandle 	= ConsoleMessageHandle@@ -99,17 +103,24 @@ 	putStrLn "" 	hFlush stdout --- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1 debug :: [String] -> IO () debug = debugM "propellor" . unwords  checkDebugMode :: IO () checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"   where-	go (Just "1") = do-		f <- setFormatter-			<$> streamHandler stderr DEBUG-			<*> pure (simpleLogFormatter "[$time] $msg")-		updateGlobalLogger rootLoggerName $ -			setLevel DEBUG .  setHandlers [f]-	go _ = noop+	go (Just "1") = enableDebugMode+	go (Just _) = noop+	go Nothing = whenM (doesDirectoryExist ".git") $+		whenM (any (== "1") . lines <$> getgitconfig) $+			enableDebugMode+	getgitconfig = catchDefaultIO "" $+		readProcess "git" ["config", "propellor.debug"]++enableDebugMode :: IO ()+enableDebugMode = do+	f <- setFormatter+		<$> streamHandler stderr DEBUG+		<*> pure (simpleLogFormatter "[$time] $msg")+	updateGlobalLogger rootLoggerName $ +		setLevel DEBUG .  setHandlers [f]

@@ -15,6 +15,7 @@ import qualified Data.Set as S  import Propellor.Types+import Propellor.Types.PrivData import Propellor.Message import Propellor.Info import Propellor.Gpg@@ -30,7 +31,7 @@ import Utility.Table  -- | Allows a Property to access the value of a specific PrivDataField,--- for use in a specific Context.+-- for use in a specific Context or HostContext. -- -- Example use: --@@ -47,20 +48,26 @@ -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData-	:: PrivDataField-	-> Context+	:: IsContext c+	=> PrivDataField+	-> c 	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) 	-> Property-withPrivData field context@(Context cname) mkprop = addinfo $ mkprop $ \a ->-	maybe missing a =<< liftIO (getLocalPrivData field context)+withPrivData field c mkprop = addinfo $ mkprop $ \a ->+	maybe missing a =<< get   where-	missing = liftIO $ do+  	get = do+		context <- mkHostContext hc <$> asks hostName+		liftIO $ getLocalPrivData field context+	missing = do+		Context cname <- mkHostContext hc <$> asks hostName 		warningMessage $ "Missing privdata " ++ show field ++ " (for " ++ cname ++ ")"-		putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'"+		liftIO $ putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'" 		return FailedChange-	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, context) } }+	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, hc) } }+	hc = asHostContext c -addPrivDataField :: (PrivDataField, Context) -> Property+addPrivDataField :: (PrivDataField, HostContext) -> Property addPrivDataField v = pureInfoProperty (show v) $ 	mempty { _privDataFields = S.singleton v } @@ -78,7 +85,8 @@ filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used)   where-	used = _privDataFields $ hostInfo host+	used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $+		_privDataFields $ hostInfo host  getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context = M.lookup (field, context)@@ -119,7 +127,7 @@ 		, shellEscape context 		, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby 		]-	mkhostmap host = M.fromList $ map (\k -> (k, [hostName host])) $+	mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $ 		S.toList $ _privDataFields $ hostInfo host 	usedby = M.unionsWith (++) $ map mkhostmap hosts 	wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")

@@ -10,3 +10,6 @@  privDataLocal :: FilePath privDataLocal = privDataDir </> "local"++privDataRelay :: String -> FilePath+privDataRelay host = privDataDir </> "relay" </> host

@@ -7,7 +7,7 @@ import Control.Monad import Data.Monoid import Control.Monad.IfElse-import "mtl" Control.Monad.Reader+import "mtl" Control.Monad.RWS.Strict  import Propellor.Types import Propellor.Info@@ -121,21 +121,15 @@ withOS :: Desc -> (Maybe System -> Propellor Result) -> Property withOS desc a = property desc $ a =<< getOS -boolProperty :: Desc -> IO Bool -> Property-boolProperty desc a = property desc $ ifM (liftIO a)-	( return MadeChange-	, return FailedChange-	)- -- | Undoes the effect of a property. revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- Changes the action that is performed to satisfy a property. +-- | Changes the action that is performed to satisfy a property.  adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } --- Combines the Info of two properties.+-- | Combines the Info of two properties. combineInfo :: (IsProp p, IsProp q) => p -> q -> Info combineInfo p q = getInfo p <> getInfo q @@ -147,3 +141,7 @@  noChange :: Propellor Result noChange = return NoChange++-- | Registers an action that should be run at the very end,+endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()+endAction desc a = tell [EndAction desc a]

@@ -11,12 +11,15 @@ siteEnabled :: HostName -> ConfigFile -> RevertableProperty siteEnabled hn cf = RevertableProperty enable disable   where-	enable = check (not <$> isenabled) $-		cmdProperty "a2ensite" ["--quiet", hn]-			`describe` ("apache site enabled " ++ hn)-			`requires` siteAvailable hn cf+	enable = combineProperties ("apache site enabled " ++ hn)+		[ siteAvailable hn cf 			`requires` installed 			`onChange` reloaded+		, check (not <$> isenabled) $+			cmdProperty "a2ensite" ["--quiet", hn]+				`requires` installed+				`onChange` reloaded+		] 	disable = combineProperties 		("apache site disabled " ++ hn)  		(map File.notPresent (siteCfg hn))

@@ -193,13 +193,15 @@ -- even vary. If apt does not know about a package at all, it will not -- be included in the result list. isInstalled' :: [Package] -> IO [Bool]-isInstalled' ps = catMaybes . map parse . lines-	<$> readProcess "apt-cache" ("policy":ps)+isInstalled' ps = catMaybes . map parse . lines <$> policy   where 	parse l 		| "Installed: (none)" `isInfixOf` l = Just False 		| "Installed: " `isInfixOf` l = Just True 		| otherwise = Nothing+	policy = do+		environ <- addEntry "LANG" "C" <$> getEnvironment+		readProcessEnv "apt-cache" ("policy":ps) (Just environ)  autoRemove :: Property autoRemove = runApt ["-y", "autoremove"]

@@ -11,6 +11,7 @@  import Propellor import Propellor.Types.Chroot+import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Shim as Shim@@ -88,7 +89,7 @@ 	let me = localdir </> "propellor" 	shim <- liftIO $ ifM (doesDirectoryExist d) 		( pure (Shim.file me d)-		, Shim.setup me d+		, Shim.setup me Nothing d 		) 	ifM (liftIO $ bindmount shim) 		( chainprovision shim@@ -109,12 +110,14 @@ 	chainprovision shim = do 		parenthost <- asks hostName 		cmd <- liftIO $ toChain parenthost c systemdonly+		pe <- liftIO standardPathEnv 		let p = mkproc 			[ shim 			, "--continue" 			, show cmd 			]-		liftIO $ withHandle StdoutHandle createProcessSuccess p+		let p' = p { env = Just pe }+		liftIO $ withHandle StdoutHandle createProcessSuccess p' 			processChainOutput  toChain :: HostName -> Chroot -> Bool -> IO CmdLine

@@ -0,0 +1,16 @@+module Propellor.Property.Chroot.Util where++import Utility.Env+import Control.Applicative++-- 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)]+standardPathEnv = do+	path <- getEnvDefault "PATH" "/bin"+	addEntry "PATH" (path ++ stdPATH)+		<$> getEnvironment++stdPATH :: String+stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"

@@ -13,7 +13,6 @@  import Propellor.Types import Propellor.Property-import Utility.Monad import Utility.SafeCommand import Utility.Env @@ -28,10 +27,7 @@ cmdProperty' :: String -> [String] -> [(String, String)] -> Property cmdProperty' cmd params env = property desc $ liftIO $ do 	env' <- addEntries env <$> getEnvironment-	ifM (boolSystemEnv cmd (map Param params) (Just env'))-		( return MadeChange-		, return FailedChange-		)+	toResult <$> boolSystemEnv cmd (map Param params) (Just env')   where 	desc = unwords $ cmd : params 

@@ -58,4 +58,4 @@  -- | Installs a cron job to run propellor. runPropellor :: CronTimes -> Property-runPropellor times = niceJob "propellor" times "root" localdir "make"+runPropellor times = niceJob "propellor" times "root" localdir "./propellor"

@@ -2,12 +2,16 @@ 	Url, 	DebootstrapConfig(..), 	built,+	built', 	installed,+	sourceInstall, 	programPath, ) where  import Propellor import qualified Propellor.Property.Apt as Apt+import Propellor.Property.Chroot.Util+import Propellor.Property.Mount import Utility.Path import Utility.SafeCommand import Utility.FileMode@@ -52,11 +56,14 @@ -- Note that reverting this property does not stop any processes -- currently running in the chroot. built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty-built target system@(System _ arch) config =+built = built' (toProp installed)++built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty+built' installprop target system@(System _ arch) config = 	RevertableProperty setup teardown   where 	setup = check (unpopulated target <||> ispartial) setupprop-		`requires` toProp installed+		`requires` installprop 	 	teardown = check (not <$> unpopulated target) teardownprop 	@@ -78,24 +85,22 @@ 			, Param target 			] 		cmd <- fromMaybe "debootstrap" <$> programPath-		ifM (boolSystem cmd params)+		de <- standardPathEnv+		ifM (boolSystemEnv cmd params (Just de)) 			( do 				fixForeignDev target 				return MadeChange 			, return FailedChange 			) -	teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do-		removetarget-		return MadeChange+	teardownprop = property ("removed debootstrapped " ++ target) $+		makeChange removetarget  	removetarget = do 		submnts <- filter (\p -> simplifyPath p /= simplifyPath target) 			. filter (dirContains target) 			<$> mountPoints-		forM_ submnts $ \mnt ->-			unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do-				errorMessage $ "failed unmounting " ++ mnt+		forM_ submnts umountLazy 		removeDirectoryRecursive target  	-- A failed debootstrap run will leave a debootstrap directory;@@ -107,9 +112,6 @@ 		, return False 		) -mountPoints :: IO [FilePath]-mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]- extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r@@ -141,9 +143,25 @@ 	aptremove = Apt.removed ["debootstrap"]  sourceInstall :: Property-sourceInstall = property "debootstrap installed from source"-	(liftIO sourceInstall')+sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')+	`requires` perlInstalled+	`requires` arInstalled +perlInstalled :: Property+perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $+	liftIO $ toResult . isJust <$> firstM id+		[ yumInstall "perl"+		]++arInstalled :: Property+arInstalled = check (not <$> inPath "ar") $ property "ar installed" $+	liftIO $ toResult . isJust <$> firstM id+		[ yumInstall "binutils"+		]++yumInstall :: String -> IO Bool+yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p]+ sourceInstall' :: IO Result sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do 	let indexfile = tmpd </> "index.html"@@ -228,18 +246,23 @@ 	tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz"  fixForeignDev :: FilePath -> IO ()-fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ -	void $ boolSystem "chroot"+fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do+	de <- standardPathEnv+	void $ boolSystemEnv "chroot" 		[ File target 		, Param "sh" 		, Param "-c" 		, Param $ intercalate " && "-			[ "rm -rf /dev"+			[ "apt-get update"+			, "apt-get -y install makedev"+			, "rm -rf /dev" 			, "mkdir /dev" 			, "cd /dev"+			, "mount -t proc proc /proc" 			, "/sbin/MAKEDEV std ptmx fd consoleonly" 			] 		]+		(Just de)  foreignDevFlag :: FilePath foreignDevFlag = "/dev/.propellor-foreign-dev"

@@ -377,11 +377,12 @@ 		liftIO $ do 			clearProvisionedFlag cid 			createDirectoryIfMissing True (takeDirectory $ identFile cid)-		shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)+		shim <- liftIO $ Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid) 		liftIO $ writeFile (identFile cid) (show ident)-		ensureProperty $ boolProperty "run" $ runContainer img-			(runps ++ ["-i", "-d", "-t"])-			[shim, "--continue", show (DockerInit (fromContainerId cid))]+		ensureProperty $ property "run" $ liftIO $+			toResult <$> runContainer img+				(runps ++ ["-i", "-d", "-t"])+				[shim, "--continue", show (DockerInit (fromContainerId cid))]  -- | Called when propellor is running inside a docker container. -- The string should be the container's ContainerId.@@ -430,7 +431,7 @@ 	let params = ["--continue", show $ toChain cid] 	msgh <- mkMessageHandle 	let p = inContainerProcess cid-		[ if isConsole msgh then "-it" else "-i" ]+		(if isConsole msgh then ["-it"] else []) 		(shim : params) 	r <- withHandle StdoutHandle createProcessSuccess p $ 		processChainOutput@@ -466,7 +467,7 @@ stoppedContainer cid = containerDesc cid $ property desc $  	ifM (liftIO $ elem cid <$> listContainers RunningContainers) 		( liftIO cleanup `after` ensureProperty -			(boolProperty desc $ stopContainer cid)+			(property desc $ liftIO $ toResult <$> stopContainer cid) 		, return NoChange 		)   where

@@ -17,17 +17,17 @@ -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600.-hasPrivContent :: FilePath -> Context -> Property+hasPrivContent :: IsContext c => FilePath -> c -> Property hasPrivContent = hasPrivContent' writeFileProtected  -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution!-hasPrivContentExposed :: FilePath -> Context -> Property+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property hasPrivContentExposed = hasPrivContent' writeFile -hasPrivContent' :: (String -> FilePath -> IO ()) -> FilePath -> Context -> Property+hasPrivContent' :: IsContext c => (String -> FilePath -> IO ()) -> FilePath -> c -> Property hasPrivContent' writer f context =  	withPrivData (PrivFile f) context $ \getcontent ->  		property desc $ getcontent $ \privcontent -> @@ -62,11 +62,11 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)   where 	go True = do-		ls <- liftIO $ lines <$> readFile f-		let ls' = a ls-		if ls' == ls+		old <- liftIO $ readFile f+		let new = unlines (a (lines old))+		if old == new 			then noChange-			else makeChange $ viaTmp updatefile f (unlines ls')+			else makeChange $ viaTmp updatefile f new 	go False = makeChange $ writer f (unlines $ a [])  	-- viaTmp makes the temp file mode 600.

@@ -33,8 +33,7 @@ 		exist <- boolSystem "iptables" (chk args) 		if exist 			then return NoChange-			else ifM (boolSystem "iptables" (add args))-				( return MadeChange , return FailedChange)+			else toResult <$> boolSystem "iptables" (add args) 	add params = (Param "-A") : params 	chk params = (Param "-C") : params 

@@ -57,8 +57,9 @@  -- | Specified git repository is cloned to the specified directory. ----- If the firectory exists with some other content, it will be recursively--- deleted.+-- If the directory exists with some other content (either a non-git+-- repository, or a git repository cloned from some other location),+-- it will be recursively deleted first. -- -- A branch can be specified, to check out. cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property@@ -94,3 +95,23 @@  isGitDir :: FilePath -> IO Bool isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir])++data GitShared = Shared GroupName | SharedAll | NotShared++bareRepo :: FilePath -> UserName -> GitShared -> Property+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $+	dirExists repo : case gitshared of+		NotShared ->+			[ ownerGroup repo user user+			, userScriptProperty user ["git", "init", "--bare", "--shared=false", repo]+			]+		SharedAll ->+			[ ownerGroup repo user user+			, userScriptProperty user ["git", "init", "--bare", "--shared=all", repo]+			]+		Shared group' ->+			[ ownerGroup repo user group'+			, userScriptProperty user ["git", "init", "--bare", "--shared=group", repo]+			]+  where+	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])

@@ -0,0 +1,14 @@+module Propellor.Property.Group where++import Propellor++type GID = Int++exists :: GroupName -> Maybe GID -> Property+exists group' mgid = check test (cmdProperty "addgroup" $ args mgid)+	`describe` unwords ["group", group']+  where+	groupFile = "/etc/group"+	test = not . elem group' . words <$> readProcess "cut" ["-d:", "-f1", groupFile]+	args Nothing = [group']+	args (Just gid) = ["--gid", show gid, group']

@@ -7,8 +7,46 @@ -- | Eg, hd0,0 or xen/xvda1 type GrubDevice = String +-- | Eg, /dev/sda+type OSDevice = String+ type TimeoutSecs = Int +-- | Types of machines that grub can boot.+data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen++-- | Installs the grub package. This does not make grub be used as the+-- bootloader.+--+-- This includes running update-grub, so that the grub boot menu is+-- created. It will be automatically updated when kernel packages are+-- installed.+installed :: BIOS -> Property+installed bios = +	Apt.installed [pkg] `describe` "grub package installed"+		`before`+	cmdProperty "update-grub" []+  where+	pkg = case bios of+		PC -> "grub-pc"+		EFI64 -> "grub-efi-amd64"+		EFI32 -> "grub-efi-ia32"+		Coreboot -> "grub-coreboot"+		Xen -> "grub-xen"++-- | Installs grub onto a device, so the system can boot from that device.+--+-- You may want to install grub to multiple devices; eg for a system+-- that uses software RAID.+--+-- Note that this property does not check if grub is already installed+-- on the device; it always does the work to reinstall it. It's a good idea+-- to arrange for this property to only run once, by eg making it be run+-- onChange after OS.cleanInstallOnce.+boots :: OSDevice -> Property+boots dev = cmdProperty "grub-install" [dev]+	`describe` ("grub boots " ++ dev)+ -- | Use PV-grub chaining to boot -- -- Useful when the VPS's pv-grub is too old to boot a modern kernel image.@@ -31,8 +69,8 @@ 		] 	, "/boot/load.cf" `File.hasContent` 		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]-	, Apt.installed ["grub-xen"]-	, flagFile (scriptProperty ["update-grub; grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim"+	, installed Xen+	, flagFile (scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim" 			`describe` "/boot-xen-shim" 	]   where

@@ -5,6 +5,7 @@ import Propellor import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File+import qualified Propellor.Property.Reboot as Reboot  import Data.List @@ -24,9 +25,8 @@ 		[ "LOAD_KEXEC=true" 		, "USE_GRUB_CONFIG=true" 		] `describe` "kexec configured"-	, check (not <$> runningInstalledKernel)-		(cmdProperty "reboot" [])-			`describe` "running installed kernel"+	, check (not <$> runningInstalledKernel) Reboot.now+		`describe` "running installed kernel" 	]  runningInstalledKernel :: IO Bool

@@ -0,0 +1,23 @@+module Propellor.Property.Mount where++import Propellor+import Utility.SafeCommand++type FsType = String+type Source = String++mountPoints :: IO [FilePath]+mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]++getFsType :: FilePath -> IO (Maybe FsType)+getFsType mnt = catchDefaultIO Nothing $+	headMaybe . lines+		<$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]++umountLazy :: FilePath -> IO ()+umountLazy mnt =  +	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $+		errorMessage $ "failed unmounting " ++ mnt++mount :: FsType -> Source -> FilePath -> IO Bool+mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]

@@ -0,0 +1,232 @@+module Propellor.Property.OS (+	cleanInstallOnce,+	Confirmation(..),+	preserveNetwork,+	preserveResolvConf,+	preserveRootSshAuthorized,+	oldOSRemoved,+) where++import Propellor+import qualified Propellor.Property.Debootstrap as Debootstrap+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.User as User+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Reboot as Reboot+import Propellor.Property.Mount+import Propellor.Property.Chroot.Util (stdPATH)+import Utility.SafeCommand++import System.Posix.Files (rename, fileExist)+import Control.Exception (throw)++-- | Replaces whatever OS was installed before with a clean installation+-- of the OS that the Host is configured to have.+-- +-- This is experimental; use with caution!+--+-- This can replace one Linux distribution with different one.+-- But, it can also fail and leave the system in an unbootable state.+--+-- To avoid this property being accidentially used, you have to provide+-- a Confirmation containing the name of the host that you intend to apply+-- the property to.+--+-- This property only runs once. The cleanly installed system will have+-- a file /etc/propellor-cleaninstall, which indicates it was cleanly+-- installed.+-- +-- The files from the old os will be left in /old-os+--+-- After the OS is installed, and if all properties of the host have+-- been successfully satisfied, the host will be rebooted to properly load+-- the new OS.+--+-- You will typically want to run some more properties after the clean+-- install succeeds, to bootstrap from the cleanly installed system to+-- a fully working system. For example:+--+-- > & os (System (Debian Unstable) "amd64")+-- > & cleanInstallOnce (Confirmed "foo.example.com")+-- >    `onChange` propertyList "fixing up after clean install"+-- >        [ preserveNetwork+-- >        , preserveResolvConf+-- >        , preserverRootSshAuthorized+-- >        , Apt.update+-- >        -- , Grub.boots "/dev/sda"+-- >        --   `requires` Grub.installed Grub.PC+-- >        -- , oldOsRemoved (Confirmed "foo.example.com")+-- >        ]+-- > & Hostname.sane+-- > & Apt.installed ["linux-image-amd64"]+-- > & Apt.installed ["ssh"]+-- > & User.hasSomePassword "root"+-- > & User.accountFor "joey"+-- > & User.hasSomePassword "joey"+-- > -- rest of system properties here+cleanInstallOnce :: Confirmation -> Property+cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $+	go `requires` confirmed "clean install confirmed" confirmation+  where+	go = +		finalized+			`requires`+		-- easy to forget and system may not boot without shadow pw!+		User.shadowConfig True+			`requires`+		-- reboot at end if the rest of the propellor run succeeds+		Reboot.atEnd True (/= FailedChange)+			`requires`+		propellorbootstrapped+			`requires`+		flipped+			`requires`+		osbootstrapped++	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of+		(Just d@(System (Debian _) _)) -> debootstrap d+		(Just u@(System (Ubuntu _) _)) -> debootstrap u+		_ -> error "os is not declared to be Debian or Ubuntu"+	+	debootstrap targetos = ensureProperty $ toProp $+		-- Ignore the os setting, and install debootstrap from+		-- source, since we don't know what OS we're running in yet.+		Debootstrap.built' Debootstrap.sourceInstall+			newOSDir targetos Debootstrap.DefaultConfig+		-- debootstrap, I wish it was faster.. +		-- TODO eatmydata to speed it up+		-- Problem: Installing eatmydata on some random OS like+		-- Fedora may be difficult. Maybe configure dpkg to not+		-- sync instead?++	-- This is the fun bit.+	flipped = property (newOSDir ++ " moved into place") $ liftIO $ do+		-- First, unmount most mount points, lazily, so+		-- they don't interfere with moving things around.+		devfstype <- fromMaybe "devtmpfs" <$> getFsType "/dev"+		mnts <- filter (`notElem` ("/": trickydirs)) <$> mountPoints+		-- reverse so that deeper mount points come first+		forM_ (reverse mnts) umountLazy++		renamesout <- map (\d -> (d, oldOSDir ++ d, pure $ d `notElem` (oldOSDir:newOSDir:trickydirs)))+			<$> dirContents "/"+		renamesin <- map (\d -> let dest = "/" ++ takeFileName d in (d, dest, not <$> fileExist dest))+			<$> dirContents newOSDir+		createDirectoryIfMissing True oldOSDir+		massRename (renamesout ++ renamesin)+		removeDirectoryRecursive newOSDir+		+		-- Prepare environment for running additional properties,+		-- overriding old OS's environment.+		void $ setEnv "PATH" stdPATH True+		void $ unsetEnv "LANG"++		-- Remount /dev, so that block devices etc are+		-- available for other properties to use.+		unlessM (mount devfstype devfstype "/dev") $ do+			warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic"+			void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"]++		-- Mount /sys too, needed by eg, grub-mkconfig.+		unlessM (mount "sysfs" "sysfs" "/sys") $+			warningMessage "failed mounting /sys"++		-- And /dev/pts, used by apt.+		unlessM (mount "devpts" "devpts" "/dev/pts") $+			warningMessage "failed mounting /dev/pts"++		return MadeChange++	propellorbootstrapped = property "propellor re-debootstrapped in new os" $+		return NoChange+		-- re-bootstrap propellor in /usr/local/propellor,+		--   (using git repo bundle, privdata file, and possibly+		--   git repo url, which all need to be arranged to+		--   be present in /old-os's /usr/local/propellor)+		-- TODO+	+	finalized = property "clean OS installed" $ do+		liftIO $ writeFile flagfile ""+		return MadeChange++	flagfile = "/etc/propellor-cleaninstall"+	+	trickydirs = +		-- /tmp can contain X's sockets, which prevent moving it+		-- so it's left as-is.+		[ "/tmp"+		-- /proc is left mounted+		, "/proc"+		]++-- Performs all the renames. If any rename fails, rolls back all+-- previous renames. Thus, this either successfully performs all+-- the renames, or does not change the system state at all.+massRename :: [(FilePath, FilePath, IO Bool)] -> IO ()+massRename = go []+  where+	go _ [] = return ()+	go undo ((from, to, test):rest) = ifM test+		( tryNonAsync (rename from to)+			>>= either+				(rollback undo)+				(const $ go ((to, from):undo) rest)+		, go undo rest+		)+	rollback undo e = do+		mapM_ (uncurry rename) undo+		throw e++data Confirmation = Confirmed HostName++confirmed :: Desc -> Confirmation -> Property+confirmed desc (Confirmed c) = property desc $ do+	hostname <- asks hostName+	if hostname /= c+		then do+			warningMessage "Run with a bad confirmation, not matching hostname."+			return FailedChange+		else return NoChange++-- | /etc/network/interfaces is configured to bring up the network +-- interface that currently has a default route configured, using+-- the same (static) IP address.+preserveNetwork :: Property+preserveNetwork = undefined -- TODO++-- | /etc/resolv.conf is copied the from the old OS+preserveResolvConf :: Property+preserveResolvConf = check (fileExist oldloc) $+	property (newloc ++ " copied from old OS") $ do+		ls <- liftIO $ lines <$> readFile oldloc+		ensureProperty $ newloc `File.hasContent` ls+  where+	newloc = "/etc/resolv.conf"+	oldloc = oldOSDir ++ newloc++-- | Root's .ssh/authorized_keys has added to it any ssh keys that+-- were authorized in the old OS. Any other contents of the file are+-- retained.+preserveRootSshAuthorized :: Property+preserveRootSshAuthorized = check (fileExist oldloc) $+	property (newloc ++ " copied from old OS") $ do+		ks <- liftIO $ lines <$> readFile oldloc+		ensureProperties (map (Ssh.authorizedKey "root") ks)+  where+	newloc = "/root/.ssh/authorized_keys"+	oldloc = oldOSDir ++ newloc++-- Removes the old OS's backup from /old-os+oldOSRemoved :: Confirmation -> Property+oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $+	go `requires` confirmed "old OS backup removal confirmed" confirmation+  where+	go = property "old OS backup removed" $ do+		liftIO $ removeDirectoryRecursive oldOSDir+		return MadeChange++oldOSDir :: FilePath+oldOSDir = "/old-os"++newOSDir :: FilePath+newOSDir = "/new-os"

@@ -23,7 +23,7 @@ 			"define('SIMPLEID_BASE_URL', '"++url++"');" 		| otherwise = l 	-	-- the identitites directory controls access, so open up+	-- the identities directory controls access, so open up 	-- file mode 	identfile u = File.hasPrivContentExposed 		(concat [ "/var/lib/simpleid/identities/", u, ".identity" ])

@@ -1,7 +1,30 @@ module Propellor.Property.Reboot where  import Propellor+import Utility.SafeCommand  now :: Property now = cmdProperty "reboot" [] 	`describe` "reboot now"++-- | Schedules a reboot at the end of the current propellor run.+--+-- The Result code of the endire propellor run can be checked;+-- the reboot proceeds only if the function returns True.+--+-- The reboot can be forced to run, which bypasses the init system. Useful+-- if the init system might not be running for some reason.+atEnd :: Bool -> (Result -> Bool) -> Property+atEnd force resultok = property "scheduled reboot at end of propellor run" $ do+	endAction "rebooting" atend+	return NoChange+  where+	atend r+		| resultok r = liftIO $ toResult+			<$> boolSystem "reboot" rebootparams+		| otherwise = do+			warningMessage "Not rebooting, due to status of propellor run."+			return FailedChange+	rebootparams+		| force = [Param "--force"]+		| otherwise = []

@@ -13,19 +13,16 @@ -- we can do is try to start the service, and if it fails, assume -- this means it's already running. running :: ServiceName -> Property-running svc = property ("running " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]-	return NoChange+running = signaled "start" "running"  restarted :: ServiceName -> Property-restarted svc = property ("restarted " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]-	return NoChange+restarted = signaled "restart" "restarted"  reloaded :: ServiceName -> Property-reloaded svc = property ("reloaded " ++ svc) $ do+reloaded = signaled "reload" "reloaded"++signaled :: String -> Desc -> ServiceName -> Property+signaled cmd desc svc = property (desc ++ " " ++ svc) $ do 	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]+		scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] 	return NoChange

@@ -76,7 +76,7 @@ 	"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", 	"liblockfile-simple-perl", "cabal-install", "vim", "less", 	-- needed by haskell libs-	"libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls-dev",+	"libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls28-dev", 	"alex", "happy", "c2hs" 	] 

@@ -3,6 +3,7 @@ 	permitRootLogin, 	passwordAuthentication, 	hasAuthorizedKeys,+	authorizedKey, 	restarted, 	randomHostKeys, 	hostKeys,@@ -79,7 +80,7 @@ 			[ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]  -- | Sets all types of ssh host keys from the privdata.-hostKeys :: Context -> Property+hostKeys :: IsContext c => c -> Property hostKeys ctx = propertyList "known ssh host keys" 	[ hostKey SshDsa ctx 	, hostKey SshRsa ctx@@ -87,7 +88,7 @@ 	]  -- | Sets a single ssh host key from the privdata.-hostKey :: SshKeyType -> Context -> Property+hostKey :: IsContext c => SshKeyType -> c -> Property hostKey keytype context = combineProperties desc 	[ installkey (SshPubKey keytype "")  (install writeFile ".pub") 	, installkey (SshPrivKey keytype "") (install writeFileProtected "")@@ -106,7 +107,7 @@  -- | Sets up a user with a ssh private key and public key pair from the -- PrivData.-keyImported :: SshKeyType -> UserName -> Context -> Property+keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property keyImported keytype user context = combineProperties desc 	[ installkey (SshPubKey keytype user) (install writeFile ".pub") 	, installkey (SshPrivKey keytype user) (install writeFileProtected "")@@ -155,7 +156,9 @@ 		return FailedChange  -- | Makes a user have authorized_keys from the PrivData-authorizedKeys :: UserName -> Context -> Property+--+-- This removes any other lines from the file.+authorizedKeys :: IsContext c => UserName -> c -> Property authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> 	property (user ++ " has authorized_keys") $ get $ \v -> do 		f <- liftIO $ dotFile "authorized_keys" user@@ -166,6 +169,16 @@ 			[ File.ownerGroup f user user 			, File.ownerGroup (takeDirectory f) user user 			] ++-- | Ensures that a user's authorized_keys contains a line.+-- Any other lines in the file are preserved as-is.+authorizedKey :: UserName -> String -> Property+authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do+	f <- liftIO $ dotFile "authorized_keys" user+	ensureProperty $+		f `File.containsLine` l+			`requires` File.dirExists (takeDirectory f)+			`onChange` File.mode f (combineModes [ownerWriteMode, ownerReadMode])  -- | Makes the ssh server listen on a given port, in addition to any other -- ports it is configured to listen on.

@@ -151,9 +151,8 @@ 		<$> servicefilecontent 		<*> catchDefaultIO "" (readFile servicefile) -	writeservicefile = property servicefile $ liftIO $ do+	writeservicefile = property servicefile $ makeChange $ 		viaTmp writeFile servicefile =<< servicefilecontent-		return MadeChange  	setupservicefile = check (not <$> goodservicefile) $ 		-- if it's running, it has the wrong configuration,

@@ -44,7 +44,7 @@ 	`describe` unwords ["hidden service available:", hn, show port] 	`onChange` restarted -hiddenServiceData :: HiddenServiceName -> Context -> Property+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property hiddenServiceData hn context = combineProperties desc 	[ installonion "hostname" 	, installonion "private_key"

@@ -24,19 +24,34 @@  -- | Only ensures that the user has some password set. It may or may -- not be the password from the PrivData.-hasSomePassword :: UserName -> Context -> Property-hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus user) $-	hasPassword user context+hasSomePassword :: UserName -> Property+hasSomePassword user = hasSomePassword' user hostContext -hasPassword :: UserName -> Context -> Property-hasPassword user context = withPrivData (Password user) context $ \getpassword ->-	property (user ++ " has password") $ -		getpassword $ \password -> makeChange $-			withHandle StdinHandle createProcessSuccess-				(proc "chpasswd" []) $ \h -> do-					hPutStrLn h $ user ++ ":" ++ password-					hClose h+-- | While hasSomePassword uses the name of the host as context,+-- this allows specifying a different context. This is useful when+-- you want to use the same password on multiple hosts, for example.+hasSomePassword' :: IsContext c => UserName -> c -> Property+hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $+	hasPassword' user context +-- | Ensures that a user's password is set to the password from the PrivData.+-- (Will change any existing password.)+hasPassword :: UserName -> Property+hasPassword user = hasPassword' user hostContext++hasPassword' :: IsContext c => UserName -> c -> Property+hasPassword' user context = go `requires` shadowConfig True+  where+	go = withPrivData (Password user) context $+		property (user ++ " has password") . setPassword user++setPassword :: UserName -> ((PrivData -> Propellor Result) -> Propellor Result) -> Propellor Result+setPassword user getpassword = getpassword $ \password -> makeChange $+	withHandle StdinHandle createProcessSuccess+		(proc "chpasswd" []) $ \h -> do+			hPutStrLn h $ user ++ ":" ++ password+			hClose h+ lockedPassword :: UserName -> Property lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" 	[ "--lock"@@ -60,3 +75,24 @@  homedir :: UserName -> IO FilePath homedir user = homeDirectory <$> getUserEntryForName user++hasGroup :: UserName -> GroupName -> Property+hasGroup user group' = check test $ cmdProperty "adduser"+	[ user+	, group'+	]+	`describe` unwords ["user", user, "in group", group']+  where+	test = not . elem group' . words <$> readProcess "groups" [user]++-- | Controls whether shadow passwords are enabled or not.+shadowConfig :: Bool -> Property+shadowConfig True = check (not <$> shadowExists) $+	cmdProperty "shadowconfig" ["on"]+		`describe` "shadow passwords enabled"+shadowConfig False = check shadowExists $+	cmdProperty "shadowconfig" ["off"]+		`describe` "shadow passwords disabled"++shadowExists :: IO Bool+shadowExists = doesFileExist "/etc/shadow"

@@ -13,7 +13,7 @@  import Propellor -data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush+data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled 	deriving (Read, Show, Eq)  type Marker = String

@@ -1,139 +0,0 @@-module Propellor.Server (-	update,-	updateServer,-	gitPushHelper-) where--import Data.List-import System.Exit-import System.PosixCompat-import System.Posix.IO-import Control.Concurrent.Async-import qualified Data.ByteString as B--import Propellor-import Propellor.Protocol-import Propellor.PrivData.Paths-import Propellor.Git-import Propellor.Ssh-import Utility.FileMode-import Utility.SafeCommand---- Update the privdata, repo url, and git repo over the ssh--- connection, talking to the user's local propellor instance which is--- running the updateServer-update :: IO ()-update = do-	req NeedRepoUrl repoUrlMarker setRepoUrl-	makePrivDataDir-	req NeedPrivData privDataMarker $-		writeFileProtected privDataLocal-	req NeedGitPush gitPushMarker $ \_ -> do-		hin <- dup stdInput-		hout <- dup stdOutput-		hClose stdin-		hClose stdout-		unlessM (boolSystem "git" (pullparams hin hout)) $-			errorMessage "git pull from client failed"-  where-	pullparams hin hout =-		[ Param "pull"-		, Param "--progress"-		, Param "--upload-pack"-		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout-		, Param "."-		]---- The connect action should ssh to the remote host and run the provided--- calback action.-updateServer :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()-updateServer hn hst connect = connect go-  where-	go (toh, fromh) = do-		let loop = go (toh, fromh)-		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)-		case v of-			(Just NeedRepoUrl) -> do-				sendRepoUrl toh-				loop-			(Just NeedPrivData) -> do-				sendPrivData hn hst toh-				loop-			(Just NeedGitPush) -> do-				sendGitUpdate hn fromh toh-				-- no more protocol possible after git push-				hClose fromh-				hClose toh-			(Just NeedGitClone) -> do-				hClose toh-				hClose fromh-				sendGitClone hn-				updateServer hn hst connect-			Nothing -> return ()--sendRepoUrl :: Handle -> IO ()-sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)--sendPrivData :: HostName -> Host -> Handle -> IO ()-sendPrivData hn hst toh = do-	privdata <- show . filterPrivData hst <$> decryptPrivData-	void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do-		sendMarked toh privDataMarker privdata-		return True--sendGitUpdate :: HostName -> Handle -> Handle -> IO ()-sendGitUpdate hn fromh toh =-	void $ actionMessage ("Sending git update to " ++ hn) $ do-		sendMarked toh gitPushMarker ""-		(Nothing, Nothing, Nothing, h) <- createProcess p-		(==) ExitSuccess <$> waitForProcess h-  where-	p = (proc "git" ["upload-pack", "."])-		{ std_in = UseHandle fromh-		, std_out = UseHandle toh-		}---- Initial git clone, used for bootstrapping.-sendGitClone :: HostName -> IO ()-sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do-	branch <- getCurrentBranch-	cacheparams <- sshCachingParams hn-	withTmpFile "propellor.git" $ \tmp _ -> allM id-		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]-		]-  where-	remotebundle = "/usr/local/propellor.git"-	unpackcmd branch = shellWrap $ intercalate " && "-		[ "git clone " ++ remotebundle ++ " " ++ localdir-		, "cd " ++ localdir-		, "git checkout -b " ++ branch-		, "git remote rm origin"-		, "rm -f " ++ remotebundle-		]---- Shim for git push over the propellor ssh channel.--- Reads from stdin and sends it to hout;--- reads from hin and sends it to stdout.-gitPushHelper :: Fd -> Fd -> IO ()-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout-  where-	fromstdin = do-		h <- fdToHandle hout-		connect stdin h-	tostdout = do-		h <- fdToHandle hin-		connect h stdout-	connect fromh toh = do-		hSetBinaryMode fromh True-		hSetBinaryMode toh True-		b <- B.hGetSome fromh 40960-		if B.null b-			then do-				hClose fromh-				hClose toh-			else do-				B.hPut toh b-				hFlush toh-				connect fromh toh

@@ -11,14 +11,18 @@ import Utility.SafeCommand import Utility.Path import Utility.FileMode+import Utility.FileSystemEncoding  import Data.List import System.Posix.Files  -- | Sets up a shimmed version of the program, in a directory, and -- returns its path.-setup :: FilePath -> FilePath -> IO FilePath-setup propellorbin dest = do+--+-- Propellor may be running from an existing shim, in which case it's+-- simply reused.+setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath+setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do 	createDirectoryIfMissing True dest  	libs <- parseLdd <$> readProcess "ldd" [propellorbin]@@ -36,15 +40,28 @@ 	let linkerparams = ["--library-path", intercalate ":" libdirs ] 	let shim = file propellorbin dest 	writeFile shim $ unlines-		[ "#!/bin/sh"+		[ shebang 		, "GCONV_PATH=" ++ shellEscape gconvdir 		, "export GCONV_PATH" 		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ -			" " ++ shellEscape propellorbin ++ " \"$@\""+			" " ++ shellEscape (fromMaybe propellorbin propellorbinpath) ++ " \"$@\"" 		] 	modifyFileMode shim (addModes executeModes) 	return shim +shebang :: String+shebang = "#!/bin/sh"++checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath+checkAlreadyShimmed f nope = withFile f ReadMode $ \h -> do+	fileEncoding h+	s <- hGetLine h+	if s == shebang+		then return f+		else nope++-- Called when the shimmed propellor is running, so that commands it runs+-- don't see it. cleanEnv :: IO () cleanEnv = void $ unsetEnv "GCONV_PATH" 

@@ -0,0 +1,299 @@+module Propellor.Spin (+	commitSpin,+	spin,+	update,+	gitPushHelper,+	mergeSpin,+) where++import Data.List+import System.Exit+import System.PosixCompat+import System.Posix.IO+import System.Posix.Directory+import Control.Concurrent.Async+import Control.Exception (bracket)+import qualified Data.ByteString as B++import Propellor+import Propellor.Protocol+import Propellor.PrivData.Paths+import Propellor.Git+import Propellor.Ssh+import Propellor.Gpg+import qualified Propellor.Shim as Shim+import Utility.FileMode+import Utility.SafeCommand++commitSpin :: IO ()+commitSpin = do+	void $ actionMessage "Git commit" $+		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param spinCommitMessage]+	-- Push to central origin repo first, if possible.+	-- The remote propellor will pull from there, which avoids+	-- us needing to send stuff directly to the remote host.+	whenM hasOrigin $+		void $ actionMessage "Push to central git repository" $+			boolSystem "git" [Param "push"]++spin :: HostName -> Maybe HostName -> Host -> IO ()+spin target relay hst = do+	cacheparams <- if viarelay+		then pure ["-A"]+		else toCommand <$> sshCachingParams hn+	when viarelay $+		void $ boolSystem "ssh-add" []++	-- Install, or update the remote propellor.+	updateServer target relay hst+		(proc "ssh" $ cacheparams ++ [user, shellWrap probecmd])+		(proc "ssh" $ cacheparams ++ [user, shellWrap updatecmd])++	-- And now we can run it.+	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, shellWrap runcmd])) $+		error $ "remote propellor failed"+  where+	hn = fromMaybe target relay+	user = "root@"++hn++	relaying = relay == Just target+	viarelay = isJust relay && not relaying++	probecmd = intercalate " ; "+		[ "if [ ! -d " ++ localdir ++ "/.git ]"+		, "then (" ++ intercalate " && "+			[ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi"+			, "echo " ++ toMarked statusMarker (show NeedGitClone)+			] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)+		, "else " ++ updatecmd+		, "fi"+		]+	+	updatecmd = intercalate " && "+		[ "cd " ++ localdir+		, "if ! test -x ./propellor; then make deps build; fi"+		, if viarelay+			then "./propellor --continue " +++				shellEscape (show (Update (Just target)))+			-- Still using --boot for back-compat...+			else "./propellor --boot " ++ target+		]++	runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd+	cmd = if viarelay+		then "--serialized " ++ shellEscape (show (Spin [target] (Just target)))+		else "--continue " ++ shellEscape (show (SimpleRun target))++-- Update the privdata, repo url, and git repo over the ssh+-- connection, talking to the user's local propellor instance which is+-- running the updateServer+update :: Maybe HostName -> IO ()+update forhost = do+	whenM hasGitRepo $+		req NeedRepoUrl repoUrlMarker setRepoUrl++	makePrivDataDir+	createDirectoryIfMissing True (takeDirectory privfile)+	req NeedPrivData privDataMarker $+		writeFileProtected privfile++	whenM hasGitRepo $+		req NeedGitPush gitPushMarker $ \_ -> do+			hin <- dup stdInput+			hout <- dup stdOutput+			hClose stdin+			hClose stdout+			unlessM (boolSystem "git" (pullparams hin hout)) $+				errorMessage "git pull from client failed"+  where+	pullparams hin hout =+		[ Param "pull"+		, Param "--progress"+		, Param "--upload-pack"+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout+		, Param "."+		]+	+	-- When --spin --relay is run, get a privdata file+	-- to be relayed to the target host.+	privfile = maybe privDataLocal privDataRelay forhost++updateServer+	:: HostName+	-> Maybe HostName+	-> Host+	-> CreateProcess+	-> CreateProcess+	-> IO ()+updateServer target relay hst connect haveprecompiled =+	withBothHandles createProcessSuccess connect go+  where+	hn = fromMaybe target relay+	relaying = relay == Just target++	go (toh, fromh) = do+		let loop = go (toh, fromh)+		let restart = updateServer hn relay hst connect haveprecompiled+		let done = return ()+		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)+		case v of+			(Just NeedRepoUrl) -> do+				sendRepoUrl toh+				loop+			(Just NeedPrivData) -> do+				sendPrivData hn hst toh relaying+				loop+			(Just NeedGitClone) -> do+				hClose toh+				hClose fromh+				sendGitClone hn+				restart+			(Just NeedPrecompiled) -> do+				hClose toh+				hClose fromh+				sendPrecompiled hn+				updateServer hn relay 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+		| relaying = do+			let f = privDataRelay hn+			d <- readFileStrictAnyEncoding f+			nukeFile f+			return d+		| otherwise = show . filterPrivData hst <$> decryptPrivData++sendGitUpdate :: HostName -> Handle -> Handle -> IO ()+sendGitUpdate hn fromh toh =+	void $ actionMessage ("Sending git update to " ++ hn) $ do+		sendMarked toh gitPushMarker ""+		(Nothing, Nothing, Nothing, h) <- createProcess p+		(==) ExitSuccess <$> waitForProcess h+  where+	p = (proc "git" ["upload-pack", "."])+		{ std_in = UseHandle fromh+		, std_out = UseHandle toh+		}++-- Initial git clone, used for bootstrapping.+sendGitClone :: HostName -> IO ()+sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do+	branch <- getCurrentBranch+	cacheparams <- sshCachingParams hn+	withTmpFile "propellor.git" $ \tmp _ -> allM id+		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]+		]+  where+	remotebundle = "/usr/local/propellor.git"+	unpackcmd branch = shellWrap $ intercalate " && "+		[ "git clone " ++ remotebundle ++ " " ++ localdir+		, "cd " ++ localdir+		, "git checkout -b " ++ branch+		, "git remote rm origin"+		, "rm -f " ++ remotebundle+		]++-- Send a tarball containing the precompiled propellor, and libraries.+-- This should be reasonably portable, as long as the remote host has the+-- same architecture as the build host.+sendPrecompiled :: HostName -> IO ()+sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do+	bracket getWorkingDirectory changeWorkingDirectory $ \_ ->+		withTmpDir "propellor" go+  where+	go tmpdir = do+		cacheparams <- sshCachingParams hn+		let shimdir = takeFileName localdir+		createDirectoryIfMissing True (tmpdir </> shimdir)+		changeWorkingDirectory (tmpdir </> shimdir)+		me <- readSymbolicLink "/proc/self/exe"+		createDirectoryIfMissing True "bin"+		unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $+			errorMessage "failed copying in propellor"+		let bin = "bin/propellor"+		let binpath = Just $ localdir </> bin+		void $ Shim.setup bin binpath "."+		changeWorkingDirectory tmpdir+		withTmpFile "propellor.tar." $ \tarball _ -> allM id+			[ boolSystem "strip" [File me]+			, boolSystem "tar" [Param "czf", File tarball, File shimdir]+			, boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]+			, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]+			]++	remotetarball = "/usr/local/propellor.tar"++	unpackcmd = shellWrap $ intercalate " && "+		[ "cd " ++ takeDirectory remotetarball+		, "tar xzf " ++ remotetarball+		, "rm -f " ++ remotetarball+		]++-- Shim for git push over the propellor ssh channel.+-- Reads from stdin and sends it to hout;+-- reads from hin and sends it to stdout.+gitPushHelper :: Fd -> Fd -> IO ()+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout+  where+	fromstdin = do+		h <- fdToHandle hout+		connect stdin h+	tostdout = do+		h <- fdToHandle hin+		connect h stdout+	connect fromh toh = do+		hSetBinaryMode fromh True+		hSetBinaryMode toh True+		b <- B.hGetSome fromh 40960+		if B.null b+			then do+				hClose fromh+				hClose toh+			else do+				B.hPut toh b+				hFlush toh+				connect fromh toh++mergeSpin :: IO ()+mergeSpin = do+	branch <- getCurrentBranch+	branchref <- getCurrentBranchRef+	old_head <- getCurrentGitSha1 branch+	old_commit <- findLastNonSpinCommit+	rungit "reset" [Param old_commit]+	rungit "commit" [Param "-a", Param "--allow-empty"]+	rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head]+	current_commit <- getCurrentGitSha1 branch+	rungit "update-ref" [Param branchref, Param current_commit]+	rungit "checkout" [Param branch]+  where+	rungit cmd ps = unlessM (boolSystem "git" (Param cmd:ps)) $+		error ("git " ++ cmd ++ " failed")++findLastNonSpinCommit :: IO String+findLastNonSpinCommit = do+	commits <- map (separate (== ' ')) . lines+		<$> readProcess "git" ["log", "--oneline", "--no-abbrev-commit"]+	case dropWhile (\(_, msg) -> msg == spinCommitMessage) commits of+		((sha, _):_) -> return sha+		_ -> error $ "Did not find any previous commit that was not a " ++ show spinCommitMessage++spinCommitMessage :: String+spinCommitMessage = "propellor spin"

@@ -20,8 +20,9 @@ 	let cachedir = home </> ".ssh" </> "propellor" 	createDirectoryIfMissing False cachedir 	let socketfile = cachedir </> hn ++ ".sock"-	let ps = -		[ Param "-o", Param ("ControlPath=" ++ socketfile)+	let ps =+		[ Param "-o"+		, Param ("ControlPath=" ++ socketfile) 		, Params "-o ControlMaster=auto -o ControlPersist=yes" 		] 

@@ -14,6 +14,7 @@ 	, requires 	, Desc 	, Result(..)+	, ToResult(..) 	, ActionResult(..) 	, CmdLine(..) 	, PrivDataField(..)@@ -23,6 +24,8 @@ 	, SshKeyType(..) 	, Val(..) 	, fromVal+	, RunLog+	, EndAction(..) 	, module Propellor.Types.OS 	, module Propellor.Types.Dns 	) where@@ -31,7 +34,7 @@ import Control.Applicative import System.Console.ANSI import System.Posix.Types-import "mtl" Control.Monad.Reader+import "mtl" Control.Monad.RWS.Strict import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.Set as S import qualified Propellor.Types.Dns as Dns@@ -41,6 +44,7 @@ import Propellor.Types.Dns import Propellor.Types.Docker import Propellor.Types.PrivData+import Propellor.Types.Empty  -- | Everything Propellor knows about a system: Its hostname, -- properties and other info.@@ -52,13 +56,14 @@ 	deriving (Show)  -- | Propellor's monad provides read-only access to info about the host--- it's running on.-newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p }+-- it's running on, and a writer to accumulate logs about the run.+newtype Propellor p = Propellor { runWithHost :: RWST Host RunLog () IO p } 	deriving 		( Monad 		, Functor 		, Applicative 		, MonadReader Host+		, MonadWriter RunLog 		, MonadIO 		, MonadCatchIO 		)@@ -127,6 +132,13 @@ 	mappend _ MadeChange = MadeChange 	mappend NoChange NoChange = NoChange +class ToResult t where+	toResult :: t -> Result++instance ToResult Bool where+	toResult False = FailedChange+	toResult True = MadeChange+ -- | Results of actions, with color. class ActionResult a where 	getActionResult :: a -> (String, ColorIntensity, Color)@@ -142,15 +154,17 @@  data CmdLine 	= Run HostName-	| Spin HostName+	| Spin [HostName] (Maybe HostName) 	| SimpleRun HostName 	| Set PrivDataField Context 	| Dump PrivDataField Context 	| Edit PrivDataField Context 	| ListFields 	| AddKey String+	| Merge+	| Serialized CmdLine 	| Continue CmdLine-	| Update HostName+	| Update (Maybe HostName) 	| DockerInit HostName 	| DockerChain HostName String 	| ChrootChain HostName FilePath Bool Bool@@ -160,7 +174,7 @@ -- | Information about a host. data Info = Info 	{ _os :: Val System-	, _privDataFields :: S.Set (PrivDataField, Context)+	, _privDataFields :: S.Set (PrivDataField, HostContext) 	, _sshPubKey :: Val String 	, _aliases :: S.Set HostName 	, _dns :: S.Set Dns.Record@@ -183,6 +197,18 @@ 		, _chrootinfo = _chrootinfo old <> _chrootinfo new 		} +instance Empty Info where+	isEmpty i = and+		[ isEmpty (_os i)+		, isEmpty (_privDataFields i)+		, isEmpty (_sshPubKey i)+		, isEmpty (_aliases i)+		, isEmpty (_dns i)+		, isEmpty (_namedconf i)+		, isEmpty (_dockerinfo i)+		, isEmpty (_chrootinfo i)+		]+ data Val a = Val a | NoVal 	deriving (Eq, Show) @@ -192,6 +218,16 @@ 		NoVal -> old 		_ -> new +instance Empty (Val a) where+	isEmpty NoVal = True+	isEmpty _ = False+ fromVal :: Val a -> Maybe a fromVal (Val a) = Just a fromVal NoVal = Nothing++type RunLog = [EndAction]++-- | An action that Propellor runs at the end, after trying to satisfy all+-- properties. It's passed the combined Result of the entire Propellor run.+data EndAction = EndAction Desc (Result -> Propellor Result)

@@ -2,6 +2,7 @@  import Data.Monoid import qualified Data.Map as M+import Propellor.Types.Empty  data ChrootInfo host = ChrootInfo 	{ _chroots :: M.Map FilePath host@@ -16,10 +17,16 @@ 		, _chrootCfg = _chrootCfg old <> _chrootCfg new 		} +instance Empty (ChrootInfo host) where+	isEmpty i = and+		[ isEmpty (_chroots i)+		, isEmpty (_chrootCfg i)+		]+ data ChrootCfg 	= NoChrootCfg 	| SystemdNspawnCfg [(String, Bool)]-	deriving (Show)+	deriving (Show, Eq)  instance Monoid ChrootCfg where 	mempty = NoChrootCfg@@ -27,3 +34,6 @@ 	mappend NoChrootCfg v = v 	mappend (SystemdNspawnCfg l1) (SystemdNspawnCfg l2) = 		SystemdNspawnCfg (l1 <> l2)++instance Empty ChrootCfg where+	isEmpty c= c == NoChrootCfg

@@ -1,6 +1,7 @@ module Propellor.Types.Dns where  import Propellor.Types.OS (HostName)+import Propellor.Types.Empty  import Data.Word import Data.Monoid@@ -107,6 +108,9 @@ 		combiner n o = case (confDnsServerType n, confDnsServerType o) of 			(Secondary, Master) -> o 			_  -> n++instance Empty NamedConfMap where+	isEmpty (NamedConfMap m) = isEmpty m  fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf fromNamedConfMap (NamedConfMap m) = m

@@ -1,6 +1,7 @@ module Propellor.Types.Docker where  import Propellor.Types.OS+import Propellor.Types.Empty  import Data.Monoid import qualified Data.Map as M@@ -17,6 +18,12 @@ 		{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new 		, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) 		}++instance Empty (DockerInfo h) where+	isEmpty i = and+		[ isEmpty (_dockerRunParams i)+		, isEmpty (_dockerContainers i)+		]  newtype DockerRunParam = DockerRunParam (HostName -> String) 

@@ -0,0 +1,16 @@+module Propellor.Types.Empty where++import qualified Data.Map as M+import qualified Data.Set as S++class Empty t where+	isEmpty :: t -> Bool++instance Empty [a] where+	isEmpty = null++instance Empty (M.Map k v) where+	isEmpty = M.null++instance Empty (S.Set v) where+	isEmpty = S.null

@@ -1,10 +1,21 @@-module Propellor.Types.OS where+module Propellor.Types.OS (+	HostName,+	UserName,+	GroupName,+	System(..),+	Distribution(..),+	DebianSuite(..),+	isStable,+	Release,+	Architecture,+) where -type HostName = String+import Network.BSD (HostName)+ type UserName = String type GroupName = String --- | High level descritption of a operating system.+-- | High level description of a operating system. data System = System Distribution Architecture 	deriving (Show, Eq) 

@@ -15,18 +15,49 @@ 	| GpgKey 	deriving (Read, Show, Ord, Eq) --- | Context in which a PrivDataField is used.+-- | A context in which a PrivDataField is used. -- -- Often this will be a domain name. For example,  -- Context "www.example.com" could be used for the SSL cert -- for the web server serving that domain. Multiple hosts might -- use that privdata.+--+-- This appears in serlialized privdata files. newtype Context = Context String 	deriving (Read, Show, Ord, Eq) +-- | A context that varies depending on the HostName where it's used.+newtype HostContext = HostContext { mkHostContext :: HostName -> Context }++instance Show HostContext where+	show hc = show $ mkHostContext hc "<hostname>"++instance Ord HostContext where+	a <= b = show a <= show b++instance Eq HostContext where+	a == b = show a == show b++-- | Class of things that can be used as a Context.+class IsContext c where+	asContext :: HostName -> c -> Context+	asHostContext :: c -> HostContext++instance IsContext HostContext where+	asContext = flip mkHostContext+	asHostContext = id++instance IsContext Context where+	asContext _ c = c+	asHostContext = HostContext . const+ -- | Use when a PrivDataField is not dependent on any paricular context. anyContext :: Context anyContext = Context "any"++-- | Makes a HostContext that consists just of the hostname.+hostContext :: HostContext+hostContext = HostContext Context  type PrivData = String 

@@ -1,6 +1,6 @@ {- applicative stuff  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- utilities for simple data types  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- directory manipulation  -- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- portable environment variables  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- File mode utilities.  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- misc utility functions  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- monadic stuff  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- path manipulation  -- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -2,7 +2,7 @@  -  - This is like System.PosixCompat.Files, except with a fixed rename.  -- - Copyright 2014 Joey Hess <joey@kitenet.net>+ - Copyright 2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running  - processes, and logging.  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- QuickCheck with additional instances  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- safely running shell commands  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- scheduled activities  - - - Copyright 2013-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2013-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- text based table generation  -- - Copyright 2014 Joey Hess <joey@kitenet.net>+ - Copyright 2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- thread scheduling  -- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>  - Copyright 2011 Bas van Dijk & Roel van Dijk  -  - License: BSD-2-clause

@@ -1,6 +1,6 @@ {- Temporary files and directories.  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -1,6 +1,6 @@ {- user info  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}

@@ -12,7 +12,6 @@ --import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User --import qualified Propellor.Property.Hostname as Hostname---import qualified Propellor.Property.Reboot as Reboot --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker @@ -29,7 +28,7 @@ 		& Apt.unattendedUpgrades 		& Apt.installed ["etckeeper"] 		& Apt.installed ["ssh"]-		& User.hasSomePassword "root" (Context "mybox.example.com")+		& User.hasSomePassword "root" 		& Network.ipv6to4 		& File.dirExists "/var/www" 		& Docker.docked webserverContainer