From ace352cc0aa732d00900122e0ab8552c870f3901 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Oct 2015 12:33:18 -0400 Subject: improve Info type using GADT, at nomeata's suggestion This makes Show Info work, and simplifies the implementation. --- src/Propellor/PropAccum.hs | 2 +- src/Propellor/Property/Spin.hs | 2 +- src/Propellor/Property/Ssh.hs | 4 ++-- src/Propellor/Types/Info.hs | 40 ++++++++++++++++++++++++---------------- src/Propellor/Types/OS.hs | 4 ++-- 5 files changed, 30 insertions(+), 22 deletions(-) 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/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/Types/Info.hs b/src/Propellor/Types/Info.hs index e94c370e..59cc13e0 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) = fromDynamic (toDyn 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 -- cgit v1.2.3 From bfcc5a7666f817fbfe9c149480ca0359e3e744ec Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Oct 2015 12:57:08 -0400 Subject: simplify using type safe cast --- src/Propellor/Types/Info.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index 59cc13e0..2c95b6fc 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -29,7 +29,7 @@ instance Show InfoEntry where -- Extracts the value from an InfoEntry but only when -- it's of the requested type. extractInfoEntry :: Typeable v => InfoEntry -> Maybe v -extractInfoEntry (InfoEntry v) = fromDynamic (toDyn v) +extractInfoEntry (InfoEntry v) = cast v -- | Values stored in Info must be members of this class. -- -- cgit v1.2.3 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) --- debian/changelog | 3 ++ 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 +- 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 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. -- cgit v1.2.3