propellor spin

3 files changed, 75 insertions, 76 deletions

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e5046937..38e09b52 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -2,12 +2,17 @@ module Propellor.Property.Chroot (
 	Chroot,
 	chroot,
 	provisioned,
+	chain,
 ) where
 
 import Propellor
 import qualified Propellor.Property.Debootstrap as Debootstrap
+import qualified Propellor.Shim as Shim
+import Utility.SafeCommand
 
 import qualified Data.Map as M
+import Data.List.Utils
+import System.Posix.Directory
 
 data Chroot = Chroot FilePath System Host
 
@@ -35,8 +40,7 @@ provisioned c@(Chroot loc system _) = RevertableProperty
 	(propigateChrootInfo c (go "exists" setup))
 	(go "removed" teardown)
   where
-	go desc a = property ("chroot " ++ loc ++ " " ++ desc) $ do
-		ensureProperties [a]
+	go desc a = property (chrootDesc c desc) $ ensureProperties [a]
 
 	setup = provisionChroot c `requires` built
 	
@@ -53,5 +57,71 @@ propigateChrootInfo c@(Chroot loc _ h) p = propigateInfo c p (<> chrootinfo)
   where
 	chrootinfo = mempty $ mempty { _chroots = M.singleton loc h }
 
+-- | Propellor is run inside the chroot to provision it.
+--
+-- Strange and wonderful tricks let the host's /usr/local/propellor
+-- be used inside the chroot, without needing to install anything.
 provisionChroot :: Chroot -> Property
-provisionChroot = undefined
+provisionChroot c@(Chroot loc _ _) = property (chrootDesc c "provisioned") $ do
+	let d = localdir </> shimdir c
+	let me = localdir </> "propellor"
+	shim <- liftIO $ ifM (doesDirectoryExist d)
+		( pure (Shim.file me d)
+		, Shim.setup me d
+		)
+	ifM (liftIO $ bindmount shim)
+		( chainprovision shim
+		, return FailedChange
+		)
+  where
+	bindmount shim = ifM (doesFileExist (loc ++ shim))
+		( return True
+		, do
+			let mntpnt = loc ++ localdir
+			createDirectoryIfMissing True mntpnt
+			boolSystem "mount"
+				[ Param "--bind"
+				, File localdir, File mntpnt
+				]
+		)
+	
+	chainprovision shim = do
+		parenthost <- asks hostName
+		let p = inChrootProcess c
+			[ shim
+			, "--continue"
+			, show $ toChain parenthost c
+			]
+		liftIO $ withHandle StdoutHandle createProcessSuccess p
+			processChainOutput
+
+toChain :: HostName -> Chroot -> CmdLine
+toChain parenthost (Chroot loc _ _) = ChrootChain parenthost loc
+
+chain :: [Host] -> HostName -> FilePath -> IO ()
+chain hostlist hn loc = 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
+		onlyProcess (provisioningLock loc) $ do
+			r <- runPropellor h $ ensureProperties $ hostProperties h
+			putStrLn $ "\n" ++ show r
+
+inChrootProcess :: Chroot -> [String] -> CreateProcess
+inChrootProcess (Chroot loc _ _) cmd = proc "chroot" (loc:cmd)
+
+provisioningLock :: FilePath -> FilePath
+provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
+
+shimdir :: Chroot -> FilePath
+shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim"
+
+mungeloc :: FilePath -> String
+mungeloc = replace "/" "_"
+
+chrootDesc :: Chroot -> String -> String
+chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 92cc124a..5cf60ff9 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -41,7 +41,7 @@ module Propellor.Property.Docker (
 import Propellor hiding (init)
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Docker.Shim as Shim
+import qualified Propellor.Shim as Shim
 import Utility.SafeCommand
 import Utility.Path
 import Utility.ThreadScheduler
@@ -432,20 +432,10 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
 		[ if isConsole msgh then "-it" else "-i" ]
 		(shim : params)
 	r <- withHandle StdoutHandle createProcessSuccess p $
-		processoutput Nothing
+		processChainOutput
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
-  where
-	processoutput lastline h = do
-		v <- catchMaybeIO (hGetLine h)
-		case v of
-			Nothing -> pure $ fromMaybe FailedChange $
-				readish =<< lastline
-			Just s -> do
-				maybe noop putStrLn lastline
-				hFlush stdout
-				processoutput (Just s) h
 
 toChain :: ContainerId -> CmdLine
 toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
diff --git a/src/Propellor/Property/Docker/Shim.hs b/src/Propellor/Property/Docker/Shim.hs
deleted file mode 100644
index c2f35d0c..00000000
--- a/src/Propellor/Property/Docker/Shim.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | Support for running propellor, as built outside a docker container,
--- inside the container.
---
--- Note: This is currently Debian specific, due to glibcLibs.
-
-module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where
-
-import Propellor
-import Utility.LinuxMkLibs
-import Utility.SafeCommand
-import Utility.Path
-import Utility.FileMode
-
-import Data.List
-import System.Posix.Files
-
--- | Sets up a shimmed version of the program, in a directory, and
--- returns its path.
-setup :: FilePath -> FilePath -> IO FilePath
-setup propellorbin dest = do
-	createDirectoryIfMissing True dest
-
-	libs <- parseLdd <$> readProcess "ldd" [propellorbin]
-	glibclibs <- glibcLibs
-	let libs' = nub $ libs ++ glibclibs
-	libdirs <- map (dest ++) . nub . catMaybes
-		<$> mapM (installLib installFile dest) libs'
-	
-	let linker = (dest ++) $ 
-		fromMaybe (error "cannot find ld-linux linker") $
-			headMaybe $ filter ("ld-linux" `isInfixOf`) libs'
-	let gconvdir = (dest ++) $ parentDir $
-		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
-		[ "#!/bin/sh"
-		, "GCONV_PATH=" ++ shellEscape gconvdir
-		, "export GCONV_PATH"
-		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ 
-			" " ++ shellEscape propellorbin ++ " \"$@\""
-		]
-	modifyFileMode shim (addModes executeModes)
-	return shim
-
-cleanEnv :: IO ()
-cleanEnv = void $ unsetEnv "GCONV_PATH"
-
-file :: FilePath -> FilePath -> FilePath
-file propellorbin dest = dest </> takeFileName propellorbin
-
-installFile :: FilePath -> FilePath -> IO ()
-installFile top f = do
-	createDirectoryIfMissing True destdir
-	nukeFile dest
-	createLink f dest `catchIO` (const copy)
-  where
-	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]
-	destdir = inTop top $ parentDir f
-	dest = inTop top f