Merge branch 'joeyconfig' of git://git.kitenet.net/propellor into joeyconfig

Conflicts:
	src/Propellor/Property/SiteSpecific/IABak.hs

.gitignore

@@ -7,4 +7,7 @@ Setup
 Setup.hi
 Setup.o
 docker
+chroot
 propellor.1
+.lock
+.lastchecked

Makefile

@@ -17,11 +17,15 @@ install:
 	cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1)
 	# cabal sdist does not preserve symlinks, so copy over file
 	cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done
-	cd dist/gittmp && git init && \
+	export GIT_AUTHOR_NAME=build \
-		git add . \
+	&& export GIT_AUTHOR_EMAIL=build@buildhost \
-		&& git commit -q -m "distributed version of propellor" \
+	&& export GIT_COMMITTER_NAME=build \
-		&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \
+	&& export GIT_COMMITTER_EMAIL=build@buildhost \
-		&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head
+	&& cd dist/gittmp && git init \
+	&& git add . \
+	&& git commit -q -m "distributed version of propellor" \
+	&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \
+	&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head
 	rm -rf dist/gittmp
 
 clean:

config-joey.hs

@@ -25,6 +25,7 @@ import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Gpg as Gpg
 import qualified Propellor.Property.Systemd as Systemd
 import qualified Propellor.Property.Journald as Journald
+import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.OS as OS
 import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
 import qualified Propellor.Property.HostingProvider.Linode as Linode
