another try at unmounting /proc for systemd-nspawn

src/Propellor/Property/Chroot.hs

@@ -16,10 +16,10 @@ import Propellor
 import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
 import Propellor.Property.Chroot.Util
-import Propellor.Property.Mount
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Systemd.Core as Systemd
 import qualified Propellor.Shim as Shim
+import Propellor.Property.Mount
 
 import qualified Data.Map as M
 import Data.List.Utils
@@ -70,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
@@ -95,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] -> IO 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"
@@ -123,14 +123,16 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 		parenthost <- asks hostName
 		cmd <- liftIO $ toChain parenthost c systemdonly
 		pe <- liftIO standardPathEnv
-		p <- liftIO $ 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
@@ -157,17 +159,23 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 			putStrLn $ "\n" ++ show r
 chain _ _ = errorMessage "bad chain command"
 
-inChrootProcess :: Chroot -> [String] -> IO CreateProcess
+inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess (Chroot loc _ _ _) cmd = do
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
 	mountproc
-	return $ proc "chroot" (loc:cmd)
+	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/Systemd.hs

@@ -39,7 +39,6 @@ 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 Propellor.Property.Mount
 import Utility.FileMode
 
 import Data.List
@@ -168,19 +167,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 = 
+	chrootprovisioned = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) chroot True
-		(toProp provisioner `onChange` umountProc)
-		<!>
-		(toProp (revert provisioner))
-	provisioner = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) chroot True
-
-	-- The chroot's /proc is left mounted by the chroot provisioning,
-	-- but that will prevent systemd-nspawn from starting systemd in
-	-- it, so unmount.
-	umountProc = check (elem procloc <$> mountPointsBelow loc) $
-		property (procloc ++ " unmounted") $  do
-			makeChange $ umountLazy procloc
-	procloc = loc </> "proc"
 
 	-- Use nsenter to enter container and and run propellor to
 	-- finish provisioning.
@@ -269,8 +256,8 @@ enterScript c@(Container name _ _) = setup <!> teardown
 enterScriptFile :: Container -> FilePath
 enterScriptFile (Container name _ _ ) = "/usr/local/bin/enter-" ++ mungename name
 
-enterContainerProcess :: Container -> [String] -> IO CreateProcess
+enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ())
-enterContainerProcess c ps = pure $ proc (enterScriptFile c) ps
+enterContainerProcess c ps = pure (proc (enterScriptFile c) ps, noop)
 
 nspawnServiceName :: MachineName -> ServiceName
 nspawnServiceName name = "systemd-nspawn@" ++ name ++ ".service"
@@ -338,8 +325,9 @@ instance Publishable PortSpec where
 
 -- | Publish a port from the container on the host.
 --
--- Note that this will only work if the container's network is set up
+-- Note that this will only work if the container is set up to use
--- by other properties.
+-- private networking. If the container does not use private networking,
+-- this property is not needed.
 --
 -- This feature was first added in systemd version 220.
 publish :: Publishable p => p -> RevertableProperty