From b86dc506337021c84fe836aed3fcaf1a643cc462 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Mar 2017 14:53:45 -0400 Subject: Changed Chroot data type to include Info propigation This will allow for different Chroots that propigate info differently. hostChroot will use this. This commit was sponsored by Peter Hogg on Patreon. --- src/Propellor/Property/Chroot.hs | 41 +++++++++++++++++++++------------------ src/Propellor/Property/Systemd.hs | 6 +++--- 2 files changed, 25 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 5f2e6b32..9624a0f3 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -40,18 +40,18 @@ import System.Console.Concurrent -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` 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 = Chroot loc b p (setContainerProperties h ps) 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. @@ -115,7 +115,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 c) (host location ps) -- | Ensures that the chroot exists and is provisioned according to its -- properties. @@ -124,15 +126,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 $ setup `describe` chrootDesc c "exists") (teardown `describe` chrootDesc c "removed") where @@ -151,17 +152,19 @@ 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 $ +type InfoPropagator = Property Linux -> Property (HasInfo + Linux) + +propagateChrootInfo :: Chroot -> InfoPropagator +propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c $ 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) @@ -200,7 +203,7 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr 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 @@ -225,7 +228,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = 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 @@ -245,13 +248,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 diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index e1e20974..8f9c3beb 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -259,7 +259,7 @@ debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux -nspawned c@(Container name (Chroot.Chroot loc builder _) h) = +nspawned c@(Container name (Chroot.Chroot loc builder _ _) h) = p `describe` ("nspawned " ++ name) where p :: RevertableProperty (HasInfo + Linux) Linux @@ -271,7 +271,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- Chroot provisioning is run in systemd-only mode, -- which sets up the chroot and ensures systemd and dbus are -- installed, but does not handle the other properties. - chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True + chrootprovisioned = Chroot.provisioned' chroot True -- Use nsenter to enter container and and run propellor to -- finish provisioning. @@ -281,7 +281,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = doNothing - chroot = Chroot.Chroot loc builder h + chroot = Chroot.Chroot loc builder (Chroot.propagateChrootInfo chroot) h -- | Sets up the service file for the container, and then starts -- it running. -- cgit v1.2.3