propellor spin

propellor.cabal

@@ -121,7 +121,7 @@ Library
     Propellor.Ssh
     Propellor.PrivData.Paths
     Propellor.Protocol
-    Propellor.Property.Docker.Shim
+    Propellor.Shim
     Utility.Applicative
     Utility.Data
     Utility.Directory

src/Propellor/CmdLine.hs

@@ -15,7 +15,8 @@ import Propellor.Git
 import Propellor.Ssh
 import Propellor.Server
 import qualified Propellor.Property.Docker as Docker
-import qualified Propellor.Property.Docker.Shim as DockerShim
+import qualified Propellor.Property.Chroot as Chroot
+import qualified Propellor.Shim as Shim
 import Utility.SafeCommand
 
 usage :: Handle -> IO ()
@@ -72,7 +73,7 @@ processCmdLine = go =<< getArgs
 -- | Runs propellor on hosts, as controlled by command-line options.
 defaultMain :: [Host] -> IO ()
 defaultMain hostlist = do
-	DockerShim.cleanEnv
+	Shim.cleanEnv
 	checkDebugMode
 	cmdline <- processCmdLine
 	debug ["command line: ", show cmdline]
@@ -85,6 +86,7 @@ defaultMain hostlist = do
 	go _ ListFields = listPrivDataFields hostlist
 	go _ (AddKey keyid) = addKey keyid
 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
+	go _ (ChrootChain hn loc) = Chroot.chain hostlist hn loc
 	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout
 	go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)

src/Propellor/Engine.hs

@@ -11,12 +11,15 @@ import "mtl" Control.Monad.Reader
 import Control.Exception (bracket)
 import System.PosixCompat
 import System.Posix.IO
+import Data.Maybe
 
 import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info
 import Utility.Exception
+import Utility.PartialPrelude
+import Utility.Monad
 
 runPropellor :: Host -> Propellor a -> IO a
 runPropellor host a = runReaderT (runWithHost a) host
@@ -62,3 +65,18 @@ onlyProcess lockfile a = bracket lock unlock (const a)
 		return l
 	unlock = closeFd
 	alreadyrunning = error "Propellor is already running on this host!"
+
+-- | Reads and displays each line from the Handle, except for the last line
+-- which is a Result.
+processChainOutput :: Handle -> IO Result
+processChainOutput h = go Nothing
+  where
+	go lastline = do
+		v <- catchMaybeIO (hGetLine h)
+		case v of
+			Nothing -> pure $ fromMaybe FailedChange $
+				readish =<< lastline
+			Just s -> do
+				maybe noop putStrLn lastline
+				hFlush stdout
+				go (Just s)

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

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)

src/Propellor/Shim.hs

@@ -1,9 +1,10 @@
--- | Support for running propellor, as built outside a docker container,
--- inside the container.
+-- | Support for running propellor, as built outside a container,
+-- inside the container, without needing to install anything into the
+-- container.
 --
 -- Note: This is currently Debian specific, due to glibcLibs.
 
-module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where
+module Propellor.Shim (setup, cleanEnv, file) where
 
 import Propellor
 import Utility.LinuxMkLibs

src/Propellor/Types.hs

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