Merge branch 'joeyconfig'

5 files changed, 141 insertions, 19 deletions

diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 21772b34..f2f5af55 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -77,7 +77,6 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
 		, "libghc-ansi-terminal-dev"
 		, "libghc-ifelse-dev"
 		, "libghc-network-dev"
-		, "libghc-quickcheck2-dev"
 		, "libghc-mtl-dev"
 		, "libghc-transformers-dev"
 		, "libghc-exceptions-dev"
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 8d1a2388..30c11ed3 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -8,6 +8,7 @@ module Propellor.Property.Chroot (
 	ChrootBootstrapper(..),
 	Debootstrapped(..),
 	ChrootTarball(..),
+	noServices,
 	inChroot,
 	-- * Internal use
 	provisioned',
@@ -27,6 +28,7 @@ import qualified Propellor.Property.Systemd.Core as Systemd
 import qualified Propellor.Property.File as File
 import qualified Propellor.Shim as Shim
 import Propellor.Property.Mount
+import Utility.FileMode
 
 import qualified Data.Map as M
 import Data.List.Utils
@@ -247,6 +249,24 @@ mungeloc = replace "/" "_"
 chrootDesc :: Chroot -> String -> String
 chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
 
+-- | Adding this property to a chroot prevents daemons and other services
+-- from being started, which is often something you want to prevent when
+-- building a chroot.
+--
+-- This is accomplished by installing a </usr/sbin/policy-rc.d> script
+-- that does not let any daemons be started by packages that use
+-- invoke-rc.d. Reverting the property removes the script.
+noServices :: RevertableProperty NoInfo
+noServices = setup <!> teardown
+  where
+	f = "/usr/sbin/policy-rc.d"
+	script = [ "#!/bin/sh", "exit 101" ]
+	setup = combineProperties "no services started"
+		[ File.hasContent f script
+		, File.mode f (combineModes (readModes ++ executeModes))
+		]
+	teardown = File.notPresent f
+
 -- | Check if propellor is currently running within a chroot.
 --
 -- This allows properties to check and avoid performing actions that
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index 6f1ff7b2..468cca32 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -1,10 +1,22 @@
 -- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
 
 module Propellor.Property.DebianMirror
-	( DebianPriority(..)
+	( DebianPriority (..)
 	, showPriority
 	, mirror
-	, mirrorCdn
+	, RsyncExtra (..)
+	, Method (..)
+	, DebianMirror
+	, debianMirrorHostName
+	, debianMirrorSuites
+	, debianMirrorArchitectures
+	, debianMirrorSections
+	, debianMirrorSourceBool
+	, debianMirrorPriorities
+	, debianMirrorMethod
+	, debianMirrorKeyring
+	, debianMirrorRsyncExtra
+	, mkDebianMirror
 	) where
 
 import Propellor.Base
@@ -27,8 +39,88 @@ showPriority Standard  = "standard"
 showPriority Optional  = "optional"
 showPriority Extra     = "extra"
 
-mirror :: Apt.Url -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo
-mirror url dir suites archs sections source priorities crontimes = propertyList
+data RsyncExtra = Doc | Indices | Tools | Trace
+	deriving (Show, Eq)
+
+showRsyncExtra :: RsyncExtra -> String
+showRsyncExtra Doc = "doc"
+showRsyncExtra Indices = "indices"
+showRsyncExtra Tools = "tools"
+showRsyncExtra Trace = "trace"
+
+data Method = Ftp | Http | Https | Rsync | MirrorFile
+
+showMethod :: Method -> String
+showMethod Ftp = "ftp"
+showMethod Http = "http"
+showMethod Https = "https"
+showMethod Rsync = "rsync"
+showMethod MirrorFile = "file"
+
+-- | To get a new DebianMirror and set options, use:
+--
+-- > mkDebianMirror mymirrordir mycrontimes
+-- > 	. debianMirrorHostName "otherhostname"
+-- > 	. debianMirrorSourceBool True
+
+data DebianMirror = DebianMirror
+	{ _debianMirrorHostName :: HostName
+	, _debianMirrorDir :: FilePath
+	, _debianMirrorSuites :: [DebianSuite]
+	, _debianMirrorArchitectures :: [Architecture]
+	, _debianMirrorSections :: [Apt.Section]
+	, _debianMirrorSourceBool :: Bool
+	, _debianMirrorPriorities :: [DebianPriority]
+	, _debianMirrorMethod :: Method
+	, _debianMirrorKeyring :: FilePath
+	, _debianMirrorRsyncExtra :: [RsyncExtra]
+	, _debianMirrorCronTimes :: Cron.Times
+	}
+
+mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror
+mkDebianMirror dir crontimes = DebianMirror
+	{ _debianMirrorHostName = "httpredir.debian.org"
+	, _debianMirrorDir = dir
+	, _debianMirrorSuites = []
+	, _debianMirrorArchitectures = []
+	, _debianMirrorSections = []
+	, _debianMirrorSourceBool = False
+	, _debianMirrorPriorities = []
+	, _debianMirrorMethod = Http
+	, _debianMirrorKeyring = "/usr/share/keyrings/debian-archive-keyring.gpg"
+	, _debianMirrorRsyncExtra = [Trace]
+	, _debianMirrorCronTimes = crontimes
+	}
+
+debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror
+debianMirrorHostName hn m = m { _debianMirrorHostName = hn }
+
+debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror
+debianMirrorSuites s m = m { _debianMirrorSuites = s }
+
+debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror
+debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a }
+
+debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror
+debianMirrorSections s m = m { _debianMirrorSections = s }
+
+debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror
+debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s }
+
+debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror
+debianMirrorPriorities p m = m { _debianMirrorPriorities = p }
+
+debianMirrorMethod :: Method -> DebianMirror -> DebianMirror
+debianMirrorMethod me m = m { _debianMirrorMethod = me }
+
+debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror
+debianMirrorKeyring k m = m { _debianMirrorKeyring = k }
+
+debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
+debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r }
+
+mirror :: DebianMirror -> Property NoInfo
+mirror mirror' = propertyList
 	("Debian mirror " ++ dir)
 	[ Apt.installed ["debmirror"]
 	, User.accountFor (User "debmirror")
@@ -36,28 +128,30 @@ mirror url dir suites archs sections source priorities crontimes = propertyList
 	, File.ownerGroup dir (User "debmirror") (Group "debmirror")
 	, check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args
 		`describe` "debmirror setup"
-	, Cron.niceJob ("debmirror_" ++ dir) crontimes (User "debmirror") "/" $
+	, Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $
 		unwords ("/usr/bin/debmirror" : args)
 	]
   where
