From 05d35eb568e74deafc936e6735171291410b5f0b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 20 Oct 2015 12:01:59 -0400 Subject: Chroot: Converted to use a ChrootBootstrapper type class So other ways to bootstrap chroots can easily be added in separate modules. (API change) --- src/Propellor/Property/Chroot.hs | 69 ++++++++++++++++++++++++----------- src/Propellor/Property/Chroot/Util.hs | 11 +++++- src/Propellor/Property/Debootstrap.hs | 18 +-------- src/Propellor/Property/Systemd.hs | 3 +- 4 files changed, 60 insertions(+), 41 deletions(-) (limited to 'src/Propellor') 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. -- cgit v1.2.3