From a4f04fcb02d76d9903c5bbc65827565bad6c2d8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 20 Nov 2014 15:15:28 -0400 Subject: propellor spin --- src/Propellor/Property/Chroot.hs | 76 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 73 insertions(+), 3 deletions(-) (limited to 'src/Propellor/Property/Chroot.hs') 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 -- cgit v1.2.3