summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
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
parent4d155864fadb5571d788ed645c842ad853f55d71 (diff)
propellor spin
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Chroot.hs76
-rw-r--r--src/Propellor/Property/Docker.hs14
-rw-r--r--src/Propellor/Property/Docker/Shim.hs61
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