summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Chroot.hs
diff options
context:
space:
mode:
authorJoey Hess2014-11-20 15:15:28 -0400
committerJoey Hess2014-11-20 15:15:28 -0400
commita4f04fcb02d76d9903c5bbc65827565bad6c2d8c (patch)
treeda5e6584ca447a0091b2001bae3d9033095b5339 /src/Propellor/Property/Chroot.hs
parent4d155864fadb5571d788ed645c842ad853f55d71 (diff)
propellor spin
Diffstat (limited to 'src/Propellor/Property/Chroot.hs')
-rw-r--r--src/Propellor/Property/Chroot.hs76
1 files changed, 73 insertions, 3 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