+	dir = _debianMirrorDir mirror'
+	suites = _debianMirrorSuites mirror'
 	suitemirrored suite = doesDirectoryExist $ dir </> "dists" </> Apt.showSuite suite
 	architecturearg = intercalate ","
 	suitearg = intercalate "," $ map Apt.showSuite suites
 	priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")"
+	rsyncextraarg [] = "none"
+	rsyncextraarg res = intercalate "," $ map showRsyncExtra res
 	args =
 		[ "--dist" , suitearg
-		, "--arch", architecturearg archs
-		, "--section", intercalate "," sections
-		, "--limit-priority", "\"" ++ priorityRegex priorities ++ "\""
+		, "--arch", architecturearg $ _debianMirrorArchitectures mirror'
+		, "--section", intercalate "," $ _debianMirrorSections mirror'
+		, "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\""
 		]
 		++
-		(if source then [] else ["--nosource"])
+		(if _debianMirrorSourceBool mirror' then [] else ["--nosource"])
 		++
-		[ "--host", url
-		, "--method", "http"
-		, "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg"
+		[ "--host", _debianMirrorHostName mirror'
+		, "--method", showMethod $ _debianMirrorMethod mirror'
+		, "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror'
+		, "--keyring", _debianMirrorKeyring mirror'
 		, dir
 		]
-
-mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo
-mirrorCdn = mirror "http://httpredir.debian.org/debian"
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 5b8619ba..4878c365 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,8 +1,6 @@
 -- | Disk image generation. 
 --
 -- This module is designed to be imported unqualified.
---
--- TODO avoid starting services while populating chroot and running final
 
 module Propellor.Property.DiskImage (
 	-- * Partition specification
@@ -69,6 +67,11 @@ type DiskImage = FilePath
 -- Note that the disk image file is reused if it already exists,
 -- to avoid expensive IO to generate a new one. And, it's updated in-place,
 -- so its contents are undefined during the build process.
+--
+-- Note that the `Chroot.noServices` property is automatically added to the
+-- chroot while the disk image is being built, which should prevent any
+-- daemons that are included from being started on the system that is
+-- building the disk image.
 imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
 imageBuilt = imageBuilt' False
 
@@ -93,6 +96,9 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
 		| otherwise = doNothing
 	chrootdir = img ++ ".chroot"
 	chroot = mkchroot chrootdir
+		-- Before ensuring any other properties of the chroot, avoid
+		-- starting services. Reverted by imageFinalized.
+		&^ Chroot.noServices
 		-- First stage finalization.
 		& fst final
 		-- Avoid wasting disk image space on the apt cache
@@ -227,6 +233,7 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
 	go top = do
 		liftIO $ mountall top
 		liftIO $ writefstab top
+		liftIO $ allowservices top
 		ensureProperty $ final top devs
 	
 	-- Ordered lexographically by mount point, so / comes before /usr
@@ -260,6 +267,8 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
 	-- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"
 	unconfigured s = "UNCONFIGURED" `isInfixOf` s
 
+	allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
+
 noFinalization :: Finalization
 noFinalization = (doNothing, \_ _ -> doNothing)
 
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index fa24786c..3d2fbf14 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -23,7 +23,7 @@ module Propellor.Types
 	, propertyDesc
 	, propertyChildren
 	, RevertableProperty(..)
-	, (<!>)
+	, MkRevertableProperty(..)
 	, IsProp(..)
 	, Combines(..)
 	, CombinedType