{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-}
module Propellor.Property.Chroot (
debootstrapped,
bootstrapped,
provisioned,
hostChroot,
Chroot(..),
ChrootBootstrapper(..),
Debootstrapped(..),
ChrootTarball(..),
exposeTrueLocaldir,
useHostProxy,
provisioned',
propagateChrootInfo,
propellChroot,
chain,
chrootSystem,
) where
import Propellor.Base
import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Container
import Propellor.Types.Info
import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
import Utility.Split
import qualified Data.Map as M
import System.Posix.Directory
data Chroot where
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 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)
class ChrootBootstrapper b where
buildchroot
:: b
-> Info
-> FilePath
-> Either String (Property Linux)
data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
buildchroot (ChrootTarball tb) _ loc = Right $
tightenTargets $ extractTarball loc tb
extractTarball :: FilePath -> FilePath -> Property UnixLike
extractTarball target src = check (isUnpopulated target) $
cmdProperty "tar" params
`assume` MadeChange
`requires` File.dirExists target
where
params =
[ "-C"
, target
, "-xf"
, src
]
data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) info 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
debootstrap s = Debootstrap.built loc s
(cf <> proxyConf <> mirrorConf)
system = fromInfoVal (fromInfo info)
proxyConf = case (fromInfoVal . fromInfo) info of
Just (Apt.HostAptProxy u) ->
Debootstrap.DebootstrapProxy u
Nothing -> mempty
mirrorConf = case (fromInfoVal . fromInfo) info of
Just (Apt.HostMirror u) ->
Debootstrap.DebootstrapMirror u
Nothing -> mempty
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
debootstrapped conf = bootstrapped (Debootstrapped conf)
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
bootstrapped bootstrapper location ps = c
where
c = Chroot location bootstrapper propagateChrootInfo (host location ps)
provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned c = provisioned' c False [FilesystemContained]
provisioned'
:: Chroot
-> Bool
-> [ContainerCapability]
-> RevertableProperty (HasInfo + Linux) Linux
provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly caps =
(infopropigator c normalContainerInfo $ setup `describe` chrootDesc c "exists")
<!>
(teardown `describe` chrootDesc c "removed")
where
setup :: Property Linux
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly caps
`requires` built
built = case buildchroot bootstrapper (containerInfo c) loc of
Right p -> p
Left e -> cantbuild e
cantbuild e = property (chrootDesc c "built") (error e)
teardown :: Property Linux
teardown = check (not <$> isUnpopulated loc) $
property ("removed " ++ loc) $
makeChange (removeChroot loc)
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`
mempty { _chroots = M.singleton loc h }
propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> [ContainerCapability] -> Property UnixLike
propellChroot c@(Chroot loc _ _ _) mkproc systemdonly caps = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
shim <- liftIO $ 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 caps
pe <- liftIO standardPathEnv
(p, cleanup) <- liftIO $ mkproc
[ shim
, "--continue"
, show cmd
]
r <- liftIO $ chainPropellor (p { env = Just pe })
liftIO cleanup
return r
toChain :: HostName -> Chroot -> Bool -> [ContainerCapability] -> IO CmdLine
toChain parenthost (Chroot loc _ _ _) systemdonly caps = do
onconsole <- isConsole <$> getMessageHandle
return $ ChrootChain parenthost loc systemdonly onconsole caps
chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole caps) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ 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) $
runChainPropellor (setcaps h) $
ensureChildProperties $
if systemdonly
then [toChildProperty Systemd.installed]
else hostProperties h
setcaps h = h { hostInfo = hostInfo h `addInfo` caps }
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 mempty
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
exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a
exposeTrueLocaldir a = ifM (hasContainerCapability FilesystemContained)
( 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]
run "umount" [Param "-l", File from]
changeWorkingDirectory "/"
changeWorkingDirectory localdir
run cmd ps = unlessM (boolSystem cmd ps) $
error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot
hostChroot h bootstrapper d = chroot
where
chroot = Chroot d bootstrapper pinfo h
pinfo = propagateHostChrootInfo h
propagateHostChrootInfo :: Host -> InfoPropagator
propagateHostChrootInfo h c pinfo p =
propagateContainer (hostName h) c pinfo $
p `setInfoProperty` chrootInfo c
useHostProxy :: Host -> Property DebianLike
useHostProxy h = property' "use host's apt proxy" $ \w ->
case getProxyInfo h of
Just (Apt.HostAptProxy u) -> ensureProperty w (Apt.proxy' u)
Nothing -> noChange
where
getProxyInfo = fromInfoVal . fromInfo . hostInfo