starting work on a Chroot module

factored out info up-propigation code rom Docker
This commit is contained in:
Joey Hess 2014-11-20 14:06:55 -04:00
parent cc8bbcf95b
commit b8b746a7f1
8 changed files with 162 additions and 49 deletions

View File

@ -24,7 +24,7 @@ import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
import qualified Propellor.Property.HostingProvider.Linode as Linode import qualified Propellor.Property.HostingProvider.Linode as Linode
@ -80,8 +80,12 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
! Ssh.listenPort 80 ! Ssh.listenPort 80
! Ssh.listenPort 443 ! Ssh.listenPort 443
& Debootstrap.built "/tmp/chroot" (System (Debian Unstable) "amd64") [] & Chroot.provisioned testChroot
testChroot :: Chroot.Chroot
testChroot = Chroot.chroot "/tmp/chroot" (System (Debian Unstable) "amd64")
& File.hasContent "/foo" ["hello"]
orca :: Host orca :: Host
orca = standardSystem "orca.kitenet.net" Unstable "amd64" orca = standardSystem "orca.kitenet.net" Unstable "amd64"
[ "Main git-annex build box." ] [ "Main git-annex build box." ]

View File

@ -74,6 +74,7 @@ Library
Propellor.Property.Apt Propellor.Property.Apt
Propellor.Property.Cmd Propellor.Property.Cmd
Propellor.Property.Hostname Propellor.Property.Hostname
Propellor.Property.Chroot
Propellor.Property.Cron Propellor.Property.Cron
Propellor.Property.Debootstrap Propellor.Property.Debootstrap
Propellor.Property.Dns Propellor.Property.Dns
@ -102,6 +103,7 @@ Library
Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder Propellor.Property.SiteSpecific.GitAnnexBuilder
Propellor.Host
Propellor.CmdLine Propellor.CmdLine
Propellor.Info Propellor.Info
Propellor.Message Propellor.Message

View File

@ -33,6 +33,7 @@ module Propellor (
module Propellor.Types module Propellor.Types
, module Propellor.Property , module Propellor.Property
, module Propellor.Property.Cmd , module Propellor.Property.Cmd
, module Propellor.Host
, module Propellor.Info , module Propellor.Info
, module Propellor.PrivData , module Propellor.PrivData
, module Propellor.Engine , module Propellor.Engine
@ -51,6 +52,7 @@ import Propellor.PrivData
import Propellor.Message import Propellor.Message
import Propellor.Exception import Propellor.Exception
import Propellor.Info import Propellor.Info
import Propellor.Host
import Utility.PartialPrelude as X import Utility.PartialPrelude as X
import Utility.Process as X import Utility.Process as X

64
src/Propellor/Host.hs Normal file
View File

@ -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)

View File

@ -3,6 +3,7 @@
module Propellor.Property where module Propellor.Property where
import System.Directory import System.Directory
import System.FilePath
import Control.Monad import Control.Monad
import Data.Monoid import Data.Monoid
import Control.Monad.IfElse import Control.Monad.IfElse
@ -12,7 +13,6 @@ import Propellor.Types
import Propellor.Info import Propellor.Info
import Propellor.Engine import Propellor.Engine
import Utility.Monad import Utility.Monad
import System.FilePath
-- Constructs a Property. -- Constructs a Property.
property :: Desc -> Propellor Result -> Property property :: Desc -> Propellor Result -> Property
@ -135,38 +135,6 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
unrevertable :: RevertableProperty -> Property unrevertable :: RevertableProperty -> Property
unrevertable (RevertableProperty p1 _p2) = p1 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. -- Changes the action that is performed to satisfy a property.
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }

View File

@ -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

View File

@ -52,7 +52,6 @@ import System.Posix.Process
import Prelude hiding (init) import Prelude hiding (init)
import Data.List hiding (init) import Data.List hiding (init)
import Data.List.Utils import Data.List.Utils
import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
installed :: Property installed :: Property
@ -78,8 +77,10 @@ data Container = Container Image Host
instance Hostlike Container where instance Hostlike Container where
(Container i h) & p = Container i (h & p) (Container i h) & p = Container i (h & p)
(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" -- > container "web-server" "debian"
-- > & publish "80:80" -- > & 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 -- Reverting this property ensures that the container is stopped and
-- removed. -- removed.
docked docked :: Container -> RevertableProperty
:: Container
-> RevertableProperty
docked ctr@(Container _ h) = RevertableProperty docked ctr@(Container _ h) = RevertableProperty
(propigateInfo ctr (go "docked" setup)) (propigateContainerInfo ctr (go "docked" setup))
(go "undocked" teardown) (go "undocked" teardown)
where where
cn = hostName h cn = hostName h
@ -131,14 +130,12 @@ docked ctr@(Container _ h) = RevertableProperty
] ]
] ]
propigateInfo :: Container -> Property -> Property propigateContainerInfo :: Container -> Property -> Property
propigateInfo (Container _ h@(Host hn _ containerinfo)) p = propigateContainerInfo ctr@(Container _ h) p =
combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops propigateInfo ctr p (<> dockerinfo)
where where
p' = p { propertyInfo = propertyInfo p <> dockerinfo } dockerinfo = dockerInfo $
dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h } mempty { _dockerContainers = M.singleton (hostName h) h }
dnsprops = map addDNS (S.toList $ _dns containerinfo)
privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
mkContainerInfo :: ContainerId -> Container -> ContainerInfo mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =

View File

@ -25,6 +25,7 @@ module Propellor.Types
, fromVal , fromVal
, DockerInfo(..) , DockerInfo(..)
, DockerRunParam(..) , DockerRunParam(..)
, ChrootInfo(..)
, module Propellor.Types.OS , module Propellor.Types.OS
, module Propellor.Types.Dns , module Propellor.Types.Dns
) where ) where
@ -166,11 +167,12 @@ data Info = Info
, _dns :: S.Set Dns.Record , _dns :: S.Set Dns.Record
, _namedconf :: Dns.NamedConfMap , _namedconf :: Dns.NamedConfMap
, _dockerinfo :: DockerInfo , _dockerinfo :: DockerInfo
, _chrootinfo :: ChrootInfo
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Monoid Info where 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 mappend old new = Info
{ _os = _os old <> _os new { _os = _os old <> _os new
, _privDataFields = _privDataFields old <> _privDataFields new , _privDataFields = _privDataFields old <> _privDataFields new
@ -179,6 +181,7 @@ instance Monoid Info where
, _dns = _dns old <> _dns new , _dns = _dns old <> _dns new
, _namedconf = _namedconf old <> _namedconf new , _namedconf = _namedconf old <> _namedconf new
, _dockerinfo = _dockerinfo old <> _dockerinfo new , _dockerinfo = _dockerinfo old <> _dockerinfo new
, _chrootinfo = _chrootinfo old <> _chrootinfo new
} }
data Val a = Val a | NoVal data Val a = Val a | NoVal
@ -217,3 +220,19 @@ newtype DockerRunParam = DockerRunParam (HostName -> String)
instance Show DockerRunParam where instance Show DockerRunParam where
show (DockerRunParam a) = a "" 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)
]