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

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

1 files changed, 27 insertions, 10 deletions

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e56cb6ed..ded108bc 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/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
--- that any processes that might be running inside the chroot are stopped.
+-- Reverting this property removes the chroot. Anything mounted inside it
+-- 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 (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd)
+inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
+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"