{-# LANGUAGE FlexibleContexts #-} module Propellor.Property.Chroot ( Chroot(..), BuilderConf(..), debootstrapped, provisioned, -- * Internal use provisioned', propigateChrootInfo, propellChroot, chain, ) where import Propellor import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Shim as Shim import Propellor.Property.Mount import qualified Data.Map as M import Data.List.Utils import System.Posix.Directory data Chroot = Chroot FilePath System BuilderConf Host deriving (Show) data BuilderConf = UsingDeboostrap Debootstrap.DebootstrapConfig deriving (Show) instance PropAccum Chroot where (Chroot l s c h) `addProp` p = Chroot l s c (h & p) (Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p) getProperties (Chroot _ _ _ h) = hostProperties h -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. -- -- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot debootstrapped system conf location = case system of (System (Debian _) _) -> mk (System (Ubuntu _) _) -> mk where h = Host location [] mempty mk = Chroot location system (UsingDeboostrap conf) h & os system -- | Ensures that the chroot exists and is provisioned according to its -- properties. -- -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. provisioned :: Chroot -> RevertableProperty provisioned c = provisioned' (propigateChrootInfo c) c False provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = (propigator $ go "exists" setup) (go "removed" teardown) where go desc a = propertyList (chrootDesc c desc) [a] setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly `requires` toProp built built = case (system, builderconf) of ((System (Debian _) _), UsingDeboostrap cf) -> debootstrap cf ((System (Ubuntu _) _), UsingDeboostrap cf) -> debootstrap cf debootstrap = Debootstrap.built loc system teardown = toProp (revert built) propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo propigateChrootInfo c@(Chroot location _ _ _) p = propigateContainer location c p' where p' = infoProperty (propertyDesc p) (propertySatisfy p) (propertyInfo p <> chrootInfo c) (propertyChildren p) chrootInfo :: Chroot -> Info 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 NoInfo 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) ( pure (Shim.file me d) , Shim.setup me Nothing 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 cmd <- liftIO $ toChain parenthost c systemdonly pe <- liftIO standardPathEnv (p, cleanup) <- liftIO $ mkproc [ shim , "--continue" , show cmd ] let p' = p { env = Just pe } r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' processChainOutput liftIO cleanup return r toChain :: HostName -> Chroot -> Bool -> IO CmdLine toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> mkMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole chain :: [Host] -> CmdLine -> IO () chain hostlist (ChrootChain hn loc systemdonly onconsole) = case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) Just h -> go h where go h = do changeWorkingDirectory localdir when onconsole forceConsole onlyProcess (provisioningLock loc) $ do r <- runPropellor h $ ensureProperties $ if systemdonly then [Systemd.installed] else map ignoreInfo $ hostProperties h putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where -- /proc needs to be mounted in the chroot for the linker to use -- /proc/self/exe which is necessary for some commands to work mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ void $ mount "proc" "proc" procloc procloc = loc "proc" cleanup | keepprocmounted = noop | otherwise = whenM (elem procloc <$> mountPointsBelow loc) $ umountLazy procloc 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