Merge tag '5.6.0' into debian

tagging package propellor version 5.6.0

18 files changed, 324 insertions, 58 deletions

diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 1b345f15..6ca133cb 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -266,8 +266,8 @@ cabalBuild msys = do
 	-- a binary that is fully built. Also, avoid ever removing
 	-- or breaking the symlink.
 	--
-	-- Need cp -a to make build timestamp checking work.
-	unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $
+	-- Need cp -pfRL to make build timestamp checking work.
+	unlessM (boolSystem "cp" [Param "-pfRL", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $
 		error "cp of binary failed"
 	rename (tmpfor safetycopy) safetycopy
 	symlinkPropellorBin safetycopy
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index 6c720e2b..ab624706 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -7,7 +7,7 @@
 module Propellor.EnsureProperty
 	( ensureProperty
 	, property'
-	, OuterMetaTypesWitness(..)
+	, OuterMetaTypesWitness
 	, Cannot_ensureProperty_WithInfo
 	) where
 
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index c48bc060..53e7ad5a 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -13,11 +13,13 @@ import Propellor.Message
 import Propellor.Git.Config
 import Utility.SafeCommand
 import Utility.Process
+import Utility.Process.Transcript
 import Utility.Process.NonConcurrent
 import Utility.Monad
 import Utility.Misc
 import Utility.Tmp
 import Utility.Env
+import Utility.Env.Set
 import Utility.Directory
 import Utility.Split
 import Utility.Exception
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 8c0a5859..54dd8908 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -303,7 +303,8 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
   where
 	-- This use of getSatisfy is safe, because both a and b
 	-- are added as children, so their info will propigate.
-	c = withOS (getDesc a) $ \_ o ->
+	c = property (getDesc a) $ do
+		o <- getOS
 		if matching o a
 			then maybe (pure NoChange) id (getSatisfy a)
 			else if matching o b
@@ -330,15 +331,9 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
 withOS
 	:: (SingI metatypes)
 	=> Desc
-	-> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)
+	-> (OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result)
 	-> Property (MetaTypes metatypes)
-withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
-  where
-	-- Using this dummy value allows ensureProperty to be used
-	-- even though the inner property probably doesn't target everything
-	-- that the outer withOS property targets.
-	dummyoutermetatypes :: OuterMetaTypesWitness ('[])
-	dummyoutermetatypes = OuterMetaTypesWitness sing
+withOS desc a = property' desc $ \w -> a w =<< getOS
 
 -- | A property that always fails with an unsupported OS error.
 unsupportedOS :: Property UnixLike
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
index 9d49fdf4..f662c8ee 100644
--- a/src/Propellor/Property/Borg.hs
+++ b/src/Propellor/Property/Borg.hs
@@ -59,12 +59,15 @@ runBorgEnv (BorgRepoUsing os _) = map go os
 	go (UsesEnvVar (k, v)) = (k, v)
 
 installed :: Property DebianLike
-installed = withOS desc $ \w o -> case o of
-	(Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
-		Apt.backportInstalled ["borgbackup", "python3-msgpack"]
-	_ -> ensureProperty w $
-		Apt.installed ["borgbackup"]
+installed = pickOS installdebian aptinstall
   where
+	installdebian :: Property Debian
+	installdebian = withOS desc $ \w o -> case o of
+		(Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
+			Apt.backportInstalled ["borgbackup", "python3-msgpack"]
+		_ -> ensureProperty w $
+			Apt.installed ["borgbackup"]
+	aptinstall = Apt.installed ["borgbackup"] `describe` desc
         desc = "installed borgbackup"
 
 repoExists :: BorgRepo -> IO Bool
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index ab700a9d..b9fb10e0 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -79,7 +79,7 @@ niceJob desc times user cddir command = job desc times user cddir
 	("nice ionice -c 3 sh -c " ++ shellEscape command)
 
 -- | Installs a cron job to run propellor.
-runPropellor :: Times -> Property UnixLike
+runPropellor :: Times -> Property DebianLike
 runPropellor times = withOS "propellor cron job" $ \w o -> do
 	bootstrapper <- getBootstrapper
 	ensureProperty w $
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index fa41808e..29bc2d1c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -17,6 +17,7 @@ module Propellor.Property.DiskImage (
 	imageRebuiltFor,
 	imageBuiltFrom,
 	imageExists,
+	imageChrootNotPresent,
 	GrubTarget(..),
 	noBootloader,
 ) where
@@ -200,14 +201,13 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 		`describe` desc
   where
 	desc = "built disk image " ++ describeDiskImage img
-	RawDiskImage imgfile = rawDiskImage img
 	cleanrebuild :: Property Linux
 	cleanrebuild
 		| rebuild = property desc $ do
 			liftIO $ removeChroot chrootdir
 			return MadeChange
 		| otherwise = doNothing
-	chrootdir = imgfile ++ ".chroot"
+	chrootdir = imageChroot img
 	chroot =
 		let c = propprivdataonly $ mkchroot chrootdir
 		in setContainerProps c $ containerProps c
@@ -378,7 +378,7 @@ imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixL
 imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
   where
 	desc = "disk image exists " ++ img
-	parttablefile = img ++ ".parttable"
+	parttablefile = imageParttableFile dest
 	setup = property' desc $ \w -> do
 		oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
 		res <- ensureProperty w $ imageExists dest (partTableSize parttable)
@@ -488,6 +488,24 @@ noBootloader = pureInfoProperty "no bootloader" [NoBootloader]
 noBootloaderFinalized :: Finalization
 noBootloaderFinalized _img _mnt _loopDevs = doNothing
 
+imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
+imageChrootNotPresent img = check (doesDirectoryExist dir) $
+	property "destroy the chroot used to build the image" $ makeChange $ do
+		removeChroot dir
+		nukeFile $ imageParttableFile img
+  where
+	dir = imageChroot img
+
+imageChroot :: DiskImage d => d -> FilePath
+imageChroot img = imgfile <.> "chroot"
+  where
+	RawDiskImage imgfile = rawDiskImage img
+
+imageParttableFile :: DiskImage d => d -> FilePath
+imageParttableFile img = imgfile <.> "parttable"
+  where
+	RawDiskImage imgfile = rawDiskImage img
+
 isChild :: FilePath -> Maybe MountPoint -> Bool
 isChild mntpt (Just d)
 	| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index 7b62558d..37063dba 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -17,7 +17,6 @@ module Propellor.Property.Firewall (
 	IPWithMask(..),
 ) where
 
-import Data.Monoid
 import qualified Data.Semigroup as Sem
 import Data.Char
 import Data.List
diff --git a/src/Propellor/Property/Libvirt.hs b/src/Propellor/Property/Libvirt.hs
new file mode 100644
index 00000000..525dd68a
--- /dev/null
+++ b/src/Propellor/Property/Libvirt.hs
@@ -0,0 +1,210 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Libvirt (
+	NumVCPUs(..),
+	MiBMemory(..),
+	AutoStart(..),
+	DiskImageType(..),
+	installed,
+	defaultNetworkAutostarted,
+	defaultNetworkStarted,
+	defined,
+) where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Property.Chroot
+import Propellor.Property.DiskImage
+import qualified Propellor.Property.Apt as Apt
+
+import Utility.Split
+
+-- | The number of virtual CPUs to assign to the virtual machine
+newtype NumVCPUs = NumVCPUs Int
+
+-- | The number of MiB of memory to assign to the virtual machine
+newtype MiBMemory = MiBMemory Int
+
+-- | Whether the virtual machine should be started after it is defined, and at
+-- host system boot
+data AutoStart = AutoStart | NoAutoStart
+
+-- | Which type of disk image to build for the virtual machine
+data DiskImageType = Raw -- | QCow2
+
+-- | Install basic libvirt components
+installed :: Property DebianLike
+installed = Apt.installed ["libvirt-clients", "virtinst"]
+
+-- | Ensure that the default libvirt network is set to autostart, and start it.
+--
+-- On Debian, it is not started by default after installation of libvirt.
+defaultNetworkAutostarted :: Property DebianLike
+defaultNetworkAutostarted = autostarted
+	`requires` installed
+	`before` defaultNetworkStarted
+  where
+	autostarted = check (not <$> doesFileExist autostartFile) $
+		cmdProperty "virsh" ["net-autostart", "default"]
+	autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml"
+
+-- | Ensure that the default libvirt network is started.
+defaultNetworkStarted :: Property DebianLike
+defaultNetworkStarted =	go `requires` installed
+  where
+	go :: Property UnixLike
+	go = property "start libvirt's default network" $ do
+		runningNetworks <- liftIO $ virshGetColumns ["net-list"]
+		if ["default"] `elem` (take 1 <$> runningNetworks)
+			then noChange
+			else makeChange $ unlessM startIt $
+				errorMessage "failed to start default network"
+	startIt = boolSystem "virsh" [Param "net-start", Param "default"]
+
+
+-- | Builds a disk image with the properties of the given Host, installs a
+-- libvirt configuration file to boot the image, and if it is set to autostart,
+-- start the VM.
+--
+-- Note that building the disk image happens only once.  So if you change the
+-- properties of the given Host, this property will not modify the disk image.
+-- In order to later apply properties to the VM, you should spin it directly, or
+-- arrange to have it spun with a property like 'Cron.runPropellor', or use
+-- 'Propellor.Property.Conductor' from the VM host.
+--
+-- Suggested usage in @config.hs@:
+--
+-- > mybox = host "mybox.example.com" $ props
+-- > 	& osDebian (Stable "stretch") X86_64
+-- > 	& Libvirt.defaultNetworkAutostarted
+-- > 	& Libvirt.defined Libvirt.Raw
+-- > 		(Libvirt.MiBMemory 2048) (Libvirt.NumVCPUs 2)
+-- > 		Libvirt.NoAutoStart subbox
+-- >
+-- > subbox = host "subbox.mybox.example.com" $ props
+-- > 	& osDebian Unstable X86_64
+-- > 	& hasPartition
+-- > 		( partition EXT4
+-- > 			`mountedAt` "/"
+-- > 			`addFreeSpace` MegaBytes 10240
+-- > 		)
+-- > 	& Apt.installed ["linux-image-amd64"]
+-- > 	& Grub.installed PC
+-- >
+-- > 	& ipv4 "192.168.122.31"
+-- > 	& Network.static "ens3" (IPv4 "192.168.122.31")
+-- > 		(Just (Network.Gateway (IPv4 "192.168.122.1")))
+-- > 		`requires` Network.cleanInterfacesFile
+-- > 	& Hostname.sane
+defined
+	:: DiskImageType
+	-> MiBMemory
+	-> NumVCPUs
+	-> AutoStart
+	-> Host
+	-> Property (HasInfo + DebianLike)
+defined imageType (MiBMemory mem) (NumVCPUs cpus) auto h =
+	(built `before` nuked `before` xmlDefined `before` started)
+	`requires` installed
+  where
+	built :: Property (HasInfo + DebianLike)
+	built = check (not <$> doesFileExist imageLoc) $
+		setupRevertableProperty $ imageBuiltFor h
+			(image) (Debootstrapped mempty)
+
+	nuked :: Property UnixLike
+	nuked = imageChrootNotPresent image
+
+	xmlDefined :: Property UnixLike
+	xmlDefined = check (not <$> doesFileExist conf) $
+		property "define the libvirt VM" $
+		withTmpFile (hostName h) $ \t fh -> do
+			xml <- liftIO $ readProcess "virt-install" $
+				[ "-n", hostName h
+				, "--memory=" ++ show mem
+				, "--vcpus=" ++ show cpus
+				, "--disk"
+				, "path=" ++ imageLoc
+					++ ",device=disk,bus=virtio"
+				, "--print-xml"
+				] ++ autoStartArg ++ osVariantArg
+			liftIO $ hPutStrLn fh xml
+			liftIO $ hClose fh
+			makeChange $ unlessM (defineIt t) $
+				errorMessage "failed to define VM"
+	  where
+		defineIt t = boolSystem "virsh" [Param "define", Param t]
+
+	started :: Property UnixLike
+	started = case auto of
+		AutoStart -> property "start the VM" $ do
+			runningVMs <- liftIO $ virshGetColumns ["list"]
+			-- From the point of view of `virsh start`, the "State"
+			-- column in the output of `virsh list` is not relevant.
+			-- So long as the VM is listed, it's considered started.
+			if [hostName h] `elem` (take 1 . drop 1 <$> runningVMs)
+				then noChange
+				else makeChange $ unlessM startIt $
+					errorMessage "failed to start VM"
+		NoAutoStart -> doNothing
+	  where
+		startIt = boolSystem "virsh" [Param "start", Param $ hostName h]
+
+	image = case imageType of
+		Raw -> RawDiskImage imageLoc
+	imageLoc =
+		"/var/lib/libvirt/images" </> hostName h <.> case imageType of
+			Raw -> "img"
+	conf = "/etc/libvirt/qemu" </> hostName h <.> "xml"
+
+	osVariantArg = maybe [] (\v -> ["--os-variant=" ++ v]) $ osVariant h
+	autoStartArg = case auto of
+		AutoStart -> ["--autostart"]
+		NoAutoStart -> []
+
+-- ==== utility functions ====
+
+-- The --os-variant property is optional, per virt-install(1), so return Nothing
+-- if there isn't a known correct value.  The VM will still be defined.  Pass
+-- the value if we can, though, to optimise the generated XML for the host's OS
+osVariant :: Host -> Maybe String
+osVariant h = hostSystem h >>= \s -> case s of
+	System (Debian _ (Stable "jessie")) _ -> Just "debian8"
+	System (Debian _ (Stable "stretch")) _ -> Just "debian9"
+	System (Debian _ Testing) _ -> Just "debiantesting"
+	System (Debian _ Unstable) _ -> Just "debiantesting"
+
+	System (Buntish "trusty") _ -> Just "ubuntu14.04"
+	System (Buntish "utopic") _ -> Just "ubuntu14.10"
+	System (Buntish "vivid") _ -> Just "ubuntu15.04"
+	System (Buntish "wily") _ -> Just "ubuntu15.10"
+	System (Buntish "xenial") _ -> Just "ubuntu16.04"
+	System (Buntish "yakkety") _ -> Just "ubuntu16.10"
+	System (Buntish "zesty") _ -> Just "ubuntu17.04"
+	System (Buntish "artful") _ -> Just "ubuntu17.10"
+	System (Buntish "bionic") _ -> Just "ubuntu18.04"
+
+	System (FreeBSD (FBSDProduction FBSD101)) _ -> Just "freebsd10.1"
+	System (FreeBSD (FBSDProduction FBSD102)) _ -> Just "freebsd10.2"
+	System (FreeBSD (FBSDProduction FBSD093)) _ -> Just "freebsd9.3"
+	System (FreeBSD (FBSDLegacy FBSD101)) _ -> Just "freebsd10.1"
+	System (FreeBSD (FBSDLegacy FBSD102)) _ -> Just "freebsd10.2"
+	System (FreeBSD (FBSDLegacy FBSD093)) _ -> Just "freebsd9.3"
+
+	-- libvirt doesn't have an archlinux variant yet, it seems
+	System ArchLinux _ -> Nothing
+
+	-- other stable releases that we don't know about (since there are
+	-- infinitely many possible stable release names, as it is a freeform
+	-- string, we need this to avoid a compiler warning)
+	System (Debian _ _) _ -> Nothing
+	System (Buntish _) _ -> Nothing
+
+-- Run a virsh command with the given list of arguments, that is expected to
+-- yield tabular output, and return the rows
+virshGetColumns :: [String] -> IO [[String]]
+virshGetColumns args = map (filter (not . null) . split " ") . drop 2 . lines
+ 	<$> readProcess "virsh" args
+
+hostSystem :: Host -> Maybe System
+hostSystem = fromInfoVal . fromInfo . hostInfo
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 6a6bcd31..2805cc97 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -122,9 +122,9 @@ standardAutoBuilder suite arch flavor =
 		& Apt.stdSourcesList
 		& Apt.unattendedUpgrades
 		& Apt.cacheCleaned
-		& buildDepsApt
 		& User.accountFor (User builduser)
 		& tree (architectureToDebianArchString arch) flavor
+		& buildDepsApt
 
 stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
 stackAutoBuilder suite arch flavor =
@@ -140,7 +140,7 @@ stackAutoBuilder suite arch flavor =
 		-- Workaround https://github.com/commercialhaskell/stack/issues/2093
 		& Apt.installed ["libtinfo-dev"]
 
-stackInstalled :: Property Linux
+stackInstalled :: Property DebianLike
 stackInstalled = withOS "stack installed" $ \w o ->
 	case o of
 		(Just (System (Debian Linux (Stable "jessie")) arch)) ->
@@ -182,6 +182,7 @@ armAutoBuilder baseautobuilder suite arch flavor =
 	propertyList "arm git-annex autobuilder" $ props
 		& baseautobuilder suite arch flavor
 		-- Works around ghc crash with parallel builds on arm.
+		& File.dirExists (homedir </> ".cabal")
 		& (homedir </> ".cabal" </> "config")
 			`File.containsLine` "jobs: 1"
 		-- Work around https://github.com/systemd/systemd/issues/7135
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index e7d27de5..07787705 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -400,23 +400,31 @@ podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *")
 	"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
 	`requires` Apt.installed ["git-annex", "myrepos"]
 
-kiteMailServer :: Property (HasInfo + DebianLike)
-kiteMailServer = propertyList "kitenet.net mail server" $ props
-	& Postfix.installed
-	& Apt.installed ["postfix-pcre"]
-	& Apt.serviceInstalledRunning "postgrey"
+spamdEnabled :: Property DebianLike
+spamdEnabled = tightenTargets $ 
+	cmdProperty "update-rc.d" ["spamassassin", "enable"]
+		`assume` MadeChange
 
+spamassassinConfigured :: Property DebianLike
+spamassassinConfigured = propertyList "spamassassin configured" $ props
 	& Apt.serviceInstalledRunning "spamassassin"
 	& "/etc/default/spamassassin" `File.containsLines`
 		[ "# Propellor deployed"
-		, "ENABLED=1"
 		, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\""
 		, "CRON=1"
 		, "NICE=\"--nicelevel 15\""
-		] `onChange` Service.restarted "spamassassin"
-		`describe` "spamd enabled"
+		]
+		`describe` "spamd configured"
+		`onChange` spamdEnabled
+		`onChange` Service.restarted "spamassassin"
 		`requires` Apt.serviceInstalledRunning "cron"
 
+kiteMailServer :: Property (HasInfo + DebianLike)
+kiteMailServer = propertyList "kitenet.net mail server" $ props
+	& Postfix.installed
+	& Apt.installed ["postfix-pcre"]
+	& Apt.serviceInstalledRunning "postgrey"
+	& spamassassinConfigured
 	& Apt.serviceInstalledRunning "spamass-milter"
 	-- Add -m to prevent modifying messages Subject or body.
 	& "/etc/default/spamass-milter" `File.containsLine`
@@ -585,10 +593,18 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
 	& "/etc/pine.conf" `File.hasContent`
 		[ "# deployed with propellor"
 		, "inbox-path={localhost}inbox"
-		, "rsh-command=/usr/lib/dovecot/imap"
+		, "rsh-command=" ++ imapalpinescript
 		]
 		`describe` "pine configured to use local imap server"
-
+	& imapalpinescript `File.hasContent`
+		[ "#!/bin/sh"
+		, "# deployed with propellor"
+		, "set -e"
+		, "exec /usr/lib/dovecot/imap 2>/dev/null"
+		]
+		`onChange` (imapalpinescript `File.mode`
+			combineModes (readModes ++ executeModes))
+		`describe` "imap script for pine"
 	& Apt.serviceInstalledRunning "mailman"
 	-- Override the default http url. (Only affects new lists.)
 	& "/etc/mailman/mm_cfg.py" `File.containsLine`
@@ -600,6 +616,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
   where
 	ctx = Context "kitenet.net"
 	pinescript = "/usr/local/bin/pine"
+	imapalpinescript = "/usr/local/bin/imap-for-alpine"
 	dovecotusers = "/etc/dovecot/users"
 
 	ssmtp = Postfix.Service
@@ -806,7 +823,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
 		, "RewriteRule /~anna/.* http://waldeneffect\\.org/ [R]"
 		, "RewriteRule /~anna/.* http://waldeneffect\\.org/ [R]"
 		, "RewriteRule /~anna http://waldeneffect\\.org/ [R]"
-		, "RewriteRule /simpleid/ http://openid.kitenet.net:8081/simpleid/"
+		, "RewriteRule /simpleid/ http://openid.kitenet.net:8086/simpleid/"
 		, "# Even the kite home page is not here any more!"
 		, "RewriteRule ^/$ http://www.kitenet.net/ [R]"
 		, "RewriteRule ^/index.html http://www.kitenet.net/ [R]"
@@ -937,7 +954,6 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
 		`requires` Apt.installed
 			[ "ghc", "cabal-install", "make"
 			, "libghc-http-types-dev"
-			, "libghc-stm-dev"
 			, "libghc-aeson-dev"
 			, "libghc-wai-dev"
 			, "libghc-warp-dev"
@@ -1016,13 +1032,17 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
 	-- rsync server command to be updated too.
 	rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/"
 
+homerouterWifiInterfaceOld :: String
+homerouterWifiInterfaceOld = "wlx00c0ca82eb78" -- thinkpenguin wifi adapter
+
 homerouterWifiInterface :: String
-homerouterWifiInterface = "wlan0" -- "wlx7cdd90400448" is a wifi dongle
+homerouterWifiInterface = "wlx7cdd90400448" -- small wifi dongle
 
 -- My home router, running hostapd and dnsmasq,
 -- with eth0 connected to a satellite modem, and a fallback ppp connection.
 homeRouter :: Property (HasInfo + DebianLike)
 homeRouter = propertyList "home router" $ props
+	& File.notPresent (Network.interfaceDFile homerouterWifiInterfaceOld)
 	& Network.static homerouterWifiInterface (IPv4 "10.1.1.1") Nothing
 		`requires` Network.cleanInterfacesFile
 	& Apt.installed ["hostapd"]
@@ -1134,6 +1154,8 @@ laptopSoftware = Apt.installed
 	, "yeahconsole", "xkbset", "xinput"
 	, "assword", "pumpa"
 	, "vorbis-tools", "audacity"
+	, "ekiga"
+	, "bluez-firmware", "blueman", "pulseaudio-module-bluetooth"
 	, "xul-ext-ublock-origin", "xul-ext-pdf.js", "xul-ext-status4evar"
 	, "vim-syntastic", "vim-fugitive"
 	, "adb", "gthumb"
@@ -1203,15 +1225,17 @@ homeNAS = propertyList "home NAS" $ props
 	& Apt.installed ["uhubctl"]
 	& "/etc/udev/rules.d/52-startech-hub.rules" `File.hasContent`
 		[ "# let users power control startech hub with uhubctl"
-		, "ATTR{idVendor}==\"0409\", ATTR{idProduct}==\"005a\", MODE=\"0666\""
+		, "ATTR{idVendor}==\"" ++ hubvendor ++ "\", ATTR{idProduct}==\"005a\", MODE=\"0666\""
 		]
-	& autoMountDrive "archive-10" (USBHubPort 1) (Just "archive-older")
-	& autoMountDrive "archive-11" (USBHubPort 2) (Just "archive-old")
-	& autoMountDrive "archive-12" (USBHubPort 3) (Just "archive")
-	& autoMountDrive "passport" (USBHubPort 4) Nothing
+	& autoMountDrive "archive-10" (USBHubPort hubvendor 1) (Just "archive-older")
+	& autoMountDrive "archive-11" (USBHubPort hubvendor 2) (Just "archive-old")
+	& autoMountDrive "archive-12" (USBHubPort hubvendor 3) (Just "archive")
+	& autoMountDrive "passport" (USBHubPort hubvendor 4) Nothing
 	& Apt.installed ["git-annex", "borgbackup"]
+  where
+	hubvendor = "0409"
 
-newtype USBHubPort = USBHubPort Int
+data USBHubPort = USBHubPort String Int
 
 -- Makes a USB drive with the given label automount, and unmount after idle
 -- for a while.
@@ -1219,7 +1243,7 @@ newtype USBHubPort = USBHubPort Int
 -- The hub port is turned on and off automatically as needed, using
 -- uhubctl.
 autoMountDrive :: Mount.Label -> USBHubPort -> Maybe FilePath -> Property DebianLike
-autoMountDrive label (USBHubPort port) malias = propertyList desc $ props
+autoMountDrive label (USBHubPort hubvendor port) malias = propertyList desc $ props
 	& File.ownerGroup mountpoint (User "joey") (Group "joey")
 		`requires` File.dirExists mountpoint
 	& case malias of
@@ -1248,8 +1272,8 @@ autoMountDrive label (USBHubPort port) malias = propertyList desc $ props
 		, "[Service]"
 		, "Type=oneshot"
 		, "RemainAfterExit=true"
-		, "ExecStart=/usr/sbin/uhubctl -a on -p " ++ show port
-		, "ExecStop=/bin/sh -c 'uhubctl -a off -p " ++ show port ++
+		, "ExecStart=/usr/sbin/uhubctl -a on -p " ++ show port ++ " --vendor " ++ hubvendor 
+		, "ExecStop=/bin/sh -c 'uhubctl -a off -p " ++ show port ++ " --vendor " ++ hubvendor
 			-- Powering off the port does not remove device
 			-- files, so ask udev to remove the devfile; it will
 			-- be added back after the drive next spins up
@@ -1257,7 +1281,7 @@ autoMountDrive label (USBHubPort port) malias = propertyList desc $ props
 			-- spun up.
 			-- (This only works when the devfile is in
 			-- by-label.)
-			"; udevadm trigger --action=remove " ++ devfile ++ " || true'"
+			++ "; udevadm trigger --action=remove " ++ devfile ++ " || true'"
 		, "[Install]"
 		, "WantedBy="
 		]
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index cb63ff5a..9c9f5914 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -204,13 +204,18 @@ killUserProcesses = set "yes" <!> set "no"
 
 -- | Ensures machined and machinectl are installed
 machined :: Property Linux
-machined = withOS "machined installed" $ \w o ->
-	case o of
-		-- Split into separate debian package since systemd 225.
-		(Just (System (Debian _ suite) _))
-			| not (isStable suite) || suite == (Stable "stretch") ->
-				ensureProperty w $ Apt.installed ["systemd-container"]
-		_ -> noChange
+machined = installeddebian `pickOS` assumeinstalled
+  where
+	installeddebian :: Property DebianLike
+	installeddebian = withOS "machined installed" $ \w o ->
+		case o of
+			-- Split into separate debian package since systemd 225.
+			(Just (System (Debian _ suite) _))
+				| not (isStable suite) || suite == (Stable "stretch") ->
+					ensureProperty w $ Apt.installed ["systemd-container"]
+			_ -> noChange
+	assumeinstalled :: Property Linux
+	assumeinstalled = doNothing
 
 -- | Defines a container with a given machine name,
 -- and how to create its chroot if not already present.
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 0b5bdddc..f6bc2c4b 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -168,7 +168,7 @@ hasDesktopGroups user@(User u) = property' desc $ \o -> do
 	existinggroups <- map (fst . break (== ':')) . lines
 		<$> liftIO (readFile "/etc/group")
 	let toadd = filter (`elem` existinggroups) desktopgroups
-	ensureProperty o $ propertyList desc $ toProps $
+	ensureProperty o $ combineProperties desc $ toProps $
 		map (hasGroup user . Group) toadd
   where
 	desc = "user " ++ u ++ " is in standard desktop groups"
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
index a8f50ed0..9ba15d86 100644
--- a/src/Propellor/Ssh.hs
+++ b/src/Propellor/Ssh.hs
@@ -19,7 +19,7 @@ sshCachingParams :: HostName -> IO [CommandParam]
 sshCachingParams hn = do
 	home <- myHomeDir
 	let socketfile = socketFile home hn
-	createDirectoryIfMissing False (takeDirectory socketfile)
+	createDirectoryIfMissing True (takeDirectory socketfile)
 	let ps =
 		[ Param "-o"
 		, Param ("ControlPath=" ++ socketfile)
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index e10e0f5b..7052bf92 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 01d777a4..34ea4272 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -23,7 +23,7 @@ module Propellor.Types.OS (
 
 import Propellor.Types.ConfigurableValue
 
-import Network.BSD (HostName)
+import Network.Socket (HostName)
 import Data.Typeable
 import Data.String
 
diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs
index f2089ee8..7788c9aa 100644
--- a/src/Propellor/Types/Singletons.hs
+++ b/src/Propellor/Types/Singletons.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-}
+{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, FlexibleContexts #-}
 
 -- | Simple implementation of singletons, portable back to ghc 7.6.3
 
diff --git a/src/Propellor/Utilities.hs b/src/Propellor/Utilities.hs
index 33af4eda..56e7f2fb 100644
--- a/src/Propellor/Utilities.hs
+++ b/src/Propellor/Utilities.hs
@@ -9,19 +9,27 @@
 module Propellor.Utilities (
 	  module Utility.PartialPrelude
 	, module Utility.Process
+	, module Utility.Process.Transcript
 	, module Utility.Exception
 	, module Utility.Env
+	, module Utility.Env.Set
 	, module Utility.Directory
+	, module Utility.Directory.TestDirectory
 	, module Utility.Tmp
+	, module Utility.Tmp.Dir
 	, module Utility.Monad
 	, module Utility.Misc
 ) where
 
 import Utility.PartialPrelude
 import Utility.Process
+import Utility.Process.Transcript
 import Utility.Exception
 import Utility.Env
+import Utility.Env.Set
 import Utility.Directory
+import Utility.Directory.TestDirectory
 import Utility.Tmp
+import Utility.Tmp.Dir
 import Utility.Monad
 import Utility.Misc