summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-20 12:01:59 -0400
committerJoey Hess2015-10-20 12:06:24 -0400
commit05d35eb568e74deafc936e6735171291410b5f0b (patch)
tree3d1f25930948f59c96b942ec296b11094f3f20c3
parentbfcc5a7666f817fbfe9c149480ca0359e3e744ec (diff)
Chroot: Converted to use a ChrootBootstrapper type class
So other ways to bootstrap chroots can easily be added in separate modules. (API change)
-rw-r--r--debian/changelog3
-rw-r--r--src/Propellor/Property/Chroot.hs69
-rw-r--r--src/Propellor/Property/Chroot/Util.hs11
-rw-r--r--src/Propellor/Property/Debootstrap.hs18
-rw-r--r--src/Propellor/Property/Systemd.hs3
5 files changed, 63 insertions, 41 deletions
diff --git a/debian/changelog b/debian/changelog
index a6d93c58..eaa6de84 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -30,6 +30,9 @@ propellor (2.9.0) UNRELEASED; urgency=medium
* Added --unset-unused
* Fix typo: propigate → propagate. Thanks, Felix Gruber.
(A minor API change)
+ * Chroot: Converted to use a ChrootBootstrapper type class, so
+ other ways to bootstrap chroots can easily be added in separate
+ modules. (API change)
-- Joey Hess <id@joeyh.name> Thu, 08 Oct 2015 11:09:01 -0400
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 3a108540..30f09862 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -1,15 +1,18 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, GADTs #-}
module Propellor.Property.Chroot (
Chroot(..),
- BuilderConf(..),
+ ChrootBootstrapper(..),
+ Debootstrapped(..),
debootstrapped,
+ bootstrapped,
provisioned,
-- * Internal use
provisioned',
propagateChrootInfo,
propellChroot,
chain,
+ chrootSystem,
) where
import Propellor.Base
@@ -26,18 +29,37 @@ import qualified Data.Map as M
import Data.List.Utils
import System.Posix.Directory
-data Chroot = Chroot FilePath System BuilderConf Host
- deriving (Show)
+data Chroot where
+ Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot
-data BuilderConf
- = UsingDeboostrap Debootstrap.DebootstrapConfig
- deriving (Show)
+chrootSystem :: Chroot -> System
+chrootSystem (Chroot _ system _ _) = system
+
+instance Show Chroot where
+ show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system
instance PropAccum Chroot where
(Chroot l s c h) `addProp` p = Chroot l s c (h & p)
(Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p)
getProperties (Chroot _ _ _ h) = hostProperties h
+-- | Class of things that can do initial bootstrapping of an operating
+-- System in a chroot.
+class ChrootBootstrapper b where
+ -- Do initial bootstrapping of an operating system in a chroot.
+ -- If the operating System is not supported, return Nothing.
+ buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo)
+
+-- | Use to bootstrap a chroot with debootstrap.
+data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
+
+instance ChrootBootstrapper Debootstrapped where
+ buildchroot (Debootstrapped cf) system loc = case system of
+ (System (Debian _) _) -> Just debootstrap
+ (System (Ubuntu _) _) -> Just debootstrap
+ where
+ debootstrap = Debootstrap.built loc system cf
+
-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot.
@@ -46,13 +68,16 @@ instance PropAccum Chroot where
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot
-debootstrapped system conf location = case system of
- (System (Debian _) _) -> mk
- (System (Ubuntu _) _) -> mk
+debootstrapped system conf = bootstrapped system (Debootstrapped conf)
+
+-- | Defines a Chroot at the given location, bootstrapped with the
+-- specified ChrootBootstrapper.
+bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot
+bootstrapped system bootstrapper location =
+ Chroot location system bootstrapper h
+ & os system
where
h = Host location [] mempty
- mk = Chroot location system (UsingDeboostrap conf) h
- & os system
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -64,23 +89,23 @@ provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propagateChrootInfo c) c False
provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
-provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
- (propigator $ go "exists" setup)
+provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly =
+ (propigator $ propertyList (chrootDesc c "exists") [setup])
<!>
- (go "removed" teardown)
+ (propertyList (chrootDesc c "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
+ built = case buildchroot bootstrapper system loc of
+ Just p -> p
+ Nothing -> cantbuild
- debootstrap = Debootstrap.built loc system
+ cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty []
- teardown = toProp (revert built)
+ teardown = check (not <$> unpopulated loc) $
+ property ("removed " ++ loc) $
+ makeChange (removeChroot loc)
propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c p'
diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs
index ea0df780..3ebda28f 100644
--- a/src/Propellor/Property/Chroot/Util.hs
+++ b/src/Propellor/Property/Chroot/Util.hs
@@ -2,11 +2,14 @@ module Propellor.Property.Chroot.Util where
import Propellor.Property.Mount
+import Utility.Exception
import Utility.Env
+import Utility.Directory
+
import Control.Applicative
import System.Directory
--- When chrooting, it's useful to ensure that PATH has all the standard
+-- | When chrooting, it's useful to ensure that PATH has all the standard
-- directories in it. This adds those directories to whatever PATH is
-- already set.
standardPathEnv :: IO [(String, String)]
@@ -18,9 +21,13 @@ standardPathEnv = do
stdPATH :: String
stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"
--- Removes the contents of a chroot. First, unmounts any filesystems
+-- | Removes the contents of a chroot. First, unmounts any filesystems
-- mounted within it.
removeChroot :: FilePath -> IO ()
removeChroot c = do
unmountBelow c
removeDirectoryRecursive c
+
+-- | Returns true if a chroot directory is empty.
+unpopulated :: FilePath -> IO Bool
+unpopulated d = null <$> catchDefaultIO [] (dirContents d)
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index bb177007..f8981591 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -48,19 +48,8 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
---
--- Reverting this property deletes the chroot and all its contents.
--- Anything mounted under the filesystem is first unmounted.
---
--- Note that reverting this property does not stop any processes
--- currently running in the chroot.
-built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty
-built target system config = built' (toProp installed) target system config <!> teardown
- where
- teardown = check (not <$> unpopulated target) teardownprop
-
- teardownprop = property ("removed debootstrapped " ++ target) $
- makeChange (removeChroot target)
+built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
+built target system config = built' (toProp installed) target system config
built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
built' installprop target system@(System _ arch) config =
@@ -100,9 +89,6 @@ built' installprop target system@(System _ arch) config =
, return False
)
-unpopulated :: FilePath -> IO Bool
-unpopulated d = null <$> catchDefaultIO [] (dirContents d)
-
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
extractSuite (System (Ubuntu r) _) = Just r
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 0ec0697e..3f20a9e2 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -187,7 +187,8 @@ container name mkchroot = Container name c h
& resolvConfed
& linkJournal
where
- c@(Chroot.Chroot _ system _ _) = mkchroot (containerDir name)
+ c = mkchroot (containerDir name)
+ system = Chroot.chrootSystem c
h = Host name [] mempty
-- | Runs a container using systemd-nspawn.