module Propellor.Property.Chroot (
Chroot(..),
BuilderConf(..),
debootstrapped,
provisioned,
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) & p = Chroot l s c (h & p)
(Chroot l s c h) &^ p = Chroot l s c (h &^ p)
getProperties (Chroot _ _ _ h) = hostProperties h
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
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 p = propigateContainer 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 }
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
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