@@ -45,6 +46,7 @@ hosts =                --                  (o)  `
 	, gnu
 	, clam
 	, orca
+	, honeybee
 	, kite
 	, elephant
 	, beaver
@@ -74,8 +76,6 @@ darkstar = host "darkstar.kitenet.net"
 	& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel
 
 	& Apt.buildDep ["git-annex"] `period` Daily
-	& Docker.configured
-	! Docker.docked gitAnnexAndroidDev
 
 	& JoeySites.postfixClientRelay (Context "darkstar.kitenet.net")
 	& JoeySites.dkimMilter
@@ -83,7 +83,6 @@ darkstar = host "darkstar.kitenet.net"
 gnu :: Host
 gnu = host "gnu.kitenet.net"
 	& Apt.buildDep ["git-annex"] `period` Daily
-	& Docker.configured
 
 	& JoeySites.postfixClientRelay (Context "gnu.kitenet.net")
 	& JoeySites.dkimMilter
@@ -97,18 +96,18 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
 	& Ssh.randomHostKeys
 	& Apt.unattendedUpgrades
 	& Network.ipv6to4
+
 	& Tor.isRelay
 	& Tor.named "kite1"
 	& Tor.bandwidthRate (Tor.PerMonth "400 GB")
 
-	& Docker.configured
+	& Systemd.nspawned webserver
-	& Docker.garbageCollected `period` Daily
-	& Docker.docked webserver
 	& File.dirExists "/var/www/html"
-	& File.notPresent "/var/www/html/index.html"
+	& File.notPresent "/var/www/index.html"
-	& "/var/www/index.html" `File.hasContent` ["hello, world"]
+	& "/var/www/html/index.html" `File.hasContent` ["hello, world"]
 	& alias "helloworld.kitenet.net"
-	& Docker.docked oldusenetShellBox
+	
+	& Systemd.nspawned oldusenetShellBox
 
 	& JoeySites.scrollBox
 	& alias "scroll.joeyh.name"
@@ -129,15 +128,46 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
 
 	& Apt.unattendedUpgrades
 	& Postfix.satellite
+	& Apt.serviceInstalledRunning "ntp"
 	& Systemd.persistentJournal
-	& Docker.configured
+
-	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
+	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
-	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
+		GitAnnexBuilder.standardAutoBuilder
-	& Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
+		(System (Debian Unstable) "amd64") fifteenpast "2h")
-	& Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage (Cron.Times "1 3 * * *") "5h")
+	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
-	& Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage (Cron.Times "1 1 * * *") "3h")
+		GitAnnexBuilder.standardAutoBuilder
-	& Docker.garbageCollected `period` Daily
+		(System (Debian Unstable) "i386") fifteenpast "2h")
-	& Apt.buildDep ["git-annex"] `period` Daily
+	& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
+		(Cron.Times "1 1 * * *") "3h")
+  where
+	fifteenpast = Cron.Times "15 * * * *"
+
+honeybee :: Host
+honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
+	[ "Arm git-annex build box." ]
+	& ipv6 "2001:4830:1600:187::2"
+
+	-- No unattended upgrades as there is currently no console access.
+	-- (Also, system is not currently running a stock kernel,
+	-- although it should be able to.)
+	& Postfix.satellite
+	& Apt.serviceInstalledRunning "aiccu"
+	& Apt.serviceInstalledRunning "swapspace"
+	& Apt.serviceInstalledRunning "ntp"
+
+	-- Not using systemd-nspawn because it's broken (kernel issue?)
+	-- & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
+	-- 	GitAnnexBuilder.armAutoBuilder
+	-- 		builderos Cron.Daily "22h")
+	& Chroot.provisioned 
+		(Chroot.debootstrapped builderos mempty "/var/lib/container/armel-git-annex-builder"
+			& "/etc/timezone" `File.hasContent` ["America/New_York"]
+			& GitAnnexBuilder.armAutoBuilder
+				builderos (Cron.Times "1 1 * * *") "12h"
+		)
+  where
+	-- Using unstable to get new enough ghc for TH on arm.
+	builderos = System (Debian Unstable) "armel"
 
 -- This is not a complete description of kite, since it's a
 -- multiuser system with eg, user passwords that are not deployed
@@ -222,9 +252,6 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
 		, "zsh"
 		]
 	
-	& Docker.configured
-	& Docker.garbageCollected `period` Daily
-	
 	& alias "nntp.olduse.net"
 	& JoeySites.oldUseNetServer hosts
 	
@@ -281,13 +308,14 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	& myDnsSecondary
 	
 	& Docker.configured
-	& Docker.docked oldusenetShellBox
 	& Docker.docked openidProvider
 		`requires` Apt.serviceInstalledRunning "ntp"
 	& Docker.docked ancientKitenet
 	& Docker.docked jerryPlay
 	& Docker.garbageCollected `period` (Weekly (Just 1))
 	
+	& Systemd.nspawned oldusenetShellBox
+	
 	& JoeySites.scrollBox
 	& alias "scroll.joeyh.name"
 	& alias "eu.scroll.joeyh.name"
@@ -295,7 +323,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	-- For https port 443, shellinabox with ssh login to
 	-- kitenet.net
 	& alias "shell.kitenet.net"
-	& Docker.docked kiteShellBox
+	& Systemd.nspawned kiteShellBox
 	-- Nothing is using http port 80, so listen on
 	-- that port for ssh, for traveling on bad networks that
 	-- block 22.
@@ -316,6 +344,7 @@ beaver = host "beaver.kitenet.net"
 -- Branchable is not completely deployed with propellor yet.
 pell :: Host
 pell = host "pell.branchable.com"
+	& alias "branchable.com"
 	& ipv4 "66.228.46.55"
 	& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
 	
@@ -371,22 +400,21 @@ iabak = host "iabak.archiveteam.org"
        --'                        __|II|      ,.
      ----                      __|II|II|__   (  \_,/\
 --'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-.-'-
--------------------------- |      [Docker]       / --------------------------
+-------------------------- |   [Containers]      / --------------------------
 -------------------------- :                    / ---------------------------
 --------------------------- \____, o          ,' ----------------------------
 ---------------------------- '--,___________,'  -----------------------------
 
 -- Simple web server, publishing the outside host's /var/www
-webserver :: Docker.Container
+webserver :: Systemd.Container
 webserver = standardStableContainer "webserver"
-	& Docker.publish "80:80"
+	& Systemd.bind "/var/www"
-	& Docker.volume "/var/www:/var/www"
 	& Apt.serviceInstalledRunning "apache2"
 
 -- My own openid provider. Uses php, so containerized for security
 -- and administrative sanity.
 openidProvider :: Docker.Container
-openidProvider = standardStableContainer "openid-provider"
+openidProvider = standardStableDockerContainer "openid-provider"
 	& alias "openid.kitenet.net"
 	& Docker.publish "8081:80"
 	& OpenId.providerFor [User "joey", User "liw"]
@@ -394,39 +422,30 @@ openidProvider = standardStableContainer "openid-provider"
 
 -- Exhibit: kite's 90's website.
 ancientKitenet :: Docker.Container
-ancientKitenet = standardStableContainer "ancient-kitenet"
+ancientKitenet = standardStableDockerContainer "ancient-kitenet"
 	& alias "ancient.kitenet.net"
 	& Docker.publish "1994:80"
 	& Apt.serviceInstalledRunning "apache2"
-	& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www"
+	& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html"
 		(Just "remotes/origin/old-kitenet.net")
 
-oldusenetShellBox :: Docker.Container
+oldusenetShellBox :: Systemd.Container
 oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
 	& alias "shell.olduse.net"
-	& Docker.publish "4200:4200"
 	& JoeySites.oldUseNetShellBox
 
--- for development of git-annex for android, using my git-annex work tree
-gitAnnexAndroidDev :: Docker.Container
-gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
-	& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
-  where
-	gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
-	
 jerryPlay :: Docker.Container
-jerryPlay = standardContainer "jerryplay" Unstable "amd64"
+jerryPlay = standardDockerContainer "jerryplay" Unstable "amd64"
 	& alias "jerryplay.kitenet.net"
 	& Docker.publish "2202:22"
 	& Docker.publish "8001:80"
 	& Apt.installed ["ssh"]
 	& User.hasSomePassword (User "root")
-	& Ssh.permitRootLogin True
+	& Ssh.permitRootLogin (Ssh.RootLogin True)
-	
+
-kiteShellBox :: Docker.Container
+kiteShellBox :: Systemd.Container
 kiteShellBox = standardStableContainer "kiteshellbox"
 	& JoeySites.kiteShellBox
-	& Docker.publish "443:443"
 
 type Motd = [String]
 
@@ -457,12 +476,25 @@ standardSystemUnhardened hn suite arch motd = host hn
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove
 
-standardStableContainer :: Docker.ContainerName -> Docker.Container
-standardStableContainer name = standardContainer name (Stable "wheezy") "amd64"
-
 -- This is my standard container setup, Featuring automatic upgrades.
-standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
+standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container
-standardContainer name suite arch = Docker.container name (dockerImage system)
+standardContainer name suite arch = Systemd.container name chroot
+	& os system
+	& Apt.stdSourcesList `onChange` Apt.upgrade
+	& Apt.unattendedUpgrades
+	& Apt.cacheCleaned
+  where
+	system = System (Debian suite) arch
+	chroot = Chroot.debootstrapped system mempty
+
+standardStableContainer :: Systemd.MachineName -> Systemd.Container
+standardStableContainer name = standardContainer name (Stable "jessie") "amd64"
+
+standardStableDockerContainer :: Docker.ContainerName -> Docker.Container
+standardStableDockerContainer name = standardDockerContainer name (Stable "jessie") "amd64"
+
+standardDockerContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
+standardDockerContainer name suite arch = Docker.container name (dockerImage system)
 	& os system
 	& Apt.stdSourcesList `onChange` Apt.upgrade
 	& Apt.unattendedUpgrades
@@ -473,10 +505,10 @@ standardContainer name suite arch = Docker.container name (dockerImage system)
 
 -- Docker images I prefer to use.
 dockerImage :: System -> Docker.Image
-dockerImage (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
+dockerImage (System (Debian Unstable) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch)
-dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch
+dockerImage (System (Debian Testing) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch)
-dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch
+dockerImage (System (Debian (Stable _)) arch) = Docker.latestImage ("joeyh/debian-stable-" ++ arch)
-dockerImage _ = "debian-stable-official" -- does not currently exist!
+dockerImage _ = Docker.latestImage "debian-stable-official" -- does not currently exist!
 
 myDnsSecondary :: Property HasInfo
 myDnsSecondary = propertyList "dns secondary for all my domains" $ props

config-simple.hs

@@ -41,7 +41,7 @@ hosts =
 
 -- A generic webserver in a Docker container.
 webserverContainer :: Docker.Container
-webserverContainer = Docker.container "webserver" "debian"
+webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
 	& os (System (Debian (Stable "jessie")) "amd64")
 	& Apt.stdSourcesList
 	& Docker.publish "80:80"

debian/changelog

@@ -1,11 +1,62 @@
-propellor (2.5.0) UNRELEASED; urgency=medium
+propellor (2.7.0) unstable; urgency=medium
+
+  * Ssh.permitRootLogin type changed to allow configuring WithoutPassword
+    and ForcedCommandsOnly (API change)
+  * setSshdConfig type changed, and setSshdConfigBool added with old type.
+  * Fix a bug in shim generation code for docker and chroots, that
+    sometimes prevented deployment of docker containers.
+  * Added onChangeFlagOnFail which is often a safer alternative to
+    onChange.
+    Thanks, Antoine Eiche.
+  * Work around broken git pull option parser in git 2.5.0,
+    which broke use of --upload-pack to send a git push when running
+    propellor --spin.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 30 Jul 2015 12:05:46 -0400
+
+propellor (2.6.0) unstable; urgency=medium
+
+  * Replace String type synonym Docker.Image by a data type
+    which allows to specify an image name and an optional tag. (API change)
+    Thanks, Antoine Eiche.
+  * Added --unset to delete a privdata field.
+  * Version dependency on exceptions.
+  * Systemd: Add masked property.
+    Thanks, Sean Whitton
+  * Fix make install target to work even when git is not configured.
+
+ -- Joey Hess <id@joeyh.name>  Fri, 10 Jul 2015 22:36:29 -0400
+
+propellor (2.5.0) unstable; urgency=medium
 
   * cmdProperty' renamed to cmdPropertyEnv to make way for a new,
     more generic cmdProperty' (API change)
   * Add docker image related properties.
     Thanks, Antoine Eiche.
+  * Export CommandParam, boolSystem, safeSystem, shellEscape, and
+  * createProcess from Propellor.Property.Cmd, so they are available
+    for use in constricting your own Properties when using propellor
+    as a library.
+  * Improve enter-machine scripts for systemd-nspawn containers to unset most
+    environment variables.
+  * Fix Postfix.satellite bug; the default relayhost was set to the
+    domain, not to smtp.domain as documented.
+  * Mount /proc inside a chroot before provisioning it, to work around #787227
+  * --spin now works when given a short hostname that only resolves to an
+    ipv6 address.
+  * Added publish property for systemd-spawn containers, for port publishing.
+    (Needs systemd version 220.)
+  * Added bind and bindRo properties for systemd-spawn containers.
+  * Firewall: Port was changed to a newtype, and the Port and PortRange
+    constructors of Rules were changed to DPort and DportRange, respectively.
+    (API change)
+  * Docker: volume and publish accept Bound FilePath and Bound Port,
+    respectively. They also continue to accept Strings, for backwards
+    compatibility.
+  * Docker: Added environment property.
+    Thanks Antoine Eiche.
 
- -- Joey Hess <id@joeyh.name>  Thu, 07 May 2015 12:08:34 -0400
+ -- Joey Hess <id@joeyh.name>  Tue, 09 Jun 2015 17:08:43 -0400
 
 propellor (2.4.0) unstable; urgency=medium
 

debian/control

@@ -16,7 +16,7 @@ Build-Depends:
 	libghc-quickcheck2-dev,
 	libghc-mtl-dev,
 	libghc-transformers-dev,
-	libghc-exceptions-dev,
+	libghc-exceptions-dev (>= 0.6),
 Maintainer: Gergely Nagy <algernon@madhouse-project.org>
 Standards-Version: 3.9.6
 Vcs-Git: git://git.joeyh.name/propellor
@@ -38,7 +38,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
 	libghc-quickcheck2-dev,
 	libghc-mtl-dev,
 	libghc-transformers-dev,
-	libghc-exceptions-dev,
+	libghc-exceptions-dev (>= 0.6),
 	git,
 Description: property-based host configuration management in haskell
  Propellor enures that the system it's run in satisfies a list of

doc/usage.mdwn

@@ -71,6 +71,10 @@ and configured in haskell.
 
   Sets a field of privdata. The content is read in from stdin.
 
+* propellor --unset field context
+
+  Removes a value from the privdata store.
+
 * propellor --dump field context
 
   Outputs the privdata value to stdout.

propellor.cabal

@@ -1,6 +1,6 @@
 Name: propellor
-Version: 2.4.0
+Version: 2.7.0
-Cabal-Version: >= 1.6
+Cabal-Version: >= 1.8
 License: BSD3
 Maintainer: Joey Hess <id@joeyh.name>
 Author: Joey Hess
@@ -38,7 +38,7 @@ Executable propellor
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
    containers, network, async, time, QuickCheck, mtl, transformers,
-   exceptions
+   exceptions (>= 0.6)
 
   if (! os(windows))
     Build-Depends: unix
@@ -121,6 +121,7 @@ Library
     Propellor.Exception
     Propellor.Types
     Propellor.Types.Chroot
+    Propellor.Types.Container
     Propellor.Types.Docker
     Propellor.Types.Dns
     Propellor.Types.Empty

src/Propellor/Bootstrap.hs

@@ -6,7 +6,6 @@ module Propellor.Bootstrap (
 ) where
 
 import Propellor
-import Utility.SafeCommand
 
 import System.Posix.Files
 import Data.List

src/Propellor/CmdLine.hs

@@ -7,7 +7,7 @@ import System.Environment (getArgs)
 import Data.List
 import System.Exit
 import System.PosixCompat
-import qualified Network.BSD
+import Network.Socket
 
 import Propellor
 import Propellor.Gpg
@@ -18,7 +18,6 @@ import Propellor.Types.CmdLine
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Shim as Shim
-import Utility.SafeCommand
 
 usage :: Handle -> IO ()
 usage h = hPutStrLn h $ unlines 
@@ -52,6 +51,7 @@ processCmdLine = go =<< getArgs
 		_ -> Spin <$> mapM hostname ps <*> pure Nothing
 	go ("--add-key":k:[]) = return $ AddKey k
 	go ("--set":f:c:[]) = withprivfield f c Set
+	go ("--unset":f:c:[]) = withprivfield f c Unset
 	go ("--dump":f:c:[]) = withprivfield f c Dump
 	go ("--edit":f:c:[]) = withprivfield f c Edit
 	go ("--list-fields":[]) = return ListFields
@@ -95,6 +95,7 @@ defaultMain hostlist = do
 	go _ (Continue cmdline) = go False cmdline
 	go _ Check = return ()
 	go _ (Set field context) = setPrivData field context
+	go _ (Unset field context) = unsetPrivData field context
 	go _ (Dump field context) = dumpPrivData field context
 	go _ (Edit field context) = editPrivData field context
 	go _ ListFields = listPrivDataFields hostlist
@@ -166,9 +167,15 @@ updateFirst' cmdline next = ifM fetchOrigin
 	, next
 	)
 
+-- Gets the fully qualified domain name, given a string that might be
+-- a short name to look up in the DNS.
 hostname :: String -> IO HostName
-hostname s
+hostname s = go =<< catchDefaultIO [] dnslookup
-	| "." `isInfixOf` s = pure s
+  where
-	| otherwise = do
+	dnslookup = getAddrInfo (Just canonname) (Just s) Nothing
-		h <- Network.BSD.getHostByName s
+	canonname = defaultHints { addrFlags = [AI_CANONNAME] }
-		return (Network.BSD.hostName h)
+	go (AddrInfo { addrCanonName = Just v } : _) = pure v
+	go _
+		| "." `isInfixOf` s = pure s -- assume it's a fqdn
+		| otherwise = 
+			error $ "cannot find host " ++ s ++ " in the DNS"

src/Propellor/Git.hs

@@ -3,7 +3,6 @@ module Propellor.Git where
 import Propellor
 import Propellor.PrivData.Paths
 import Propellor.Gpg
-import Utility.SafeCommand
 import Utility.FileMode
 
 getCurrentBranch :: IO String

src/Propellor/PrivData.hs

@@ -6,6 +6,7 @@ module Propellor.PrivData (
 	withSomePrivData,
 	addPrivData,
 	setPrivData,
+	unsetPrivData,
 	dumpPrivData,
 	editPrivData,
 	filterPrivData,
@@ -143,6 +144,11 @@ setPrivData field context = do
 	putStrLn "Enter private data on stdin; ctrl-D when done:"
 	setPrivDataTo field context =<< hGetContentsStrict stdin
 
+unsetPrivData :: PrivDataField -> Context -> IO ()
+unsetPrivData field context = do
+	modifyPrivData $ M.delete (field, context)
+	putStrLn "Private data unset."
+
 dumpPrivData :: PrivDataField -> Context -> IO ()
 dumpPrivData field context =
 	maybe (error "Requested privdata is not set.") putStrLn
@@ -192,17 +198,22 @@ listPrivDataFields hosts = do
 
 setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
 setPrivDataTo field context value = do
-	makePrivDataDir
+	modifyPrivData set
-	m <- decryptPrivData
-	let m' = M.insert (field, context) (chomp value) m
-	gpgEncrypt privDataFile (show m')
 	putStrLn "Private data set."
-	void $ boolSystem "git" [Param "add", File privDataFile]
   where
+	set = M.insert (field, context) (chomp value)
 	chomp s
 		| end s == "\n" = chomp (beginning s)
 		| otherwise = s
 
+modifyPrivData :: (PrivMap -> PrivMap) -> IO ()
+modifyPrivData f = do
+	makePrivDataDir
+	m <- decryptPrivData
+	let m' = f m
+	gpgEncrypt privDataFile (show m')
+	void $ boolSystem "git" [Param "add", File privDataFile]
+
 decryptPrivData :: IO PrivMap
 decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile
 

src/Propellor/Property.hs

@@ -54,6 +54,41 @@ onChange = combineWith $ \p hook -> do
 			return $ r <> r'
 		_ -> return r
 
+-- | Same as `onChange` except that if property y fails, a flag file
+-- is generated. On next run, if the flag file is present, property y
+-- is executed even if property x doesn't change.
+--
+-- With `onChange`, if y fails, the property x `onChange` y returns
+-- `FailedChange`. But if this property is applied again, it returns
+-- `NoChange`. This behavior can cause trouble...
+onChangeFlagOnFail
+	:: (Combines (Property x) (Property y))
+	=> FilePath
+        -> Property x
+        -> Property y
+        -> CombinedType (Property x) (Property y)
+onChangeFlagOnFail flagfile p1 p2 =
+	combineWith go p1 p2
+  where
+	go s1 s2 = do
+		r1 <- s1
+		case r1 of
+			MadeChange -> flagFailed s2
+			_ -> ifM (liftIO $ doesFileExist flagfile)
+				(flagFailed s2
+				, return r1
+				)
+	flagFailed s = do
+		r <- s
+		liftIO $ case r of
+			FailedChange -> createFlagFile
+			_ -> removeFlagFile
+		return r
+	createFlagFile = unlessM (doesFileExist flagfile) $ do
+		createDirectoryIfMissing True (takeDirectory flagfile)
+		writeFile flagfile ""
+	removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
+
 -- | Alias for @flip describe@
 (==>) :: IsProp (Property i) => Desc -> Property i -> Property i
 (==>) = flip describe

src/Propellor/Property/Apache.hs

@@ -4,7 +4,6 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
-import Utility.SafeCommand
 
 type ConfigFile = [String]
 

src/Propellor/Property/Chroot.hs

@@ -19,7 +19,7 @@ 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
-import Utility.SafeCommand
+import Propellor.Property.Mount
 
 import qualified Data.Map as M
 import Data.List.Utils
@@ -56,8 +56,9 @@ debootstrapped system conf location = case system of
 -- | Ensures that the chroot exists and is provisioned according to its
 -- properties.
 --
--- Reverting this property removes the chroot. Note that it does not ensure
+-- Reverting this property removes the chroot. Anything mounted inside it
--- that any processes that might be running inside the chroot are stopped.
+-- is first unmounted. Note that it does not ensure that any processes
+-- that might be running inside the chroot are stopped.
 provisioned :: Chroot -> RevertableProperty
 provisioned c = provisioned' (propigateChrootInfo c) c False
 
@@ -69,7 +70,7 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
   where
 	go desc a = propertyList (chrootDesc c desc) [a]
 
-	setup = propellChroot c (inChrootProcess c) systemdonly
+	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
 		`requires` toProp built
 	
 	built = case (system, builderconf) of
@@ -94,7 +95,7 @@ chrootInfo (Chroot loc _ _ h) =
 	mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
 
 -- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
 propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
 	let d = localdir </> shimdir c
 	let me = localdir </> "propellor"
@@ -117,19 +118,21 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 				, File localdir, File mntpnt
 				]
 		)
-	
+
 	chainprovision shim = do
 		parenthost <- asks hostName
 		cmd <- liftIO $ toChain parenthost c systemdonly
 		pe <- liftIO standardPathEnv
-		let p = mkproc
+		(p, cleanup) <- liftIO $ mkproc
 			[ shim
 			, "--continue"
 			, show cmd
 			]
 		let p' = p { env = Just pe }
-		liftIO $ withHandle StdoutHandle createProcessSuccess p'
+		r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
 			processChainOutput
+		liftIO cleanup
+		return r
 
 toChain :: HostName -> Chroot -> Bool -> IO CmdLine
 toChain parenthost (Chroot loc _ _ _) systemdonly = do
@@ -156,8 +159,22 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 			putStrLn $ "\n" ++ show r
 chain _ _ = errorMessage "bad chain command"
 
-inChrootProcess :: Chroot -> [String] -> CreateProcess
+inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd)
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
+	mountproc
+	return (proc "chroot" (loc:cmd), cleanup)
+  where
+	-- /proc needs to be mounted in the chroot for the linker to use
+	-- /proc/self/exe which is necessary for some commands to work
+	mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
+		void $ mount "proc" "proc" procloc
+	
+	procloc = loc </> "proc"
+
+	cleanup
+		| keepprocmounted = noop
+		| otherwise = whenM (elem procloc <$> mountPointsBelow loc) $
+			umountLazy procloc
 
 provisioningLock :: FilePath -> FilePath
 provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"

src/Propellor/Property/Cmd.hs

@@ -1,22 +1,32 @@
 {-# LANGUAGE PackageImports #-}
 
 module Propellor.Property.Cmd (
+	-- * Properties for running commands and scripts
 	cmdProperty,
 	cmdProperty',
 	cmdPropertyEnv,
+	Script,
 	scriptProperty,
 	userScriptProperty,
+	-- * Lower-level interface for running commands
+	CommandParam(..),
+	boolSystem,
+	boolSystemEnv,
+	safeSystem,
+	safeSystemEnv,
+	shellEscape,
+	createProcess,
 ) where
 
 import Control.Applicative
 import Data.List
 import "mtl" Control.Monad.Reader
-import System.Process (CreateProcess)
 
 import Propellor.Types
 import Propellor.Property
 import Utility.SafeCommand
 import Utility.Env
+import Utility.Process (createProcess, CreateProcess)
 
 -- | A property that can be satisfied by running a command.
 --
@@ -40,15 +50,18 @@ cmdPropertyEnv cmd params env = property desc $ liftIO $ do
   where
 	desc = unwords $ cmd : params
 
--- | A property that can be satisfied by running a series of shell commands.
+-- | A series of shell commands. (Without a leading hashbang.)
-scriptProperty :: [String] -> Property NoInfo
+type Script = [String]
+
+-- | A property that can be satisfied by running a script.
+scriptProperty :: Script -> Property NoInfo
 scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
   where
 	shellcmd = intercalate " ; " ("set -e" : script)
 
--- | A property that can satisfied by running a series of shell commands,
+-- | A property that can satisfied by running a script
 -- as user (cd'd to their home directory).
-userScriptProperty :: User -> [String] -> Property NoInfo
+userScriptProperty :: User -> Script -> Property NoInfo
 userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]
   where
 	shellcmd = intercalate " ; " ("set -e" : "cd" : script)

src/Propellor/Property/Cron.hs

@@ -4,7 +4,6 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Bootstrap
-import Utility.SafeCommand
 import Utility.FileMode
 
 import Data.Char

src/Propellor/Property/Debootstrap.hs

@@ -15,7 +15,6 @@ 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
 
 import Data.List
@@ -107,9 +106,7 @@ unpopulated d = null <$> catchDefaultIO [] (dirContents d)
 
 removetarget :: FilePath -> IO ()
 removetarget target = do
-	submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
+	submnts <- mountPointsBelow target
-		. filter (dirContains target)
-		<$> mountPoints
 	forM_ submnts umountLazy
 	removeDirectoryRecursive target
 

src/Propellor/Property/Docker.hs

@@ -16,22 +16,26 @@ module Propellor.Property.Docker (
 	memoryLimited,
 	garbageCollected,
 	tweaked,
-	Image,
+	Image(..),
+	latestImage,
 	ContainerName,
 	Container,
 	HasImage(..),
 	-- * Container configuration
 	dns,
 	hostname,
+	Publishable,
 	publish,
 	expose,
 	user,
+	Mountable,
 	volume,
 	volumes_from,
 	workdir,
 	memory,
 	cpuShares,
 	link,
+	environment,
 	ContainerAlias,
 	restartAlways,
 	restartOnFailure,
@@ -43,12 +47,12 @@ module Propellor.Property.Docker (
 
 import Propellor hiding (init)
 import Propellor.Types.Docker
+import Propellor.Types.Container
 import Propellor.Types.CmdLine
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Cmd as Cmd
 import qualified Propellor.Shim as Shim
-import Utility.SafeCommand
 import Utility.Path
 import Utility.ThreadScheduler
 
@@ -152,8 +156,8 @@ docked ctr@(Container _ h) =
 imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo
 imageBuilt directory ctr = describe built msg
   where
-	msg = "docker image " ++ image ++ " built from " ++ directory
+	msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
-	built = Cmd.cmdProperty' dockercmd ["build", "--tag", image, "./"] workDir
+	built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
 	workDir p = p { cwd = Just directory }
 	image = getImageName ctr
 
@@ -161,8 +165,8 @@ imageBuilt directory ctr = describe built msg
 imagePulled :: HasImage c => c -> Property NoInfo
 imagePulled ctr = describe pulled msg
   where
-	msg = "docker image " ++ image ++ " pulled"
+	msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
-	pulled = Cmd.cmdProperty dockercmd ["pull", image]
+	pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
 	image = getImageName ctr
 
 propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
@@ -240,8 +244,52 @@ data ContainerInfo = ContainerInfo Image [RunParam]
 -- | Parameters to pass to `docker run` when creating a container.
 type RunParam = String
 
--- | A docker image, that can be used to run a container.
+-- | ImageID is an image identifier to perform action on images. An
-type Image = String
+-- ImageID can be the name of an container image, a UID, etc.
+--
+-- It just encapsulates a String to avoid the definition of a String
+-- instance of ImageIdentifier.
+newtype ImageID = ImageID String
+
+-- | Used to perform Docker action on an image.
+--
+-- Minimal complete definition: `imageIdentifier`
+class ImageIdentifier i where
+	-- | For internal purposes only.
+	toImageID :: i -> ImageID
+	toImageID = ImageID . imageIdentifier
+	-- | A string that Docker can use as an image identifier.
+	imageIdentifier :: i -> String
+
+instance ImageIdentifier ImageID where
+	imageIdentifier (ImageID i) = i
+	toImageID = id
+
+-- | A docker image, that can be used to run a container. The user has
+-- to specify a name and can provide an optional tag.
+-- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention>
+-- for more information.
+data Image = Image
+	{ repository :: String
+	, tag :: Maybe String
+	}
+	deriving (Eq, Read, Show)
+
+-- | Defines a Docker image without any tag. This is considered by
+-- Docker as the latest image of the provided repository.
+latestImage :: String -> Image
+latestImage repo = Image repo Nothing
+
+instance ImageIdentifier Image where
+	-- | The format of the imageIdentifier of an `Image` is:
+	-- repository | repository:tag
+	imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i)
+
+-- | The UID of an image. This UID is generated by Docker.
+newtype ImageUID = ImageUID String
+
+instance ImageIdentifier ImageUID where
+	imageIdentifier (ImageUID uid) = uid
 
 -- | Set custom dns server for container.
 dns :: String -> Property HasInfo
@@ -255,10 +303,19 @@ hostname = runProp "hostname"
 name :: String -> Property HasInfo
 name = runProp "name"
 
+class Publishable p where
+	toPublish :: p -> String
+
+instance Publishable (Bound Port) where
+	toPublish p = show (hostSide p) ++ ":" ++ show (containerSide p)
+
+-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
+instance Publishable String where
+	toPublish = id
+
 -- | Publish a container's port to the host
--- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
+publish :: Publishable p => p -> Property HasInfo
-publish :: String -> Property HasInfo
+publish = runProp "publish" . toPublish
-publish = runProp "publish"
 
 -- | Expose a container's port without publishing it.
 expose :: String -> Property HasInfo
@@ -268,11 +325,21 @@ expose = runProp "expose"
 user :: String -> Property HasInfo
 user = runProp "user"
 
--- | Mount a volume
+class Mountable p where
--- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
+	toMount :: p -> String
+
+instance Mountable (Bound FilePath) where
+	toMount p = hostSide p ++ ":" ++ containerSide p
+
+-- | string format: [host-dir]:[container-dir]:[rw|ro]
+--
 -- With just a directory, creates a volume in the container.
-volume :: String -> Property HasInfo
+instance Mountable String where
-volume = runProp "volume"
+	toMount = id
+
+-- | Mount a volume
+volume :: Mountable v => v -> Property HasInfo
+volume = runProp "volume" . toMount
 
 -- | Mount a volume from the specified container into the current
 -- container.
@@ -327,6 +394,11 @@ restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
 restartNever :: Property HasInfo
 restartNever = runProp "restart" "no"
 
+-- | Set environment variable with a tuple composed by the environment
+-- variable name and its value.
+environment :: (String, String) -> Property HasInfo
+environment (k, v) = runProp "env" $ k ++ "=" ++ v
+
 -- | A container is identified by its name, and the host
 -- on which it's deployed.
 data ContainerId = ContainerId 
@@ -397,7 +469,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		return FailedChange
 
 	restartcontainer = do
-		oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
+		oldimage <- liftIO $
+			fromMaybe (toImageID image) . fmap toImageID <$>
+				commitContainer cid
 		void $ liftIO $ removeContainer cid
 		go oldimage
 
@@ -426,16 +500,14 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 				retry (n-1) a
 			_ -> return v
 
-	go img = do
+	go img = liftIO $ do
-		liftIO $ do
+		clearProvisionedFlag cid
-			clearProvisionedFlag cid
+		createDirectoryIfMissing True (takeDirectory $ identFile cid)
-			createDirectoryIfMissing True (takeDirectory $ identFile cid)
+		shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
-		shim <- liftIO $ Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
+		writeFile (identFile cid) (show ident)
-		liftIO $ writeFile (identFile cid) (show ident)
+		toResult <$> runContainer img
-		ensureProperty $ property "run" $ liftIO $
+			(runps ++ ["-i", "-d", "-t"])
-			toResult <$> runContainer img
+			[shim, "--continue", show (DockerInit (fromContainerId cid))]
-				(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.
@@ -536,20 +608,20 @@ removeContainer :: ContainerId -> IO Bool
 removeContainer cid = catchBoolIO $
 	snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
 
-removeImage :: Image -> IO Bool
+removeImage :: ImageIdentifier i => i -> IO Bool
 removeImage image = catchBoolIO $
-	snd <$> processTranscript dockercmd ["rmi", image ] Nothing
+	snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing
 
-runContainer :: Image -> [RunParam] -> [String] -> IO Bool
+runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
 runContainer image ps cmd = boolSystem dockercmd $ map Param $
-	"run" : (ps ++ image : cmd)
+	"run" : (ps ++ (imageIdentifier image) : cmd)
 
 inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
 inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
 
-commitContainer :: ContainerId -> IO (Maybe Image)
+commitContainer :: ContainerId -> IO (Maybe ImageUID)
 commitContainer cid = catchMaybeIO $
-	takeWhile (/= '\n') 
+	ImageUID . takeWhile (/= '\n')
 		<$> readProcess dockercmd ["commit", fromContainerId cid]
 
 data ContainerFilter = RunningContainers | AllContainers
@@ -567,8 +639,8 @@ listContainers status =
 		| otherwise = baseps
 	baseps = ["ps", "--no-trunc"]
 
-listImages :: IO [Image]
+listImages :: IO [ImageUID]
-listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
+listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
 runProp :: String -> RunParam -> Property HasInfo
 runProp field val = pureInfoProperty (param) $ dockerInfo $

src/Propellor/Property/Firewall.hs

@@ -9,7 +9,6 @@ module Propellor.Property.Firewall (
 	Target(..),
 	Proto(..),
 	Rules(..),
-	Port,
 	ConnectionState(..)
 ) where
 
@@ -18,7 +17,6 @@ import Data.Char
 import Data.List
 
 import Propellor
-import Utility.SafeCommand
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Network as Network
 
@@ -46,8 +44,8 @@ toIpTable r =  map Param $
 toIpTableArg :: Rules -> [String]
 toIpTableArg Everything        = []
 toIpTableArg (Proto proto)     = ["-p", map toLower $ show proto]
-toIpTableArg (Port port)       = ["--dport", show port]
+toIpTableArg (DPort port)       = ["--dport", show port]
-toIpTableArg (PortRange (f,t)) = ["--dport", show f ++ ":" ++ show t]
+toIpTableArg (DPortRange (f,t)) = ["--dport", show f ++ ":" ++ show t]
 toIpTableArg (IFace iface)     = ["-i", iface]
 toIpTableArg (Ctstate states)  = ["-m", "conntrack","--ctstate", concat $ intersperse "," (map show states)]
 toIpTableArg (r :- r')         = toIpTableArg r <> toIpTableArg r'
@@ -56,33 +54,31 @@ data Rule = Rule
 	{ ruleChain :: Chain
 	, ruleTarget :: Target
 	, ruleRules :: Rules
-	} deriving (Eq, Show, Read)
+	} deriving (Eq, Show)
 
 data Chain = INPUT | OUTPUT | FORWARD
-	deriving (Eq,Show,Read)
+	deriving (Eq, Show)
 
 data Target = ACCEPT | REJECT | DROP | LOG
-	deriving (Eq,Show,Read)
+	deriving (Eq, Show)
 
 data Proto = TCP | UDP | ICMP
-	deriving (Eq,Show,Read)
+	deriving (Eq, Show)
-
-type Port = Int
 
 data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID
-	deriving (Eq,Show,Read)
+	deriving (Eq, Show)
 
 data Rules
 	= Everything
 	| Proto Proto
 	-- ^There is actually some order dependency between proto and port so this should be a specific
 	-- data type with proto + ports
-	| Port Port
+	| DPort Port
-	| PortRange (Port,Port)
+	| DPortRange (Port,Port)
 	| IFace Network.Interface
 	| Ctstate [ ConnectionState ]
 	| Rules :- Rules   -- ^Combine two rules
-	deriving (Eq,Show,Read)
+	deriving (Eq, Show)
 
 infixl 0 :-
 

src/Propellor/Property/Git.hs

@@ -4,7 +4,6 @@ import Propellor
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
-import Utility.SafeCommand
 
 import Data.List
 

src/Propellor/Property/Mount.hs

@@ -1,23 +1,33 @@
 module Propellor.Property.Mount where
 
 import Propellor
-import Utility.SafeCommand
+import Utility.Path
 
 type FsType = String
 type Source = String
 
+-- | Lists all mount points of the system.
 mountPoints :: IO [FilePath]
 mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
 
+-- | Finds all filesystems mounted inside the specified directory.
+mountPointsBelow :: FilePath -> IO [FilePath]
+mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
+	. filter (dirContains target)
+	<$> mountPoints
+
+-- | Filesystem type mounted at a given location.
 getFsType :: FilePath -> IO (Maybe FsType)
 getFsType mnt = catchDefaultIO Nothing $
 	headMaybe . lines
 		<$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]
 
+-- | Unmounts a device, lazily so any running processes don't block it.
 umountLazy :: FilePath -> IO ()
 umountLazy mnt =  
 	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
 		errorMessage $ "failed unmounting " ++ mnt
 
+-- | Mounts a device.
 mount :: FsType -> Source -> FilePath -> IO Bool
 mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]

src/Propellor/Property/OS.hs

@@ -16,7 +16,6 @@ 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)

src/Propellor/Property/Obnam.hs

@@ -4,7 +4,6 @@ import Propellor
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Cron as Cron
 import qualified Propellor.Property.Gpg as Gpg
-import Utility.SafeCommand
 
 import Data.List
 

src/Propellor/Property/Postfix.hs

@@ -22,10 +22,11 @@ reloaded :: Property NoInfo
 reloaded = Service.reloaded "postfix"
 
 -- | Configures postfix as a satellite system, which 
--- relays all mail through a relay host, which defaults to smtp.domain. 
+-- relays all mail through a relay host, which defaults to smtp.domain,
+-- but can be changed by @mainCf "relayhost"@.
 --
 -- The smarthost may refuse to relay mail on to other domains, without
--- futher coniguration/keys. But this should be enough to get cron job
+-- further configuration/keys. But this should be enough to get cron job
 -- mail flowing to a place where it will be seen.
 satellite :: Property NoInfo
 satellite = check (not <$> mainCfIsSet "relayhost") setup
@@ -34,14 +35,14 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
 	setup = trivial $ property "postfix satellite system" $ do
 		hn <- asks hostName
 		let (_, domain) = separate (== '.') hn
-		ensureProperties 
+		ensureProperties
 			[ Apt.reConfigure "postfix"
 				[ ("postfix/main_mailer_type", "select", "Satellite system")
 				, ("postfix/root_address", "string", "root")
 				, ("postfix/destinations", "string", "localhost")
 				, ("postfix/mailname", "string", hn)
 				]
-			, mainCf ("relayhost", domain)
+			, mainCf ("relayhost", "smtp." ++ domain)
 				`onChange` reloaded
 			]
 
@@ -57,7 +58,7 @@ mappedFile f setup = setup f
 	`onChange` cmdProperty "postmap" [f]
 
 -- | Run newaliases command, which should be done after changing
--- </etc/aliases>.
+-- @/etc/aliases@.
 newaliases :: Property NoInfo
 newaliases = trivial $ cmdProperty "newaliases" []
 
@@ -65,7 +66,7 @@ newaliases = trivial $ cmdProperty "newaliases" []
 mainCfFile :: FilePath
 mainCfFile = "/etc/postfix/main.cf"
 
--- | Sets a main.cf name=value pair. Does not reload postfix immediately.
+-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.
 mainCf :: (String, String) -> Property NoInfo
 mainCf (name, value) = check notset set
 		`describe` ("postfix main.cf " ++ setting)
@@ -74,7 +75,7 @@ mainCf (name, value) = check notset set
 	notset = (/= Just value) <$> getMainCf name
 	set = cmdProperty "postconf" ["-e", setting]
 
--- | Gets a man.cf setting.
+-- | Gets a main.cf setting.
 getMainCf :: String -> IO (Maybe String)
 getMainCf name = parse . lines <$> readProcess "postconf" [name]
   where
@@ -130,9 +131,9 @@ dedupCf ls =
 -- | Installs saslauthd and configures it for postfix, authenticating
 -- against PAM.
 --
--- Does not configure postfix to use it; eg smtpd_sasl_auth_enable = yes
+-- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@
 -- needs to be set to enable use. See
--- https://wiki.debian.org/PostfixAndSASL
+-- <https://wiki.debian.org/PostfixAndSASL>.
 saslAuthdInstalled :: Property NoInfo
 saslAuthdInstalled = setupdaemon
 	`requires` Service.running "saslauthd"

src/Propellor/Property/Reboot.hs

@@ -1,7 +1,6 @@
 module Propellor.Property.Reboot where
 
 import Propellor
-import Utility.SafeCommand
 
 now :: Property NoInfo
 now = cmdProperty "reboot" []

src/Propellor/Property/Service.hs

@@ -1,7 +1,6 @@
 module Propellor.Property.Service where
 
 import Propellor
-import Utility.SafeCommand
 
 type ServiceName = String
 

src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -6,9 +6,9 @@ import Propellor
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Cron as Cron
-import qualified Propellor.Property.Ssh as Ssh
 import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Docker as Docker
+import qualified Propellor.Property.Systemd as Systemd
+import qualified Propellor.Property.Chroot as Chroot
 import Propellor.Property.Cron (Times)
 
 builduser :: UserName
@@ -48,8 +48,6 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
 tree :: Architecture -> Property HasInfo
 tree buildarch = combineProperties "gitannexbuilder tree" $ props
 	& Apt.installed ["git"]
-	-- gitbuilderdir directory already exists when docker volume is used,
-	-- but with wrong owner.
 	& File.dirExists gitbuilderdir
 	& File.ownerGroup gitbuilderdir (User builduser) (Group builduser)
 	& gitannexbuildercloned
@@ -69,7 +67,6 @@ tree buildarch = combineProperties "gitannexbuilder tree" $ props
 buildDepsApt :: Property HasInfo
 buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
 	& Apt.buildDep ["git-annex"]
-	& Apt.installed ["liblockfile-simple-perl"]
 	& buildDepsNoHaskellLibs
 	& Apt.buildDepIn builddir
 		`describe` "git-annex source build deps installed"
@@ -84,6 +81,13 @@ buildDepsNoHaskellLibs = Apt.installed
 	"alex", "happy", "c2hs"
 	]
 
+haskellPkgsInstalled :: String -> Property NoInfo
+haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
+  where
+	go = userScriptProperty (User builduser)
+		[ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages"
+		]
+
 -- Installs current versions of git-annex's deps from cabal, but only
 -- does so once.
 cabalDeps :: Property NoInfo
@@ -92,46 +96,60 @@ cabalDeps = flagFile go cabalupdated
 		go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"]
 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
 
-standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
+autoBuilderContainer :: (System -> Property HasInfo) -> System -> Times -> TimeOut -> Systemd.Container
-standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
+autoBuilderContainer mkprop osver@(System _ arch) crontime timeout =
-	(dockerImage $ System (Debian Testing) arch)
+	Systemd.container name bootstrap
-	& os (System (Debian Testing) arch)
+		& mkprop osver
-	& Apt.stdSourcesList
+		& buildDepsApt
-	& Apt.installed ["systemd"]
+		& autobuilder arch crontime timeout
-	& Apt.unattendedUpgrades
+  where
-	& User.accountFor (User builduser)
+	name = arch ++ "-git-annex-builder"
-	& tree arch
+	bootstrap = Chroot.debootstrapped osver mempty
-	& buildDepsApt
-	& autobuilder arch (Cron.Times $ show buildminute ++ " * * * *") timeout
-	& Docker.tweaked
 
-androidAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container
+standardAutoBuilder :: System -> Property HasInfo
-androidAutoBuilderContainer dockerImage crontimes timeout =
+standardAutoBuilder osver@(System _ arch) =
-	androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
+	propertyList "standard git-annex autobuilder" $ props
+		& os osver
+		& Apt.stdSourcesList
+		& Apt.unattendedUpgrades
+		& User.accountFor (User builduser)
+		& tree arch
+
+armAutoBuilder :: System -> Times -> TimeOut -> Property HasInfo
+armAutoBuilder osver@(System _ arch) crontime timeout = 
+	propertyList "arm git-annex autobuilder" $ props
+		& standardAutoBuilder osver
+		& buildDepsNoHaskellLibs
+		-- Works around ghc crash with parallel builds on arm.
+		& (homedir </> ".cabal" </> "config")
+			`File.lacksLine` "jobs: $ncpus"
+		-- Install patched haskell packages for portability to
+		-- arm NAS's using old kernel versions.
+		& haskellPkgsInstalled "linux"
+		& autobuilder arch crontime timeout
+
+androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
+androidAutoBuilderContainer crontimes timeout =
+	androidContainer "android-git-annex-builder" (tree "android") builddir
 		& Apt.unattendedUpgrades
 		& autobuilder "android" crontimes timeout
 
 -- Android is cross-built in a Debian i386 container, using the Android NDK.
 androidContainer
 	:: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
-	=> (System -> Docker.Image)
+	=> Systemd.MachineName
-	-> Docker.ContainerName
 	-> Property i
 	-> FilePath
-	-> Docker.Container
+	-> Systemd.Container
-androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
+androidContainer name setupgitannexdir gitannexdir = Systemd.container name bootstrap
-	(dockerImage osver)
 	& os osver
 	& Apt.stdSourcesList
-	& Apt.installed ["systemd"]
-	& Docker.tweaked
 	& User.accountFor (User builduser)
 	& File.dirExists gitbuilderdir
 	& File.ownerGroup homedir (User builduser) (Group builduser)
-	& buildDepsApt
 	& flagFile chrootsetup ("/chrootsetup")
 		`requires` setupgitannexdir
-	& flagFile haskellpkgsinstalled ("/haskellpkgsinstalled")
+	& haskellPkgsInstalled "android"
   where
 	-- Use git-annex's android chroot setup script, which will install
 	-- ghc-android and the NDK, all build deps, etc, in the home
@@ -139,54 +157,5 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
 	chrootsetup = scriptProperty
 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
 		]
-	haskellpkgsinstalled = userScriptProperty (User builduser)
+	osver = System (Debian (Stable "jessie")) "i386"
-		[ "cd " ++ gitannexdir ++ " && ./standalone/android/install-haskell-packages"
+	bootstrap = Chroot.debootstrapped osver mempty
-		]
-	osver = System (Debian Testing) "i386"
-
--- armel builder has a companion container using amd64 that
--- runs the build first to get TH splices. They need
--- to have the same versions of all haskell libraries installed.
-armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
-armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
-	(dockerImage $ System (Debian Unstable) "amd64")
-	& os (System (Debian Testing) "amd64")
-	& Apt.stdSourcesList
-	& Apt.installed ["systemd"]
-	-- This volume is shared with the armel builder.
-	& Docker.volume gitbuilderdir
-	& User.accountFor (User builduser)
-	-- Install current versions of build deps from cabal.
-	& tree "armel"
-	& buildDepsNoHaskellLibs
-	& cabalDeps
-	-- The armel builder can ssh to this companion.
-	& Docker.expose "22"
-	& Apt.serviceInstalledRunning "ssh"
-	& Ssh.authorizedKeys (User builduser) (Context "armel-git-annex-builder")
-	& Docker.tweaked
-
-armelAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container
-armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
-	(dockerImage $ System (Debian Unstable) "armel")
-	& os (System (Debian Testing) "armel")
-	& Apt.stdSourcesList
-	& Apt.installed ["systemd"]
-	& Apt.installed ["openssh-client"]
-	& Docker.link "armel-git-annex-builder-companion" "companion"
-	& Docker.volumes_from "armel-git-annex-builder-companion"
-	& User.accountFor (User builduser)
-	-- TODO: automate installing haskell libs
-	-- (Currently have to run
-	-- git-annex/standalone/linux/install-haskell-packages
-	-- which is not fully automated.)
-	& buildDepsNoHaskellLibs
-	& autobuilder "armel" crontimes timeout
-		`requires` tree "armel"
-	& Ssh.keyImported SshRsa (User builduser) (Context "armel-git-annex-builder")
-	& trivial writecompanionaddress
-	& Docker.tweaked
-  where
-	writecompanionaddress = scriptProperty
-		[ "echo \"$COMPANION_PORT_22_TCP_ADDR\" > " ++ homedir </> "companion_address"
-		] `describe` "companion_address file"

src/Propellor/Property/SiteSpecific/GitHome.hs

@@ -3,7 +3,6 @@ module Propellor.Property.SiteSpecific.GitHome where
 import Propellor
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.User
-import Utility.SafeCommand
 
 -- | Clones Joey Hess's git home directory, and runs its fixups script.
 installedFor :: User -> Property NoInfo

src/Propellor/Property/SiteSpecific/IABak.hs

@@ -35,7 +35,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props
 	& Cron.niceJob "shardstats" (Cron.Times "*/30 * * * *") (User "root") "/"
 		"/usr/local/IA.BAK/shardstats-all"
 	& Cron.niceJob "shardmaint" Cron.Daily (User "root") "/"
-		"/usr/local/IA.BAK/shardmaint"
+		"/usr/local/IA.BAK/shardmaint-fast; /usr/local/IA.BAK/shardmaint"
 
 registrationServer :: [Host] -> Property HasInfo
 registrationServer knownhosts = propertyList "iabak registration server" $ props
@@ -64,14 +64,13 @@ graphiteServer = propertyList "iabak graphite server" $ props
 		, "pattern = ^carbon\\."
 		, "retentions = 60:90d"
 		, "[iabak-connections]"
-		, "pattern = ^iabak\.shardstats\.connections"
+		, "pattern = ^iabak\\.shardstats\\.connections"
 		, "retentions = 1h:1y,3h:10y"
-		, "[iabak]"
+		, "[iabak-default]"
 		, "pattern = ^iabak\\."
 		, "retentions = 10m:30d,1h:1y,3h:10y"
 		, "[default_1min_for_1day]"
 		, "pattern = .*"
-		, "retentions = 60s:1d"
 		]
 	& graphiteCSRF
 	& cmdProperty "graphite-manage" ["syncdb", "--noinput"] `flagFile` "/etc/flagFiles/graphite-syncdb"

src/Propellor/Property/SiteSpecific/JoeySites.hs

@@ -15,7 +15,6 @@ import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Apache as Apache
 import qualified Propellor.Property.Postfix as Postfix
-import Utility.SafeCommand
 import Utility.FileMode
 
 import Data.List
@@ -30,7 +29,6 @@ scrollBox = propertyList "scroll server" $ props
 		"libghc-bytestring-dev", "libghc-mtl-dev", "libghc-ncurses-dev",
 		"libghc-random-dev", "libghc-monad-loops-dev", "libghc-text-dev",
 		"libghc-ifelse-dev", "libghc-case-insensitive-dev",
-		"libghc-transformers-dev",
 		"libghc-data-default-dev", "libghc-optparse-applicative-dev"]
 	& userScriptProperty (User "scroll")
 		[ "cd " ++ d </> "scroll"
@@ -389,7 +387,7 @@ twitRss = combineProperties "twitter rss" $ props
 -- Work around for expired ssl cert.
 pumpRss :: Property NoInfo
 pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/"
-	"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
+	"wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
 
 ircBouncer :: Property HasInfo
 ircBouncer = propertyList "IRC bouncer" $ props
@@ -407,7 +405,7 @@ ircBouncer = propertyList "IRC bouncer" $ props
 
 kiteShellBox :: Property NoInfo
 kiteShellBox = propertyList "kitenet.net shellinabox"
-	[ Apt.installed ["openssl", "shellinabox"]
+	[ Apt.installed ["openssl", "shellinabox", "openssh-client"]
 	, File.hasContent "/etc/default/shellinabox"
 		[ "# Deployed by propellor"
 		, "SHELLINABOX_DAEMON_START=1"
@@ -861,6 +859,8 @@ legacyWebSites = propertyList "legacy web sites" $ props
 		, "  AllowOverride None"
 		, Apache.allowAll
 		, "</Directory>"
+		, "RewriteEngine On"
+		, "RewriteRule .* http://www.sowsearpoetry.org/ [L]"
 		]
 	& alias "wortroot.kitenet.net"
 	& alias "www.wortroot.kitenet.net"

src/Propellor/Property/Ssh.hs

@@ -1,7 +1,10 @@
 module Propellor.Property.Ssh (
 	PubKeyText,
 	sshdConfig,
+	ConfigKeyword,
+	setSshdConfigBool,
 	setSshdConfig,
+	RootLogin(..),
 	permitRootLogin,
 	passwordAuthentication,
 	noPasswords,
@@ -24,11 +27,11 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Service as Service
 import Propellor.Property.User
-import Utility.SafeCommand
 import Utility.FileMode
 
 import System.PosixCompat
 import qualified Data.Map as M
+import Data.List
 
 type PubKeyText = String
 
@@ -39,21 +42,37 @@ sshBool False = "no"
 sshdConfig :: FilePath
 sshdConfig = "/etc/ssh/sshd_config"
 
-setSshdConfig :: String -> Bool -> Property NoInfo
+type ConfigKeyword = String
-setSshdConfig setting allowed = combineProperties "sshd config"
-	[ sshdConfig `File.lacksLine` (sshline $ not allowed)
-	, sshdConfig `File.containsLine` (sshline allowed)
-	]
-	`onChange` restarted
-	`describe` unwords [ "ssh config:", setting, sshBool allowed ]
-  where
-	sshline v = setting ++ " " ++ sshBool v
 
-permitRootLogin :: Bool -> Property NoInfo
+setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo
-permitRootLogin = setSshdConfig "PermitRootLogin"
+setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
+
+setSshdConfig :: ConfigKeyword -> String -> Property NoInfo
+setSshdConfig setting val = File.fileProperty desc f sshdConfig
+	`onChange` restarted
+  where
+	desc = unwords [ "ssh config:", setting, val ]
+	cfgline = setting ++ " " ++ val
+	wantedline s
+		| s == cfgline = True
+		| (setting ++ " ") `isPrefixOf` s = False
+		| otherwise = True
+	f ls 
+		| cfgline `elem` ls = filter wantedline ls
+		| otherwise = filter wantedline ls ++ [cfgline]
+
+data RootLogin
+	= RootLogin Bool  -- ^ allow or prevent root login
+	| WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods
+	| ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key
+
+permitRootLogin :: RootLogin -> Property NoInfo
+permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b
+permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password"
+permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only"
 
 passwordAuthentication :: Bool -> Property NoInfo
-passwordAuthentication = setSshdConfig "PasswordAuthentication"
+passwordAuthentication = setSshdConfigBool "PasswordAuthentication"
 
 -- | Configure ssh to not allow password logins.
 --

src/Propellor/Property/Systemd.hs

@@ -1,31 +1,51 @@
+{-# LANGUAGE FlexibleInstances #-}
+
 module Propellor.Property.Systemd (
-	module Propellor.Property.Systemd.Core,
+	-- * Services
 	ServiceName,
-	MachineName,
 	started,
 	stopped,
 	enabled,
 	disabled,
+	masked,
+	running,
 	restarted,
-	persistentJournal,
+	networkd,
+	journald,
+	-- * Configuration
+	installed,
 	Option,
 	configured,
-	journaldConfigured,
 	daemonReloaded,
+	-- * Journal
+	persistentJournal,
+	journaldConfigured,
+	-- * Containers
+	MachineName,
 	Container,
 	container,
 	nspawned,
+	-- * Container configuration
 	containerCfg,
 	resolvConfed,
+	linkJournal,
+	privateNetwork,
+	module Propellor.Types.Container,
+	Proto(..),
+	Publishable,
+	publish,
+	Bindable,
+	bind,
+	bindRo,
 ) where
 
 import Propellor
 import Propellor.Types.Chroot
+import Propellor.Types.Container
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.File as File
 import Propellor.Property.Systemd.Core
-import Utility.SafeCommand
 import Utility.FileMode
 
 import Data.List
@@ -45,6 +65,9 @@ instance PropAccum Container where
 	getProperties (Container _ _ h) = hostProperties h
 
 -- | Starts a systemd service.
+--
+-- Note that this does not configure systemd to start the service on boot,
+-- it only ensures that the service is currently running.
 started :: ServiceName -> Property NoInfo
 started n = trivial $ cmdProperty "systemctl" ["start", n]
 	`describe` ("service " ++ n ++ " started")
@@ -55,6 +78,9 @@ stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
 	`describe` ("service " ++ n ++ " stopped")
 
 -- | Enables a systemd service.
+--
+-- This does not ensure the service is started, it only configures systemd
+-- to start it on boot.
 enabled :: ServiceName -> Property NoInfo
 enabled n = trivial $ cmdProperty "systemctl" ["enable", n]
 	`describe` ("service " ++ n ++ " enabled")
@@ -64,11 +90,32 @@ disabled :: ServiceName -> Property NoInfo
 disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
 	`describe` ("service " ++ n ++ " disabled")
 
+-- | Masks a systemd service.
+masked :: ServiceName -> RevertableProperty
+masked n = systemdMask <!> systemdUnmask
+  where
+	systemdMask   = trivial $ cmdProperty "systemctl" ["mask", n]
+	                `describe` ("service " ++ n ++ " masked")
+	systemdUnmask = trivial $ cmdProperty "systemctl" ["unmask", n]
+	                `describe` ("service " ++ n ++ " unmasked")
+
+-- | Ensures that a service is both enabled and started
+running :: ServiceName -> Property NoInfo
+running n = trivial $ started n `requires` enabled n
+
 -- | Restarts a systemd service.
 restarted :: ServiceName -> Property NoInfo
 restarted n = trivial $ cmdProperty "systemctl" ["restart", n]
 	`describe` ("service " ++ n ++ " restarted")
 
+-- | The systemd-networkd service.
+networkd :: ServiceName
+networkd = "systemd-networkd"
+
+-- | The systemd-journald service.
+journald :: ServiceName
+journald = "systemd-journald"
+
 -- | Enables persistent storage of the journal.
 persistentJournal :: Property NoInfo
 persistentJournal = check (not <$> doesDirectoryExist dir) $ 
@@ -87,7 +134,8 @@ type Option = String
 -- Does not ensure that the relevant daemon notices the change immediately.
 --
 -- This assumes that there is only one [Header] per file, which is
--- currently the case. And it assumes the file already exists with
+-- currently the case for files like journald.conf and system.conf. 
+-- And it assumes the file already exists with
 -- the right [Header], so new lines can just be appended to the end.
 configured :: FilePath -> Option -> String -> Property NoInfo
 configured cfgfile option value = combineProperties desc
@@ -102,15 +150,15 @@ configured cfgfile option value = combineProperties desc
 		| setting `isPrefixOf` l = Nothing
 		| otherwise = Just l
 
+-- | Causes systemd to reload its configuration files.
+daemonReloaded :: Property NoInfo
+daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
+
 -- | Configures journald, restarting it so the changes take effect.
 journaldConfigured :: Option -> String -> Property NoInfo
 journaldConfigured option value =
 	configured "/etc/systemd/journald.conf" option value
-		`onChange` restarted "systemd-journald"
+		`onChange` restarted journald
-
--- | Causes systemd to reload its configuration files.
-daemonReloaded :: Property NoInfo
-daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
 
 -- | Defines a container with a given machine name.
 --
@@ -123,6 +171,7 @@ container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
 container name mkchroot = Container name c h
 	& os system
 	& resolvConfed
+	& linkJournal
   where
 	c@(Chroot.Chroot _ system _ _) = mkchroot (containerDir name)
 	h = Host name [] mempty
@@ -153,8 +202,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
 	-- Chroot provisioning is run in systemd-only mode,
 	-- which sets up the chroot and ensures systemd and dbus are
 	-- installed, but does not handle the other provisions.
-	chrootprovisioned = Chroot.provisioned'
+	chrootprovisioned = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) chroot True
-		(Chroot.propigateChrootInfo chroot) chroot True
 
 	-- Use nsenter to enter container and and run propellor to
 	-- finish provisioning.
@@ -178,8 +226,14 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
 		return $ unlines $
 			"# deployed by propellor" : map addparams ls
 	addparams l
-		| "ExecStart=" `isPrefixOf` l =
+		| "ExecStart=" `isPrefixOf` l = unwords $
-			l ++ " " ++ unwords (nspawnServiceParams cfg)
+			[ "ExecStart = /usr/bin/systemd-nspawn"
+			, "--quiet"
+			, "--keep-unit"
+			, "--boot"
+			, "--directory=" ++ containerDir name
+			, "--machine=%i"
+			] ++ nspawnServiceParams cfg
 		| otherwise = l
 	
 	goodservicefile = (==)
@@ -216,15 +270,19 @@ enterScript c@(Container name _ _) = setup <!> teardown
   where
 	setup = combineProperties ("generated " ++ enterScriptFile c)
 		[ scriptfile `File.hasContent`
-			[ "#!/bin/sh"
+			[ "#!/usr/bin/perl"
 			, "# Generated by propellor"
-			, "pid=\"$(machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2)\" || true"
+			, "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;"
-			, "if [ -n \"$pid\" ]; then"
+			, "chomp $pid;"
-			, "\tnsenter -p -u -n -i -m -t \"$pid\" \"$@\""
+			, "if (length $pid) {"
-			, "else"
+			, "\tforeach my $var (keys %ENV) {"
-			, "\techo container not running >&2"
+			, "\t\tdelete $ENV{$var} unless $var eq 'PATH' || $var eq 'TERM';"
-			, "\texit 1"
+			, "\t}"
-			, "fi"
+			, "\texec('nsenter', '-p', '-u', '-n', '-i', '-m', '-t', $pid, @ARGV);"
+			, "} else {"
+			, "\tdie 'container not running';"
+			, "}"
+			, "exit(1);"
 			]
 		, scriptfile `File.mode` combineModes (readModes ++ executeModes)
 		]
@@ -234,8 +292,8 @@ enterScript c@(Container name _ _) = setup <!> teardown
 enterScriptFile :: Container -> FilePath
 enterScriptFile (Container name _ _ ) = "/usr/local/bin/enter-" ++ mungename name
 
-enterContainerProcess :: Container -> [String] -> CreateProcess
+enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ())
-enterContainerProcess = proc . enterScriptFile
+enterContainerProcess c ps = pure (proc (enterScriptFile c) ps, noop)
 
 nspawnServiceName :: MachineName -> ServiceName
 nspawnServiceName name = "systemd-nspawn@" ++ name ++ ".service"
@@ -267,3 +325,68 @@ containerCfg p = RevertableProperty (mk True) (mk False)
 -- This property is enabled by default. Revert it to disable it.
 resolvConfed :: RevertableProperty
 resolvConfed = containerCfg "bind=/etc/resolv.conf"
+
+-- | Link the container's journal to the host's if possible.
+-- (Only works if the host has persistent journal enabled.)
+--
+-- This property is enabled by default. Revert it to disable it.
+linkJournal :: RevertableProperty
+linkJournal = containerCfg "link-journal=try-guest"
+
+-- | Disconnect networking of the container from the host.
+privateNetwork :: RevertableProperty
+privateNetwork = containerCfg "private-network"
+
+class Publishable a where
+	toPublish :: a -> String
+
+instance Publishable Port where
+	toPublish (Port n) = show n
+
+instance Publishable (Bound Port) where
+	toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v)
+
+data Proto = TCP | UDP
+
+instance Publishable (Proto, Bound Port) where
+	toPublish (TCP, fp) = "tcp:" ++ toPublish fp
+	toPublish (UDP, fp) = "udp:" ++ toPublish fp
+
+-- | Publish a port from the container to the host.
+-- 
+-- This feature was first added in systemd version 220.
+--
+-- This property is only needed (and will only work) if the container
+-- is configured to use private networking. Also, networkd should be enabled
+-- both inside the container, and on the host. For example:
+--
+-- > foo :: Host
+-- > foo = host "foo.example.com"
+-- >	& Systemd.running Systemd.networkd
+-- >	& Systemd.nspawned webserver
+-- >
+-- > webserver :: Systemd.container
+-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty)
+-- >	& Systemd.privateNetwork
+-- >	& Systemd.running Systemd.networkd
+-- >	& Systemd.publish (Port 80 ->- Port 8080)
+-- >	& Apt.installedRunning "apache2"
+publish :: Publishable p => p -> RevertableProperty
+publish p = containerCfg $ "--port=" ++ toPublish p
+
+class Bindable a where
+	toBind :: a -> String
+
+instance Bindable FilePath where
+	toBind f = f
+
+instance Bindable (Bound FilePath) where
+	toBind v = hostSide v ++ ":" ++ containerSide v
+
+-- | Bind mount a file or directory from the host into the container.
+bind :: Bindable p => p -> RevertableProperty
+bind p = containerCfg $ "--bind=" ++ toBind p
+
+-- | Read-only mind mount.
+bindRo :: Bindable p => p -> RevertableProperty
+bindRo p = containerCfg $ "--bind-ro=" ++ toBind p

src/Propellor/Property/Tor.hs

@@ -103,13 +103,8 @@ bandwidthRate' s divby = case readSize dataUnits s of
 	Nothing -> property ("unable to parse " ++ s) noChange
 
 hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
-hiddenServiceAvailable hn port = hiddenServiceHostName prop
+hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
   where
-	prop = configured
-		[ ("HiddenServiceDir", varLib </> hn)
-		, ("HiddenServicePort", unwords [show port, "127.0.0.1:" ++ show port])
-		]
-		`describe` "hidden service available"
 	hiddenServiceHostName p =  adjustPropertySatisfy p $ \satisfy -> do
 		r <- satisfy
 		h <- liftIO $ readFile (varLib </> hn </> "hostname")
@@ -164,7 +159,7 @@ type NickName = String
 
 -- | Convert String to a valid tor NickName.
 saneNickname :: String -> NickName
-saneNickname s 
+saneNickname s
 	| null n = "unnamed"
 	| otherwise = n
   where

src/Propellor/Shim.hs

@@ -8,7 +8,6 @@ module Propellor.Shim (setup, cleanEnv, file) where
 
 import Propellor
 import Utility.LinuxMkLibs
-import Utility.SafeCommand
 import Utility.FileMode
 import Utility.FileSystemEncoding
 
@@ -21,7 +20,7 @@ import System.Posix.Files
 -- 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
+setup propellorbin propellorbinpath dest = checkAlreadyShimmed shim $ do
 	createDirectoryIfMissing True dest
 
 	libs <- parseLdd <$> readProcess "ldd" [propellorbin]
@@ -40,7 +39,6 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
 		fromMaybe (error "cannot find gconv directory") $
 			headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs
 	let linkerparams = ["--library-path", intercalate ":" libdirs ]
-	let shim = file propellorbin dest
 	writeFile shim $ unlines
 		[ shebang
 		, "GCONV_PATH=" ++ shellEscape gconvdir
@@ -50,6 +48,8 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
 		]
 	modifyFileMode shim (addModes executeModes)
 	return shim
+  where
+	shim = file propellorbin dest
 
 shebang :: String
 shebang = "#!/bin/sh"

src/Propellor/Spin.hs

@@ -14,8 +14,7 @@ import System.Posix.Directory
 import Control.Concurrent.Async
 import qualified Data.ByteString as B
 import qualified Data.Set as S
-import qualified Network.BSD as BSD
+import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
-import Network.Socket (inet_ntoa)
 
 import Propellor
 import Propellor.Protocol
@@ -98,17 +97,21 @@ spin target relay hst = do
 getSshTarget :: HostName -> Host -> IO String
 getSshTarget target hst
 	| null configips = return target
-	| otherwise = go =<< tryIO (BSD.getHostByName target)
+	| otherwise = go =<< tryIO (dnslookup target)
   where
 	go (Left e) = useip (show e)
-	go (Right hostentry) = ifM (anyM matchingconfig (BSD.hostAddresses hostentry))
+	go (Right addrinfos) = do
-		( return target
+		configaddrinfos <- catMaybes <$> mapM iptoaddr configips
-		, do
+		if any (`elem` configaddrinfos) (map addrAddress addrinfos)
-			ips <- mapM inet_ntoa (BSD.hostAddresses hostentry)
+			then return target
-			useip ("DNS " ++ show ips ++ " vs configured " ++ show configips)
+			else useip ("DNS lookup did not return any of the expected addresses " ++ show configips)
-		)
 
-	matchingconfig a = flip elem configips <$> inet_ntoa a
+	dnslookup h = getAddrInfo (Just $ defaultHints { addrFlags = [AI_CANONNAME] }) (Just h) Nothing
+
+	-- Convert a string containing an IP address into a SockAddr.
+	iptoaddr :: String -> IO (Maybe SockAddr)
+	iptoaddr ip = catchDefaultIO Nothing $ headMaybe . map addrAddress
+		<$> getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST] })  (Just ip) Nothing
 
 	useip why = case headMaybe configips of
 		Nothing -> return target
@@ -144,11 +147,15 @@ update forhost = do
 			hout <- dup stdOutput
 			hClose stdin
 			hClose stdout
+			-- Not using git pull because git 2.5.0 badly
+			-- broke its option parser.
 			unlessM (boolSystem "git" (pullparams hin hout)) $
-				errorMessage "git pull from client failed"
+				errorMessage "git fetch from client failed"
+			unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $
+				errorMessage "git merge from client failed"
   where
 	pullparams hin hout =
-		[ Param "pull"
+		[ Param "fetch"
 		, Param "--progress"
 		, Param "--upload-pack"
 		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout

src/Propellor/Ssh.hs

@@ -1,7 +1,6 @@
 module Propellor.Ssh where
 
 import Propellor
-import Utility.SafeCommand
 import Utility.UserInfo
 
 import System.PosixCompat
@@ -23,7 +22,8 @@ sshCachingParams hn = do
 	let ps =
 		[ Param "-o"
 		, Param ("ControlPath=" ++ socketfile)
-		, Params "-o ControlMaster=auto -o ControlPersist=yes"
+		, Param "-o", Param "ControlMaster=auto"
+		, Param "-o", Param "ControlPersist=yes"
 		]
 
 	maybe noop (expireold ps socketfile)
@@ -38,7 +38,7 @@ sshCachingParams hn = do
 			then touchFile f
 			else do
 				void $ boolSystem "ssh" $
-					[ Params "-O stop" ] ++ ps ++
+					[ Param "-O", Param "stop" ] ++ ps ++
 					[ Param "localhost" ]
 				nukeFile f
 	tenminutes = 600

src/Propellor/Types/CmdLine.hs

@@ -10,6 +10,7 @@ data CmdLine
 	| Spin [HostName] (Maybe HostName)
 	| SimpleRun HostName
 	| Set PrivDataField Context
+	| Unset PrivDataField Context
 	| Dump PrivDataField Context
 	| Edit PrivDataField Context
 	| ListFields

src/Propellor/Types/Container.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Propellor.Types.Container where
+
+-- | A value that can be bound between the host and a container.
+--
+-- For example, a Bound Port is a Port on the container that is bound to
+-- a Port on the host.
+data Bound v = Bound
+	{ hostSide :: v
+	, containerSide :: v
+	}
+
+-- | Create a Bound value, from two different values for the host and
+-- container.
+--
+-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host
+-- is bound to port 80 from the container.
+(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v
+(-<-) hostv containerv = Bound hostv containerv
+
+-- | Flipped version of -<- with the container value first and host value
+-- second.
+(->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v
+(->-) containerv hostv = Bound hostv containerv
+
+-- | Create a Bound value, that is the same on both the host and container.
+same :: v -> Bound v
+same v = Bound v v
+

src/Propellor/Types/OS.hs

@@ -10,6 +10,7 @@ module Propellor.Types.OS (
 	User(..),
 	Group(..),
 	userGroup,
+	Port(..),
 ) where
 
 import Network.BSD (HostName)
@@ -42,3 +43,6 @@ newtype Group = Group String
 -- | Makes a Group with the same name as the User.
 userGroup :: User -> Group
 userGroup (User u) = Group u
+
+newtype Port = Port Int
+	deriving (Eq, Show)

src/Utility/Data.hs

@@ -5,6 +5,8 @@
  - License: BSD-2-clause
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Utility.Data where
 
 {- First item in the list that is not Nothing. -}

src/Utility/Directory.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Directory where
 
@@ -18,6 +19,7 @@ import Control.Applicative
 import Control.Concurrent
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Data.Maybe
+import Prelude
 
 #ifdef mingw32_HOST_OS
 import qualified System.Win32 as Win32

src/Utility/Env.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Env where
 
@@ -13,6 +14,7 @@ module Utility.Env where
 import Utility.Exception
 import Control.Applicative
 import Data.Maybe
+import Prelude
 import qualified System.Environment as E
 import qualified System.SetEnv
 #else

src/Utility/Exception.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Exception (
 	module X,

src/Utility/FileMode.hs

@@ -22,15 +22,12 @@ import Utility.Exception
 
 {- Applies a conversion function to a file's mode. -}
 modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
-modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode f convert = do
-modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
-modifyFileMode' f convert = do
 	s <- getFileStatus f
 	let old = fileMode s
 	let new = convert old
 	when (new /= old) $
 		setFileMode f new
-	return old
 
 {- Adds the specified FileModes to the input mode, leaving the rest
  - unchanged. -}
@@ -41,14 +38,6 @@ addModes ms m = combineModes (m:ms)
 removeModes :: [FileMode] -> FileMode -> FileMode
 removeModes ms m = m `intersectFileModes` complement (combineModes ms)
 
-{- Runs an action after changing a file's mode, then restores the old mode. -}
-withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
-withModifiedFileMode file convert a = bracket setup cleanup go
-  where
-	setup = modifyFileMode' file convert
-	cleanup oldmode = modifyFileMode file (const oldmode)
-	go _ = a
-
 writeModes :: [FileMode]
 writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
 

src/Utility/FileSystemEncoding.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.FileSystemEncoding (
 	fileEncoding,

src/Utility/LinuxMkLibs.hs

@@ -7,7 +7,12 @@
 
 module Utility.LinuxMkLibs where
 
-import Control.Applicative
+import Utility.PartialPrelude
+import Utility.Directory
+import Utility.Process
+import Utility.Monad
+import Utility.Path
+
 import Data.Maybe
 import System.Directory
 import System.FilePath
@@ -15,12 +20,8 @@ import Data.List.Utils
 import System.Posix.Files
 import Data.Char
 import Control.Monad.IfElse
-
+import Control.Applicative
-import Utility.PartialPrelude
+import Prelude
-import Utility.Directory
-import Utility.Process
-import Utility.Monad
-import Utility.Path
 
 {- Installs a library. If the library is a symlink to another file,
  - install the file it links to, and update the symlink to be relative. -}

src/Utility/Misc.hs

@@ -6,23 +6,25 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Misc where
 
+import Utility.FileSystemEncoding
+import Utility.Monad
+
 import System.IO
 import Control.Monad
 import Foreign
 import Data.Char
 import Data.List
-import Control.Applicative
 import System.Exit
 #ifndef mingw32_HOST_OS
 import System.Posix.Process (getAnyProcessStatus)
 import Utility.Exception
 #endif
-
+import Control.Applicative
-import Utility.FileSystemEncoding
+import Prelude
-import Utility.Monad
 
 {- A version of hgetContents that is not lazy. Ensures file is 
  - all read before it gets closed. -}

src/Utility/Monad.hs

@@ -5,6 +5,8 @@
  - License: BSD-2-clause
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Utility.Monad where
 
 import Data.Maybe

src/Utility/PartialPrelude.hs

@@ -5,6 +5,8 @@
  - them being accidentially used.
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Utility.PartialPrelude where
 
 import qualified Data.Maybe

src/Utility/Path.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE PackageImports, CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Path where
 
@@ -16,6 +17,7 @@ import Data.List
 import Data.Maybe
 import Data.Char
 import Control.Applicative
+import Prelude
 
 #ifdef mingw32_HOST_OS
 import qualified System.FilePath.Posix as Posix

src/Utility/PosixFiles.hs

@@ -8,6 +8,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.PosixFiles (
 	module X,

src/Utility/Process.hs

@@ -1,12 +1,13 @@
 {- System.Process enhancements, including additional ways of running
  - processes, and logging.
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Process (
 	module X,
@@ -54,6 +55,7 @@ import qualified System.Posix.IO
 import Control.Applicative
 #endif
 import Data.Maybe
+import Prelude
 
 import Utility.Misc
 import Utility.Exception
@@ -63,8 +65,8 @@ type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Hand
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
 
-{- Normally, when reading from a process, it does not need to be fed any
+-- | Normally, when reading from a process, it does not need to be fed any
- - standard input. -}
+-- standard input.
 readProcess :: FilePath	-> [String] -> IO String
 readProcess cmd args = readProcessEnv cmd args Nothing
 
@@ -82,9 +84,8 @@ readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
 	hClose h
 	return output
 
-{- Runs an action to write to a process on its stdin, 
+-- | Runs an action to write to a process on its stdin, 
- - returns its output, and also allows specifying the environment.
+-- returns its output, and also allows specifying the environment.
- -}
 writeReadProcessEnv
 	:: FilePath
 	-> [String]
@@ -124,8 +125,8 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
 		, env = environ
 		}
 
-{- Waits for a ProcessHandle, and throws an IOError if the process
+-- | Waits for a ProcessHandle, and throws an IOError if the process
- - did not exit successfully. -}
+-- did not exit successfully.
 forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
 forceSuccessProcess p pid = do
 	code <- waitForProcess pid
@@ -133,10 +134,10 @@ forceSuccessProcess p pid = do
 		ExitSuccess -> return ()
 		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
 
-{- Waits for a ProcessHandle and returns True if it exited successfully.
+-- | Waits for a ProcessHandle and returns True if it exited successfully.
- - Note that using this with createProcessChecked will throw away
+-- Note that using this with createProcessChecked will throw away
- - the Bool, and is only useful to ignore the exit code of a process,
+-- the Bool, and is only useful to ignore the exit code of a process,
- - while still waiting for it. -}
+-- while still waiting for it. -}
 checkSuccessProcess :: ProcessHandle -> IO Bool
 checkSuccessProcess pid = do
 	code <- waitForProcess pid
@@ -147,13 +148,13 @@ ignoreFailureProcess pid = do
 	void $ waitForProcess pid
 	return True
 
-{- Runs createProcess, then an action on its handles, and then
+-- | Runs createProcess, then an action on its handles, and then
- - forceSuccessProcess. -}
+-- forceSuccessProcess.
 createProcessSuccess :: CreateProcessRunner
 createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
 
-{- Runs createProcess, then an action on its handles, and then
+-- | Runs createProcess, then an action on its handles, and then
- - a checker action on its exit code, which must wait for the process. -}
+-- a checker action on its exit code, which must wait for the process.
 createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
 createProcessChecked checker p a = do
 	t@(_, _, _, pid) <- createProcess p
@@ -161,14 +162,14 @@ createProcessChecked checker p a = do
 	_ <- checker pid
 	either E.throw return r
 
-{- Leaves the process running, suitable for lazy streaming.
+-- | Leaves the process running, suitable for lazy streaming.
- - Note: Zombies will result, and must be waited on. -}
+-- Note: Zombies will result, and must be waited on.
 createBackgroundProcess :: CreateProcessRunner
 createBackgroundProcess p a = a =<< createProcess p
 
-{- Runs a process, optionally feeding it some input, and
+-- | Runs a process, optionally feeding it some input, and
- - returns a transcript combining its stdout and stderr, and
+-- returns a transcript combining its stdout and stderr, and
- - whether it succeeded or failed. -}
+-- whether it succeeded or failed.
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
 processTranscript cmd opts input = processTranscript' cmd opts Nothing input
 
@@ -232,9 +233,9 @@ processTranscript' cmd opts environ input = do
 		hClose inh
 	writeinput Nothing _ = return ()
 
-{- Runs a CreateProcessRunner, on a CreateProcess structure, that
+-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
- - is adjusted to pipe only from/to a single StdHandle, and passes
+-- is adjusted to pipe only from/to a single StdHandle, and passes
- - the resulting Handle to an action. -}
+-- the resulting Handle to an action.
 withHandle
 	:: StdHandle
 	-> CreateProcessRunner
@@ -256,7 +257,7 @@ withHandle h creator p a = creator p' $ a . select
 		| h == StderrHandle =
 			(stderrHandle, base { std_err = CreatePipe })
 
-{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+-- | Like withHandle, but passes (stdin, stdout) handles to the action.
 withIOHandles
 	:: CreateProcessRunner
 	-> CreateProcess
@@ -270,7 +271,7 @@ withIOHandles creator p a = creator p' $ a . ioHandles
 		, std_err = Inherit
 		}
 
-{- Like withHandle, but passes (stdout, stderr) handles to the action. -}
+-- | Like withHandle, but passes (stdout, stderr) handles to the action.
 withOEHandles
 	:: CreateProcessRunner
 	-> CreateProcess
@@ -284,8 +285,8 @@ withOEHandles creator p a = creator p' $ a . oeHandles
 		, std_err = CreatePipe
 		}
 
-{- Forces the CreateProcessRunner to run quietly;
+-- | Forces the CreateProcessRunner to run quietly;
- - both stdout and stderr are discarded. -}
+-- both stdout and stderr are discarded.
 withQuietOutput
 	:: CreateProcessRunner
 	-> CreateProcess
@@ -297,8 +298,8 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
 		}
 	creator p' $ const $ return ()
 
-{- Stdout and stderr are discarded, while the process is fed stdin
+-- | Stdout and stderr are discarded, while the process is fed stdin
- - from the handle. -}
+-- from the handle.
 feedWithQuietOutput
 	:: CreateProcessRunner
 	-> CreateProcess
@@ -319,11 +320,11 @@ devNull = "/dev/null"
 devNull = "NUL"
 #endif
 
-{- Extract a desired handle from createProcess's tuple.
+-- | Extract a desired handle from createProcess's tuple.
- - These partial functions are safe as long as createProcess is run
+-- These partial functions are safe as long as createProcess is run
- - with appropriate parameters to set up the desired handle.
+-- with appropriate parameters to set up the desired handle.
- - Get it wrong and the runtime crash will always happen, so should be
+-- Get it wrong and the runtime crash will always happen, so should be
- - easily noticed. -}
+-- easily noticed.
 type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
 stdinHandle :: HandleExtractor
 stdinHandle (Just h, _, _, _) = h
@@ -344,7 +345,7 @@ oeHandles _ = error "expected oeHandles"
 processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
 processHandle (_, _, _, pid) = pid
 
-{- Debugging trace for a CreateProcess. -}
+-- | Debugging trace for a CreateProcess.
 debugProcess :: CreateProcess -> IO ()
 debugProcess p = do
 	debugM "Utility.Process" $ unwords
@@ -360,15 +361,15 @@ debugProcess p = do
 	piped Inherit = False
 	piped _ = True
 
-{- Shows the command that a CreateProcess will run. -}
+-- | Shows the command that a CreateProcess will run.
 showCmd :: CreateProcess -> String
 showCmd = go . cmdspec
   where
 	go (ShellCommand s) = s
 	go (RawCommand c ps) = c ++ " " ++ show ps
 
-{- Starts an interactive process. Unlike runInteractiveProcess in
+-- | Starts an interactive process. Unlike runInteractiveProcess in
- - System.Process, stderr is inherited. -}
+-- System.Process, stderr is inherited.
 startInteractiveProcess
 	:: FilePath
 	-> [String]
@@ -384,7 +385,8 @@ startInteractiveProcess cmd args environ = do
 	(Just from, Just to, _, pid) <- createProcess p
 	return (pid, to, from)
 
-{- Wrapper around System.Process function that does debug logging. -}
+-- | Wrapper around 'System.Process.createProcess' from System.Process,
+-- that does debug logging.
 createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 createProcess p = do
 	debugProcess p

src/Utility/QuickCheck.hs

@@ -19,6 +19,7 @@ import System.Posix.Types
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Control.Applicative
+import Prelude
 
 instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
 	arbitrary = M.fromList <$> arbitrary

src/Utility/SafeCommand.hs

@@ -5,44 +5,45 @@
  - License: BSD-2-clause
  -}
 
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
 module Utility.SafeCommand where
 
 import System.Exit
 import Utility.Process
 import Data.String.Utils
-import Control.Applicative
 import System.FilePath
 import Data.Char
+import Control.Applicative
+import Prelude
 
-{- A type for parameters passed to a shell command. A command can
+-- | Parameters that can be passed to a shell command.
- - be passed either some Params (multiple parameters can be included,
+data CommandParam
- - whitespace-separated, or a single Param (for when parameters contain
+	= Param String -- ^ A parameter
- - whitespace), or a File.
+	| File FilePath -- ^ The name of a file
- -}
-data CommandParam = Params String | Param String | File FilePath
 	deriving (Eq, Show, Ord)
 
-{- Used to pass a list of CommandParams to a function that runs
+-- | Used to pass a list of CommandParams to a function that runs
- - a command and expects Strings. -}
+-- a command and expects Strings. -}
 toCommand :: [CommandParam] -> [String]
-toCommand = concatMap unwrap
+toCommand = map unwrap
   where
-	unwrap (Param s) = [s]
+	unwrap (Param s) = s
-	unwrap (Params s) = filter (not . null) (split " " s)
 	-- Files that start with a non-alphanumeric that is not a path
 	-- separator are modified to avoid the command interpreting them as
 	-- options or other special constructs.
 	unwrap (File s@(h:_))
-		| isAlphaNum h || h `elem` pathseps = [s]
+		| isAlphaNum h || h `elem` pathseps = s
-		| otherwise = ["./" ++ s]
+		| otherwise = "./" ++ s
-	unwrap (File s) = [s]
+	unwrap (File s) = s
 	-- '/' is explicitly included because it's an alternative
 	-- path separator on Windows.
 	pathseps = pathSeparator:"./"
 
-{- Run a system command, and returns True or False
+-- | Run a system command, and returns True or False if it succeeded or failed.
- - if it succeeded or failed.
+--
- -}
+-- This and other command running functions in this module log the commands
+-- run at debug level, using System.Log.Logger.
 boolSystem :: FilePath -> [CommandParam] -> IO Bool
 boolSystem command params = boolSystem' command params id
 
@@ -56,7 +57,7 @@ boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bo
 boolSystemEnv command params environ = boolSystem' command params $
 	\p -> p { env = environ }
 
-{- Runs a system command, returning the exit status. -}
+-- | Runs a system command, returning the exit status.
 safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
 safeSystem command params = safeSystem' command params id
 
@@ -71,23 +72,22 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex
 safeSystemEnv command params environ = safeSystem' command params $ 
 	\p -> p { env = environ }
 
-{- Wraps a shell command line inside sh -c, allowing it to be run in a
+-- | Wraps a shell command line inside sh -c, allowing it to be run in a
- - login shell that may not support POSIX shell, eg csh. -}
+-- login shell that may not support POSIX shell, eg csh.
 shellWrap :: String -> String
 shellWrap cmdline = "sh -c " ++ shellEscape cmdline
 
-{- Escapes a filename or other parameter to be safely able to be exposed to
+-- | Escapes a filename or other parameter to be safely able to be exposed to
- - the shell.
+-- the shell.
- -
+--
- - This method works for POSIX shells, as well as other shells like csh.
+-- This method works for POSIX shells, as well as other shells like csh.
- -}
 shellEscape :: String -> String
 shellEscape f = "'" ++ escaped ++ "'"
   where
 	-- replace ' with '"'"'
 	escaped = join "'\"'\"'" $ split "'" f
 
-{- Unescapes a set of shellEscaped words or filenames. -}
+-- | Unescapes a set of shellEscaped words or filenames.
 shellUnEscape :: String -> [String]
 shellUnEscape [] = []
 shellUnEscape s = word : shellUnEscape rest
@@ -104,19 +104,19 @@ shellUnEscape s = word : shellUnEscape rest
 		| c == q = findword w cs
 		| otherwise = inquote q (w++[c]) cs
 
-{- For quickcheck. -}
+-- | For quickcheck.
 prop_idempotent_shellEscape :: String -> Bool
 prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
 prop_idempotent_shellEscape_multiword :: [String] -> Bool
 prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
 
-{- Segments a list of filenames into groups that are all below the maximum
+-- | Segments a list of filenames into groups that are all below the maximum
- - command-line length limit. -}
+--  command-line length limit.
 segmentXargsOrdered :: [FilePath] -> [[FilePath]]
 segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
 
-{- Not preserving data is a little faster, and streams better when
+-- | Not preserving order is a little faster, and streams better when
- - there are a great many filesnames. -}
+-- there are a great many filenames.
 segmentXargsUnordered :: [FilePath] -> [[FilePath]]
 segmentXargsUnordered l = go l [] 0 []
   where

src/Utility/Scheduled.hs

@@ -32,7 +32,6 @@ import Utility.QuickCheck
 import Utility.PartialPrelude
 import Utility.Misc
 
-import Control.Applicative
 import Data.List
 import Data.Time.Clock
 import Data.Time.LocalTime
@@ -41,6 +40,8 @@ import Data.Time.Calendar.WeekDate
 import Data.Time.Calendar.OrdinalDate
 import Data.Tuple.Utils
 import Data.Char
+import Control.Applicative
+import Prelude
 
 {- Some sort of scheduled event. -}
 data Schedule = Schedule Recurrance ScheduledTime

src/Utility/Tmp.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Tmp where
 

src/Utility/UserInfo.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.UserInfo (
 	myHomeDir,
@@ -13,12 +14,13 @@ module Utility.UserInfo (
 	myUserGecos,
 ) where
 
+import Utility.Env
+
 import System.PosixCompat
 #ifndef mingw32_HOST_OS
 import Control.Applicative
 #endif
-
+import Prelude
-import Utility.Env
 
 {- Current user's home directory.
  -