summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Chroot.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Chroot.hs')
-rw-r--r--src/Propellor/Property/Chroot.hs122
1 files changed, 89 insertions, 33 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index cb693a73..9e8bcd2f 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -4,12 +4,14 @@ module Propellor.Property.Chroot (
debootstrapped,
bootstrapped,
provisioned,
+ hostChroot,
Chroot(..),
ChrootBootstrapper(..),
Debootstrapped(..),
ChrootTarball(..),
noServices,
inChroot,
+ exposeTrueLocaldir,
-- * Internal use
provisioned',
propagateChrootInfo,
@@ -31,27 +33,28 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
import Utility.FileMode
+import Utility.Split
import qualified Data.Map as M
-import Data.List.Utils
import System.Posix.Directory
-import System.Console.Concurrent
-- | Specification of a chroot. Normally you'll use `debootstrapped` or
--- `bootstrapped` to construct a Chroot value.
+-- `bootstrapped` or `hostChroot` to construct a Chroot value.
data Chroot where
- Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
+ Chroot :: ChrootBootstrapper b => FilePath -> b -> InfoPropagator -> Host -> Chroot
instance IsContainer Chroot where
- containerProperties (Chroot _ _ h) = containerProperties h
- containerInfo (Chroot _ _ h) = containerInfo h
- setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
+ containerProperties (Chroot _ _ _ h) = containerProperties h
+ containerInfo (Chroot _ _ _ h) = containerInfo h
+ setContainerProperties (Chroot loc b p h) ps =
+ let h' = setContainerProperties h ps
+ in Chroot loc b p h'
chrootSystem :: Chroot -> Maybe System
chrootSystem = fromInfoVal . fromInfo . containerInfo
instance Show Chroot where
- show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
+ show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
@@ -93,6 +96,7 @@ instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
(Just s@(System (Debian _ _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
+ (Just (System ArchLinux _)) -> Left "Arch Linux not supported by debootstrap."
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; OS not specified"
where
@@ -114,7 +118,9 @@ debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
-bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
+bootstrapped bootstrapper location ps = c
+ where
+ c = Chroot location bootstrapper propagateChrootInfo (host location ps)
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -123,15 +129,14 @@ bootstrapped bootstrapper location ps = Chroot location bootstrapper (host locat
-- is first unmounted. Note that it does not ensure that any processes
-- that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
-provisioned c = provisioned' (propagateChrootInfo c) c False
+provisioned c = provisioned' c False
provisioned'
- :: (Property Linux -> Property (HasInfo + Linux))
- -> Chroot
+ :: Chroot
-> Bool
-> RevertableProperty (HasInfo + Linux) Linux
-provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
- (propigator $ setup `describe` chrootDesc c "exists")
+provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly =
+ (infopropigator c normalContainerInfo $ setup `describe` chrootDesc c "exists")
<!>
(teardown `describe` chrootDesc c "removed")
where
@@ -150,17 +155,20 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
- p `setInfoProperty` chrootInfo c
+type InfoPropagator = Chroot -> (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux)
+
+propagateChrootInfo :: InfoPropagator
+propagateChrootInfo c@(Chroot location _ _ _) pinfo p =
+ propagateContainer location c pinfo $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ h) = mempty `addInfo`
+chrootInfo (Chroot loc _ _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
-propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
+propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
shim <- liftIO $ ifM (doesDirectoryExist d)
@@ -192,14 +200,12 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr
, "--continue"
, show cmd
]
- let p' = p { env = Just pe }
- r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
- processChainOutput
+ r <- liftIO $ chainPropellor (p { env = Just pe })
liftIO cleanup
return r
toChain :: HostName -> Chroot -> Bool -> IO CmdLine
-toChain parenthost (Chroot loc _ _) systemdonly = do
+toChain parenthost (Chroot loc _ _ _) systemdonly = do
onconsole <- isConsole <$> getMessageHandle
return $ ChrootChain parenthost loc systemdonly onconsole
@@ -214,17 +220,16 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
go h = do
changeWorkingDirectory localdir
when onconsole forceConsole
- onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureChildProperties $
- if systemdonly
- then [toChildProperty Systemd.installed]
- else hostProperties h
- flushConcurrentOutput
- putStrLn $ "\n" ++ show r
+ onlyProcess (provisioningLock loc) $
+ runChainPropellor (setInChroot h) $
+ ensureChildProperties $
+ if systemdonly
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
chain _ _ = errorMessage "bad chain command"
inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
mountproc
return (proc "chroot" (loc:cmd), cleanup)
where
@@ -244,13 +249,13 @@ provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
shimdir :: Chroot -> FilePath
-shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim"
+shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"
mungeloc :: FilePath -> String
mungeloc = replace "/" "_"
chrootDesc :: Chroot -> String -> String
-chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
+chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- | Adding this property to a chroot prevents daemons and other services
-- from being started, which is often something you want to prevent when
@@ -286,3 +291,54 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) }
newtype InChroot = InChroot Bool
deriving (Typeable, Show)
+
+-- | Runs an action with the true localdir exposed,
+-- not the one bind-mounted into a chroot. The action is passed the
+-- path containing the contents of the localdir outside the chroot.
+--
+-- In a chroot, this is accomplished by temporily bind mounting the localdir
+-- to a temp directory, to preserve access to the original bind mount. Then
+-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
+-- the temp directory is bind mounted back to the localdir.
+exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a
+exposeTrueLocaldir a = ifM inChroot
+ ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
+ bracket_
+ (movebindmount localdir tmpdir)
+ (movebindmount tmpdir localdir)
+ (a tmpdir)
+ , a localdir
+ )
+ where
+ movebindmount from to = liftIO $ do
+ run "mount" [Param "--bind", File from, File to]
+ -- Have to lazy unmount, because the propellor process
+ -- is running in the localdir that it's unmounting..
+ run "umount" [Param "-l", File from]
+ -- We were in the old localdir; move to the new one after
+ -- flipping the bind mounts. Otherwise, commands that try
+ -- to access the cwd will fail because it got umounted out
+ -- from under.
+ changeWorkingDirectory "/"
+ changeWorkingDirectory localdir
+ run cmd ps = unlessM (boolSystem cmd ps) $
+ error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
+
+-- | Generates a Chroot that has all the properties of a Host.
+--
+-- Note that it's possible to create loops using this, where a host
+-- contains a Chroot containing itself etc. Such loops will be detected at
+-- runtime.
+hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot
+hostChroot h bootstrapper d = chroot
+ where
+ chroot = Chroot d bootstrapper pinfo h
+ pinfo = propagateHostChrootInfo h
+
+-- This is different than propagateChrootInfo in that Info using
+-- HostContext is not made to use the name of the chroot as its context,
+-- but instead uses the hostname of the Host.
+propagateHostChrootInfo :: Host -> InfoPropagator
+propagateHostChrootInfo h c pinfo p =
+ propagateContainer (hostName h) c pinfo $
+ p `setInfoProperty` chrootInfo c