summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-20 12:06:35 -0400
committerJoey Hess2015-10-20 12:06:35 -0400
commit9b7719c2c78f1e6f3d012bb76aca7efa1df7faac (patch)
tree736397753e2064407fb8befee07b325fbc055540
parent650b7659cf07f1da31bcf51eb139af28d5bc8bb1 (diff)
parent05d35eb568e74deafc936e6735171291410b5f0b (diff)
Merge branch 'joeyconfig'
-rw-r--r--debian/changelog3
-rw-r--r--src/Propellor/PropAccum.hs2
-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/Spin.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs4
-rw-r--r--src/Propellor/Property/Systemd.hs3
-rw-r--r--src/Propellor/Types/Info.hs40
-rw-r--r--src/Propellor/Types/OS.hs4
10 files changed, 93 insertions, 63 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/PropAccum.hs b/src/Propellor/PropAccum.hs
index 1f9459d0..3c50cf32 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -83,6 +83,6 @@ propagateContainer containername c prop = infoProperty
hostprops = map go $ getProperties c
go p =
let i = mapInfo (forceHostContext containername)
- (propigatableInfo (propertyInfo p))
+ (propagatableInfo (propertyInfo p))
cs = map go (propertyChildren p)
in infoProperty (propertyDesc p) (propertySatisfy p) i cs
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/Spin.hs b/src/Propellor/Property/Spin.hs
index ead85f59..5f857ef4 100644
--- a/src/Propellor/Property/Spin.hs
+++ b/src/Propellor/Property/Spin.hs
@@ -125,7 +125,7 @@ cdesc n = "controller for " ++ n
-- To detect loops of controlled hosts, each Host's info contains a list
-- of the hosts it's controlling.
newtype Controlling = Controlled [Host]
- deriving (Typeable, Monoid)
+ deriving (Typeable, Monoid, Show)
isControlledBy :: Host -> Controlling -> Bool
h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs)
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index ea38980b..fa07c6f8 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -209,7 +209,7 @@ getHostPubKey = fromHostKeyInfo <$> askInfo
newtype HostKeyInfo = HostKeyInfo
{ fromHostKeyInfo :: M.Map SshKeyType PubKeyText }
- deriving (Eq, Ord, Typeable)
+ deriving (Eq, Ord, Typeable, Show)
instance IsInfo HostKeyInfo where
propagateInfo _ = False
@@ -230,7 +230,7 @@ getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo
newtype UserKeyInfo = UserKeyInfo
{ fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) }
- deriving (Eq, Ord, Typeable)
+ deriving (Eq, Ord, Typeable, Show)
instance IsInfo UserKeyInfo where
propagateInfo _ = False
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.
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index e94c370e..2c95b6fc 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Propellor.Types.Info (
Info,
@@ -6,7 +6,7 @@ module Propellor.Types.Info (
addInfo,
getInfo,
mapInfo,
- propigatableInfo,
+ propagatableInfo,
InfoVal(..),
fromInfoVal,
Typeable,
@@ -17,56 +17,64 @@ import Data.Monoid
import Data.Maybe
-- | Information about a Host, which can be provided by its properties.
-newtype Info = Info [(Dynamic, Bool)]
- deriving (Monoid)
+newtype Info = Info [InfoEntry]
+ deriving (Monoid, Show)
-instance Show Info where
- show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l)
+data InfoEntry where
+ InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry
+
+instance Show InfoEntry where
+ show (InfoEntry v) = show v
+
+-- Extracts the value from an InfoEntry but only when
+-- it's of the requested type.
+extractInfoEntry :: Typeable v => InfoEntry -> Maybe v
+extractInfoEntry (InfoEntry v) = cast v
-- | Values stored in Info must be members of this class.
--
-- This is used to avoid accidentially using other data types
-- as info, especially type aliases which coud easily lead to bugs.
-- We want a little bit of dynamic types here, but not too far..
-class (Typeable v, Monoid v) => IsInfo v where
+class (Typeable v, Monoid v, Show v) => IsInfo v where
-- | Should info of this type be propagated out of a
-- container to its Host?
propagateInfo :: v -> Bool
-- | Any value in the `IsInfo` type class can be added to an Info.
addInfo :: IsInfo v => Info -> v -> Info
-addInfo (Info l) v = Info ((toDyn v, propagateInfo v):l)
+addInfo (Info l) v = Info (InfoEntry v:l)
-- The list is reversed here because addInfo builds it up in reverse order.
getInfo :: IsInfo v => Info -> v
-getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l))
+getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
-- | Maps a function over all values stored in the Info that are of the
-- appropriate type.
mapInfo :: IsInfo v => (v -> v) -> Info -> Info
mapInfo f (Info l) = Info (map go l)
where
- go (i, p) = case fromDynamic i of
- Nothing -> (i, p)
- Just v -> (toDyn (f v), p)
+ go i = case extractInfoEntry i of
+ Nothing -> i
+ Just v -> InfoEntry (f v)
-- | Filters out parts of the Info that should not propagate out of a
-- container.
-propigatableInfo :: Info -> Info
-propigatableInfo (Info l) = Info (filter snd l)
+propagatableInfo :: Info -> Info
+propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l)
-- | Use this to put a value in Info that is not a monoid.
-- The last value set will be used. This info does not propagate
-- out of a container.
data InfoVal v = NoInfoVal | InfoVal v
- deriving (Typeable)
+ deriving (Typeable, Show)
instance Monoid (InfoVal v) where
mempty = NoInfoVal
mappend _ v@(InfoVal _) = v
mappend v NoInfoVal = v
-instance Typeable v => IsInfo (InfoVal v) where
+instance (Typeable v, Show v) => IsInfo (InfoVal v) where
propagateInfo _ = False
fromInfoVal :: InfoVal v -> Maybe v
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index b16939c7..447d4396 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -42,10 +42,10 @@ type Architecture = String
type UserName = String
newtype User = User UserName
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Show)
newtype Group = Group String
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Show)
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group