propellor spin

propellor.cabal

@@ -96,6 +96,7 @@ Library
     Propellor.Property.Ssh
     Propellor.Property.Sudo
     Propellor.Property.Systemd
+    Propellor.Property.Systemd.Core
     Propellor.Property.Tor
     Propellor.Property.User
     Propellor.Property.HostingProvider.CloudAtCost

src/Propellor/CmdLine.hs

@@ -85,7 +85,7 @@ defaultMain hostlist = do
 	go _ (Edit field context) = editPrivData field context
 	go _ ListFields = listPrivDataFields hostlist
 	go _ (AddKey keyid) = addKey keyid
-	go _ (ChrootChain hn loc onconsole) = Chroot.chain hostlist hn loc onconsole
+	go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c
 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
 	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout

src/Propellor/Property/Chroot.hs

@@ -11,6 +11,7 @@ module Propellor.Property.Chroot (
 
 import Propellor
 import qualified Propellor.Property.Debootstrap as Debootstrap
+import qualified Propellor.Property.Systemd.Core as Systemd
 import qualified Propellor.Shim as Shim
 import Utility.SafeCommand
 
@@ -52,16 +53,17 @@ debootstrapped system conf location = case system of
 -- Reverting this property removes the chroot. 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
+provisioned c = provisioned' (propigateChrootInfo c) c False
 
-provisioned' :: (Property -> Property) -> Chroot -> RevertableProperty
-provisioned' propigator c@(Chroot loc system builderconf _) = RevertableProperty
+provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty
+provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty
 	(propigator $ go "exists" setup)
 	(go "removed" teardown)
   where
 	go desc a = property (chrootDesc c desc) $ ensureProperties [a]
 
-	setup = propellChroot c (inChrootProcess c) `requires` toProp built
+	setup = propellChroot c (inChrootProcess c) systemdonly
+		`requires` toProp built
 	
 	built = case (system, builderconf) of
 		((System (Debian _) _), UsingDeboostrap cf) -> debootstrap cf
@@ -79,8 +81,8 @@ 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) -> Property
-propellChroot c@(Chroot loc _ _ _) mkproc = property (chrootDesc c "provisioned") $ do
+propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property
+propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
 	let d = localdir </> shimdir c
 	let me = localdir </> "propellor"
 	shim <- liftIO $ ifM (doesDirectoryExist d)
@@ -105,7 +107,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc = property (chrootDesc c "provisioned"
 	
 	chainprovision shim = do
 		parenthost <- asks hostName
-		cmd <- liftIO $ toChain parenthost c
+		cmd <- liftIO $ toChain parenthost c systemdonly
 		let p = mkproc
 			[ shim
 			, "--continue"
@@ -114,24 +116,29 @@ propellChroot c@(Chroot loc _ _ _) mkproc = property (chrootDesc c "provisioned"
 		liftIO $ withHandle StdoutHandle createProcessSuccess p
 			processChainOutput
 
-toChain :: HostName -> Chroot -> IO CmdLine
-toChain parenthost (Chroot loc _ _ _) = do
+toChain :: HostName -> Chroot -> Bool -> IO CmdLine
+toChain parenthost (Chroot loc _ _ _) systemdonly = do
 	onconsole <- isConsole <$> mkMessageHandle
-	return $ ChrootChain parenthost loc onconsole
+	return $ ChrootChain parenthost loc systemdonly onconsole
 
-chain :: [Host] -> HostName -> FilePath -> Bool -> IO ()
-chain hostlist hn loc onconsole = case findHostNoAlias hostlist hn of
-	Nothing -> errorMessage ("cannot find host " ++ hn)
-	Just parenthost -> case M.lookup loc (_chroots $ _chrootinfo $ hostInfo parenthost) of
-		Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
-		Just h -> go h
+chain :: [Host] -> CmdLine -> IO ()
+chain hostlist (ChrootChain hn loc systemdonly onconsole) = 
+	case findHostNoAlias hostlist hn of
+		Nothing -> errorMessage ("cannot find host " ++ hn)
+		Just parenthost -> case M.lookup loc (_chroots $ _chrootinfo $ hostInfo parenthost) of
+			Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
+			Just h -> go h
   where
 	go h = do
 		changeWorkingDirectory localdir
 		when onconsole forceConsole
 		onlyProcess (provisioningLock loc) $ do
-			r <- runPropellor h $ ensureProperties $ hostProperties h
+			r <- runPropellor h $ ensureProperties $
+				if systemdonly
+					then [Systemd.installed]
+					else hostProperties h
 			putStrLn $ "\n" ++ show r
+chain _ _ = errorMessage "bad chain command"
 
 inChrootProcess :: Chroot -> [String] -> CreateProcess
 inChrootProcess (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd)

src/Propellor/Property/Systemd.hs

@@ -1,5 +1,5 @@
 module Propellor.Property.Systemd (
-	installed,
+	module Propellor.Property.Systemd.Core,
 	started,
 	stopped,
 	enabled,
@@ -14,6 +14,7 @@ import Propellor
 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
 
@@ -30,12 +31,6 @@ instance Hostlike Container where
         (Container n c h) &^ p = Container n c (h &^ p)
         getHost (Container _ _ h) = h
 
--- dbus is only a Recommends of systemd, but is needed for communication
--- from the systemd inside a container to the one outside, so make sure it
--- gets installed.
-installed :: Property
-installed = Apt.installed ["systemd", "dbus"]
-
 -- | Starts a systemd service.
 started :: ServiceName -> Property
 started n = trivial $ cmdProperty "systemctl" ["start", n]
@@ -110,20 +105,18 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
 		, nspawnService c
 		]
 
-	-- When provisioning the chroot, pass a version of the Host
-	-- that only has the Property of systemd being installed.
-	-- This is to avoid starting any daemons in the chroot,
-	-- which would not run in the container's namespace.
-	chrootprovisioned = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) $
-		mkChroot $ h { hostProperties = [installed] }
+	-- Chroot provisioning is run in systemd-only mode,
+	-- which sets up the chroot and ensures systemd and dbus are
+	-- installed, but does not handle the other provisions.
+	chrootprovisioned = Chroot.provisioned'
+		(Chroot.propigateChrootInfo chroot) chroot True
 
 	-- Use nsenter to enter container and and run propellor to
 	-- finish provisioning.
 	containerprovisioned = Chroot.propellChroot chroot
-		(enterContainerProcess c)
+		(enterContainerProcess c) False
 
-	mkChroot = Chroot.Chroot loc system builderconf
-	chroot = mkChroot h
+	chroot = Chroot.Chroot loc system builderconf h
 
 nspawnService :: Container -> RevertableProperty
 nspawnService (Container name _ _) = RevertableProperty setup teardown

src/Propellor/Property/Systemd/Core.hs

@@ -0,0 +1,10 @@
+module Propellor.Property.Systemd.Core where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+
+-- dbus is only a Recommends of systemd, but is needed for communication
+-- from the systemd inside a container to the one outside, so make sure it
+-- gets installed.
+installed :: Property
+installed = Apt.installed ["systemd", "dbus"]

src/Propellor/Types.hs

@@ -155,7 +155,7 @@ data CmdLine
 	| Update HostName
 	| DockerInit HostName
 	| DockerChain HostName String
-	| ChrootChain HostName FilePath Bool
+	| ChrootChain HostName FilePath Bool Bool
 	| GitPush Fd Fd
 	deriving (Read, Show, Eq)