From b8b746a7f1bdbf179136959a85138fde60c43588 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 20 Nov 2014 14:06:55 -0400 Subject: starting work on a Chroot module factored out info up-propigation code rom Docker --- src/Propellor.hs | 2 ++ src/Propellor/Host.hs | 64 ++++++++++++++++++++++++++++++++++++++++ src/Propellor/Property.hs | 34 +-------------------- src/Propellor/Property/Chroot.hs | 57 +++++++++++++++++++++++++++++++++++ src/Propellor/Property/Docker.hs | 23 +++++++-------- src/Propellor/Types.hs | 21 ++++++++++++- 6 files changed, 154 insertions(+), 47 deletions(-) create mode 100644 src/Propellor/Host.hs create mode 100644 src/Propellor/Property/Chroot.hs (limited to 'src') diff --git a/src/Propellor.hs b/src/Propellor.hs index c0ef14f4..6e31e27c 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -33,6 +33,7 @@ module Propellor ( module Propellor.Types , module Propellor.Property , module Propellor.Property.Cmd + , module Propellor.Host , module Propellor.Info , module Propellor.PrivData , module Propellor.Engine @@ -51,6 +52,7 @@ import Propellor.PrivData import Propellor.Message import Propellor.Exception import Propellor.Info +import Propellor.Host import Utility.PartialPrelude as X import Utility.Process as X diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs new file mode 100644 index 00000000..14d56e20 --- /dev/null +++ b/src/Propellor/Host.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Host where + +import Data.Monoid +import qualified Data.Set as S + +import Propellor.Types +import Propellor.Info +import Propellor.Property +import Propellor.PrivData + +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host hn [] mempty + +-- | Something that can accumulate properties. +class Hostlike h where + -- | Adds a property. + -- + -- Can add Properties and RevertableProperties + (&) :: IsProp p => h -> p -> h + + -- | Like (&), but adds the property as the + -- first property of the host. Normally, property + -- order should not matter, but this is useful + -- when it does. + (&^) :: IsProp p => h -> p -> h + + getHost :: h -> Host + +instance Hostlike Host where + (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) + (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) + getHost h = h + +-- | Adds a property in reverted form. +(!) :: Hostlike h => h -> RevertableProperty -> h +h ! p = h & revert p + +infixl 1 &^ +infixl 1 & +infixl 1 ! + +-- | When eg, docking a container, some of the Info about the container +-- should propigate out to the Host it's on. This includes DNS info, +-- so that eg, aliases of the container are reflected in the dns for the +-- host where it runs. +-- +-- This adjusts the Property that docks a container, to include such info +-- from the container. +propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property +propigateInfo hl p f = combineProperties (propertyDesc p) $ + p' : dnsprops ++ privprops + where + p' = p { propertyInfo = f (propertyInfo p) } + i = hostInfo (getHost hl) + dnsprops = map addDNS (S.toList $ _dns i) + privprops = map addPrivDataField (S.toList $ _privDataFields i) diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index bf69ff60..1d750a78 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -3,6 +3,7 @@ module Propellor.Property where import System.Directory +import System.FilePath import Control.Monad import Data.Monoid import Control.Monad.IfElse @@ -12,7 +13,6 @@ import Propellor.Types import Propellor.Info import Propellor.Engine import Utility.Monad -import System.FilePath -- Constructs a Property. property :: Desc -> Propellor Result -> Property @@ -135,38 +135,6 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 unrevertable :: RevertableProperty -> Property unrevertable (RevertableProperty p1 _p2) = p1 --- | Starts accumulating the properties of a Host. --- --- > host "example.com" --- > & someproperty --- > ! oldproperty --- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty - -class Hostlike h where - -- | Adds a property to a Host - -- - -- Can add Properties and RevertableProperties - (&) :: IsProp p => h -> p -> h - -- | Like (&), but adds the property as the - -- first property of the host. Normally, property - -- order should not matter, but this is useful - -- when it does. - (&^) :: IsProp p => h -> p -> h - -instance Hostlike Host where - (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) - --- | Adds a property to the Host in reverted form. -(!) :: Hostlike h => h -> RevertableProperty -> h -h ! p = h & revert p - -infixl 1 &^ -infixl 1 & -infixl 1 ! - -- Changes the action that is performed to satisfy a property. adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs new file mode 100644 index 00000000..e5046937 --- /dev/null +++ b/src/Propellor/Property/Chroot.hs @@ -0,0 +1,57 @@ +module Propellor.Property.Chroot ( + Chroot, + chroot, + provisioned, +) where + +import Propellor +import qualified Propellor.Property.Debootstrap as Debootstrap + +import qualified Data.Map as M + +data Chroot = Chroot FilePath System Host + +instance Hostlike Chroot where + (Chroot l s h) & p = Chroot l s (h & p) + (Chroot l s h) &^ p = Chroot l s (h &^ p) + getHost (Chroot _ _ h) = h + +-- | Defines a Chroot at the given location, containing the specified +-- System. Properties can be added to configure the Chroot. +-- +-- > chroot "/srv/chroot/ghc-dev" (System (Debian Unstable) "amd64" +-- > & Apt.installed ["build-essential", "ghc", "haskell-platform"] +-- > & ... +chroot :: FilePath -> System -> Chroot +chroot location system = Chroot location system (Host location [] mempty) + +-- | Ensures that the chroot exists and is provisioned according to its +-- properties. +-- +-- Reverting this property removes the chroot. Note that it does not ensure +-- that any processes that might be running inside the chroot are stopped. +provisioned :: Chroot -> RevertableProperty +provisioned c@(Chroot loc system _) = RevertableProperty + (propigateChrootInfo c (go "exists" setup)) + (go "removed" teardown) + where + go desc a = property ("chroot " ++ loc ++ " " ++ desc) $ do + ensureProperties [a] + + setup = provisionChroot c `requires` built + + built = case system of + (System (Debian _) _) -> debootstrap + (System (Ubuntu _) _) -> debootstrap + + debootstrap = unrevertable (Debootstrap.built loc system []) + + teardown = undefined + +propigateChrootInfo :: Chroot -> Property -> Property +propigateChrootInfo c@(Chroot loc _ h) p = propigateInfo c p (<> chrootinfo) + where + chrootinfo = mempty $ mempty { _chroots = M.singleton loc h } + +provisionChroot :: Chroot -> Property +provisionChroot = undefined diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 676d323a..92cc124a 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -52,7 +52,6 @@ import System.Posix.Process import Prelude hiding (init) import Data.List hiding (init) import Data.List.Utils -import qualified Data.Set as S import qualified Data.Map as M installed :: Property @@ -78,8 +77,10 @@ data Container = Container Image Host instance Hostlike Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) + getHost (Container _ h) = h --- | Builds a Container with a given name, image, and properties. +-- | Defines a Container with a given name, image, and properties. +-- Properties can be added to configure the Container. -- -- > container "web-server" "debian" -- > & publish "80:80" @@ -100,11 +101,9 @@ container cn image = Container image (Host cn [] info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked - :: Container - -> RevertableProperty +docked :: Container -> RevertableProperty docked ctr@(Container _ h) = RevertableProperty - (propigateInfo ctr (go "docked" setup)) + (propigateContainerInfo ctr (go "docked" setup)) (go "undocked" teardown) where cn = hostName h @@ -131,14 +130,12 @@ docked ctr@(Container _ h) = RevertableProperty ] ] -propigateInfo :: Container -> Property -> Property -propigateInfo (Container _ h@(Host hn _ containerinfo)) p = - combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops +propigateContainerInfo :: Container -> Property -> Property +propigateContainerInfo ctr@(Container _ h) p = + propigateInfo ctr p (<> dockerinfo) where - p' = p { propertyInfo = propertyInfo p <> dockerinfo } - dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h } - dnsprops = map addDNS (S.toList $ _dns containerinfo) - privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) + dockerinfo = dockerInfo $ + mempty { _dockerContainers = M.singleton (hostName h) h } mkContainerInfo :: ContainerId -> Container -> ContainerInfo mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 90c08e64..4e0a8dee 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -25,6 +25,7 @@ module Propellor.Types , fromVal , DockerInfo(..) , DockerRunParam(..) + , ChrootInfo(..) , module Propellor.Types.OS , module Propellor.Types.Dns ) where @@ -166,11 +167,12 @@ data Info = Info , _dns :: S.Set Dns.Record , _namedconf :: Dns.NamedConfMap , _dockerinfo :: DockerInfo + , _chrootinfo :: ChrootInfo } deriving (Eq, Show) instance Monoid Info where - mempty = Info mempty mempty mempty mempty mempty mempty mempty + mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty mappend old new = Info { _os = _os old <> _os new , _privDataFields = _privDataFields old <> _privDataFields new @@ -179,6 +181,7 @@ instance Monoid Info where , _dns = _dns old <> _dns new , _namedconf = _namedconf old <> _namedconf new , _dockerinfo = _dockerinfo old <> _dockerinfo new + , _chrootinfo = _chrootinfo old <> _chrootinfo new } data Val a = Val a | NoVal @@ -217,3 +220,19 @@ newtype DockerRunParam = DockerRunParam (HostName -> String) instance Show DockerRunParam where show (DockerRunParam a) = a "" + +data ChrootInfo = ChrootInfo + { _chroots :: M.Map FilePath Host + } + deriving (Show) + +instance Monoid ChrootInfo where + mempty = ChrootInfo mempty + mappend old new = ChrootInfo + { _chroots = M.union (_chroots old) (_chroots new) + } + +instance Eq ChrootInfo where + x == y = and + [ M.keys (_chroots x) == M.keys (_chroots y) + ] -- cgit v1.2.3