summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2017-03-11 14:53:45 -0400
committerJoey Hess2017-03-11 14:53:53 -0400
commitb86dc506337021c84fe836aed3fcaf1a643cc462 (patch)
tree50a61fc0d95e66456c0157e770d96fafa612c99e /src
parent6ce4b7c072d31bf745bc1c59d21544b6d52dbc4c (diff)
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.
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Chroot.hs41
-rw-r--r--src/Propellor/Property/Systemd.hs6
2 files changed, 25 insertions, 22 deletions
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.