From d49d2518979c7b985af8f00741f2a91bcd511024 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 23:11:34 -0400 Subject: separate docker container type Docker containers are now a separate data type, cannot be included in the main host list, and are instead passed to Docker.docked. (API change) --- src/Propellor/Property.hs | 33 ++++++------ src/Propellor/Property/Docker.hs | 63 ++++++++++------------ .../Property/SiteSpecific/GitAnnexBuilder.hs | 10 ++-- src/Propellor/Types/Info.hs | 14 ++--- 4 files changed, 54 insertions(+), 66 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 7000b2a3..bf69ff60 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -144,27 +144,28 @@ unrevertable (RevertableProperty p1 _p2) = p1 host :: HostName -> Host host hn = Host hn [] mempty --- | Adds a property to a Host --- --- Can add Properties and RevertableProperties -(&) :: IsProp p => Host -> p -> Host -(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - -infixl 1 & +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. -(!) :: Host -> RevertableProperty -> Host +(!) :: Hostlike h => h -> RevertableProperty -> h h ! p = h & revert p -infixl 1 ! - --- | 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 => Host -> p -> Host -(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) - infixl 1 &^ +infixl 1 & +infixl 1 ! -- Changes the action that is performed to satisfy a property. adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 96405108..ce9fb7d7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -16,6 +16,7 @@ module Propellor.Property.Docker ( tweaked, Image, ContainerName, + Container, -- * Container configuration dns, hostname, @@ -71,55 +72,60 @@ configured = prop `requires` installed -- only [a-zA-Z0-9_-] are allowed type ContainerName = String --- | Starts accumulating the properties of a Docker container. +-- | A docker container. +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) + +-- | Builds a Container with a given name, image, and properties. -- -- > container "web-server" "debian" -- > & publish "80:80" -- > & Apt.installed {"apache2"] -- > & ... -container :: ContainerName -> Image -> Host -container cn image = Host hn [] info +container :: ContainerName -> Image -> Container +container cn image = Container image (Host hn [] info) where - info = dockerInfo $ mempty { _dockerImage = Val image } + info = dockerInfo mempty hn = cn2hn cn cn2hn :: ContainerName -> HostName cn2hn cn = cn ++ ".docker" --- | Ensures that a docker container is set up and running, finding --- its configuration in the passed list of hosts. +-- | Ensures that a docker container is set up and running. -- -- The container has its own Properties which are handled by running -- propellor inside the container. -- -- When the container's Properties include DNS info, such as a CNAME, --- that is propigated to the Info of the host(s) it's docked in. +-- that is propigated to the Info of the Host it's docked in. -- -- Reverting this property ensures that the container is stopped and -- removed. docked - :: [Host] - -> ContainerName + :: Container -> RevertableProperty -docked hosts cn = RevertableProperty - ((maybe id propigateInfo mhost) (go "docked" setup)) +docked ctr@(Container _ h) = RevertableProperty + (propigateInfo h (go "docked" setup)) (go "undocked" teardown) where + cn = hostName h + go desc a = property (desc ++ " " ++ cn) $ do hn <- asks hostName let cid = ContainerId hn cn - ensureProperties [findContainer mhost cid cn $ a cid] - - mhost = findHostNoAlias hosts (cn2hn cn) + ensureProperties [a cid (mkContainerInfo cid ctr)] - setup cid (Container image runparams) = + setup cid (ContainerInfo image runparams) = provisionContainer cid `requires` runningContainer cid image runparams `requires` installed - teardown cid (Container image _runparams) = + teardown cid (ContainerInfo image _runparams) = combineProperties ("undocked " ++ fromContainerId cid) [ stoppedContainer cid , property ("cleaned up " ++ fromContainerId cid) $ @@ -136,26 +142,11 @@ propigateInfo (Host _ _ containerinfo) p = dnsprops = map addDNS (S.toList $ _dns containerinfo) privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) -findContainer - :: Maybe Host - -> ContainerId - -> ContainerName - -> (Container -> Property) - -> Property -findContainer mhost cid cn mk = case mhost of - Nothing -> cantfind - Just h -> maybe cantfind mk (mkContainer cid h) - where - cantfind = containerDesc cid $ property "" $ do - liftIO $ warningMessage $ - "missing definition for docker container \"" ++ cn2hn cn - return FailedChange - -mkContainer :: ContainerId -> Host -> Maybe Container -mkContainer cid@(ContainerId hn _cn) h = Container - <$> fromVal (_dockerImage info) - <*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info)) +mkContainerInfo :: ContainerId -> Container -> ContainerInfo +mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = + ContainerInfo img runparams where + runparams = map (\mkparam -> mkparam hn) (_dockerRunParams info) info = _dockerinfo $ hostInfo h' h' = h -- Restart by default so container comes up on @@ -209,7 +200,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg cmdline = "cgroup_enable=memory swapaccount=1" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" -data Container = Container Image [RunParam] +data ContainerInfo = ContainerInfo Image [RunParam] -- | Parameters to pass to `docker run` when creating a container. type RunParam = String diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 901eba2e..0208dea6 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] cabalupdated = homedir ".cabal" "packages" "hackage.haskell.org" "00-index.cache" -standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host +standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") (dockerImage $ System (Debian Testing) arch) & os (System (Debian Testing) arch) @@ -101,14 +101,14 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta & autobuilder arch (show buildminute ++ " * * * *") timeout & Docker.tweaked -androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container androidAutoBuilderContainer dockerImage crontimes timeout = androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir & Apt.unattendedUpgrades & autobuilder "android" crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host +androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name (dockerImage osver) & os osver @@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe -- armel builder has a companion container using amd64 that -- runs the build first to get TH splices. They need -- to have the same versions of all haskell libraries installed. -armelCompanionContainer :: (System -> Docker.Image) -> Host +armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" (dockerImage $ System (Debian Unstable) "amd64") & os (System (Debian Testing) "amd64") @@ -156,7 +156,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder- & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") & Docker.tweaked -armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" (dockerImage $ System (Debian Unstable) "armel") & os (System (Debian Testing) "armel") diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index de072aa0..6aba1f9f 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -45,26 +45,22 @@ fromVal (Val a) = Just a fromVal NoVal = Nothing data DockerInfo = DockerInfo - { _dockerImage :: Val String - , _dockerRunParams :: [HostName -> String] + { _dockerRunParams :: [HostName -> String] } instance Eq DockerInfo where x == y = and - [ _dockerImage x == _dockerImage y - , let simpl v = map (\a -> a "") (_dockerRunParams v) + [ let simpl v = map (\a -> a "") (_dockerRunParams v) in simpl x == simpl y ] instance Monoid DockerInfo where - mempty = DockerInfo mempty mempty + mempty = DockerInfo mempty mappend old new = DockerInfo - { _dockerImage = _dockerImage old <> _dockerImage new - , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new } instance Show DockerInfo where show a = unlines - [ "docker image " ++ show (_dockerImage a) - , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + [ "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] -- cgit v1.2.3