diff options
Diffstat (limited to 'src/Propellor/Property')
| -rw-r--r-- | src/Propellor/Property/Chroot.hs | 130 | ||||
| -rw-r--r-- | src/Propellor/Property/Debootstrap.hs | 2 | ||||
| -rw-r--r-- | src/Propellor/Property/Docker.hs | 37 | ||||
| -rw-r--r-- | src/Propellor/Property/Docker/Shim.hs | 61 | ||||
| -rw-r--r-- | src/Propellor/Property/Systemd.hs | 103 |
5 files changed, 246 insertions, 87 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs new file mode 100644 index 00000000..798330b0 --- /dev/null +++ b/src/Propellor/Property/Chroot.hs @@ -0,0 +1,130 @@ +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 + +instance Hostlike Chroot where + (Chroot l s h) & p = Chroot l s (h & p) + (Chroot l s h) &^ p = Chroot l s (h &^ p) + getHost (Chroot _ _ h) = h + +-- | Defines a Chroot at the given location, containing the specified +-- System. Properties can be added to configure the Chroot. +-- +-- > chroot "/srv/chroot/ghc-dev" (System (Debian Unstable) "amd64") +-- > & Apt.installed ["build-essential", "ghc", "haskell-platform"] +-- > & ... +chroot :: FilePath -> System -> Chroot +chroot location system = Chroot location system (Host location [] mempty) + +-- | Ensures that the chroot exists and is provisioned according to its +-- properties. +-- +-- Reverting this property removes the chroot. Note that it does not ensure +-- that any processes that might be running inside the chroot are stopped. +provisioned :: Chroot -> RevertableProperty +provisioned c@(Chroot loc system _) = RevertableProperty + (propigateChrootInfo c (go "exists" setup)) + (go "removed" teardown) + where + go desc a = property (chrootDesc c desc) $ ensureProperties [a] + + setup = provisionChroot c `requires` built + + built = case system of + (System (Debian _) _) -> debootstrap + (System (Ubuntu _) _) -> debootstrap + + debootstrap = toProp (Debootstrap.built loc system []) + + teardown = undefined + +propigateChrootInfo :: Chroot -> Property -> Property +propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c) + +chrootInfo :: Chroot -> Info +chrootInfo (Chroot loc _ h) = + mempty { _chrootinfo = 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 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 + forceConsole + 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/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 4e7bc740..5f521c32 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -33,7 +33,7 @@ built target system@(System _ arch) extraparams = RevertableProperty setup teardown where setup = check (unpopulated target <||> ispartial) setupprop - `requires` unrevertable installed + `requires` toProp installed teardown = check (not <$> unpopulated target) teardownprop diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 676d323a..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 @@ -52,7 +52,6 @@ import System.Posix.Process import Prelude hiding (init) import Data.List hiding (init) import Data.List.Utils -import qualified Data.Set as S import qualified Data.Map as M installed :: Property @@ -78,8 +77,10 @@ data Container = Container Image Host instance Hostlike Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) + getHost (Container _ h) = h --- | Builds a Container with a given name, image, and properties. +-- | Defines a Container with a given name, image, and properties. +-- Properties can be added to configure the Container. -- -- > container "web-server" "debian" -- > & publish "80:80" @@ -100,11 +101,9 @@ container cn image = Container image (Host cn [] info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked - :: Container - -> RevertableProperty +docked :: Container -> RevertableProperty docked ctr@(Container _ h) = RevertableProperty - (propigateInfo ctr (go "docked" setup)) + (propigateContainerInfo ctr (go "docked" setup)) (go "undocked" teardown) where cn = hostName h @@ -131,14 +130,12 @@ docked ctr@(Container _ h) = RevertableProperty ] ] -propigateInfo :: Container -> Property -> Property -propigateInfo (Container _ h@(Host hn _ containerinfo)) p = - combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops +propigateContainerInfo :: Container -> Property -> Property +propigateContainerInfo ctr@(Container _ h) p = + propigateInfo ctr p (<> dockerinfo) where - p' = p { propertyInfo = propertyInfo p <> dockerinfo } - dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h } - dnsprops = map addDNS (S.toList $ _dns containerinfo) - privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) + dockerinfo = dockerInfo $ + mempty { _dockerContainers = M.singleton (hostName h) h } mkContainerInfo :: ContainerId -> Container -> ContainerInfo mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = @@ -435,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 diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs new file mode 100644 index 00000000..be08a847 --- /dev/null +++ b/src/Propellor/Property/Systemd.hs @@ -0,0 +1,103 @@ +module Propellor.Property.Systemd ( + installed, + persistentJournal, + container, + nspawned, +) where + +import Propellor +import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Property.Apt as Apt +import Utility.SafeCommand + +import Data.List.Utils + +type MachineName = String + +type NspawnParam = CommandParam + +data Container = Container MachineName System [CommandParam] Host + +instance Hostlike Container where + (Container n s ps h) & p = Container n s ps (h & p) + (Container n s ps h) &^ p = Container n s ps (h &^ p) + getHost (Container _ _ _ h) = h + +-- dbus is only a Recommends of systemd, but is needed for communication +-- from the systemd inside a container to the one outside, so make sure it +-- gets installed. +installed :: Property +installed = Apt.installed ["systemd", "dbus"] + +-- | Sets up persistent storage of the journal. +persistentJournal :: Property +persistentJournal = check (not <$> doesDirectoryExist dir) $ + combineProperties "persistent systetemd journal" + [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] + , cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] + ] + `requires` Apt.installed ["acl"] + where + dir = "/var/log/journal" + +-- | Defines a container with a given machine name, containing the specified +-- System. Properties can be added to configure the Container. +-- +-- > container "webserver" (System (Debian Unstable) "amd64") [] +container :: MachineName -> System -> [NspawnParam] -> Container +container name system ps = Container name system ps (Host name [] mempty) + +-- | Runs a container using systemd-nspawn. +-- +-- A systemd unit is set up for the container, so it will automatically +-- be started on boot. +-- +-- Systemd is automatically installed inside the container, and will +-- communicate with the host's systemd. This allows systemctl to be used to +-- examine the status of services running inside the container. +-- +-- When the host system has persistentJournal enabled, journactl can be +-- used to examine logs forwarded from the container. +-- +-- Reverting this property stops the container, removes the systemd unit, +-- and deletes the chroot and all its contents. +nspawned :: Container -> RevertableProperty +nspawned c@(Container name system _ h) = RevertableProperty setup teardown + where + -- TODO after container is running, use nsenter to enter it + -- and run propellor to finish provisioning. + setup = toProp (nspawnService c) + `requires` toProp chrootprovisioned + + teardown = toProp (revert (chrootprovisioned)) + `requires` toProp (revert (nspawnService c)) + + -- When provisioning the chroot, pass a version of the Host + -- that only has the Property of systemd being installed. + -- This is to avoid starting any daemons in the chroot, + -- which would not run in the container's namespace. + chrootprovisioned = Chroot.provisioned $ + Chroot.Chroot (containerDir name) system $ + h { hostProperties = [installed] } + +nspawnService :: Container -> RevertableProperty +nspawnService (Container name _ ps _) = RevertableProperty setup teardown + where + service = nspawnServiceName name + servicefile = "/etc/systemd/system/multi-user.target.wants" </> service + + setup = check (not <$> doesFileExist servicefile) $ + combineProperties ("container running " ++ service) + [ cmdProperty "systemctl" ["enable", service] + , cmdProperty "systemctl" ["start", service] + ] + + -- TODO adjust execStart line to reflect ps + + teardown = undefined + +nspawnServiceName :: MachineName -> String +nspawnServiceName name = "systemd-nspawn@" ++ name ++ ".service" + +containerDir :: MachineName -> FilePath +containerDir name = "/var/lib/container" ++ replace "/" "_" name |