diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index 3828535..edf12c2e 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} -- | Docker support for propellor -- @@ -9,6 +9,7 @@ module Propellor.Property.Docker where import Propellor import Propellor.SimpleSh +import Propellor.Types.Attr import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Docker.Shim as Shim @@ -32,6 +33,25 @@ configured = Property "docker configured" go `requires` installed installed :: Property installed = Apt.installed ["docker.io"] +-- | A short descriptive name for a container. +-- Should not contain whitespace or other unusual characters, +-- only [a-zA-Z0-9_-] are allowed +type ContainerName = String + +-- | Starts accumulating the properties of a Docker container. +-- +-- > container "web-server" "debian" +-- > & publish "80:80" +-- > & Apt.installed {"apache2"] +-- > & ... +container :: ContainerName -> Image -> Host +container cn image = Host [] (\_ -> attr) + where + attr = (newAttr (cn2hn cn)) { _dockerImage = Just image } + +cn2hn :: ContainerName -> HostName +cn2hn cn = cn ++ ".docker" + -- | 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. @@ -39,24 +59,24 @@ installed = Apt.installed ["docker.io"] -- Reverting this property ensures that the container is stopped and -- removed. docked - :: (HostName -> ContainerName -> Maybe (Container)) + :: [Host] -> ContainerName -> RevertableProperty -docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) +docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) where go desc a = Property (desc ++ " " ++ cn) $ do hn <- getHostName let cid = ContainerId hn cn - ensureProperties [findContainer findc hn cn $ a cid] + ensureProperties [findContainer hosts cid cn $ a cid] - setup cid (Container image containerprops) = + setup cid (Container image runparams) = provisionContainer cid `requires` - runningContainer cid image containerprops + runningContainer cid image runparams `requires` installed - teardown cid (Container image _) = + teardown cid (Container image _runparams) = combineProperties ("undocked " ++ fromContainerId cid) [ stoppedContainer cid , Property ("cleaned up " ++ fromContainerId cid) $ @@ -67,20 +87,33 @@ docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown ] findContainer - :: (HostName -> ContainerName -> Maybe (Container)) - -> HostName + :: [Host] + -> ContainerId -> ContainerName -> (Container -> Property) -> Property -findContainer findc hn cn mk = case findc hn cn of +findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of Nothing -> cantfind - Just container -> mk container + Just h -> maybe cantfind mk (mkContainer cid h) where - cid = ContainerId hn cn - cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do - liftIO $ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid + 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 + <$> _dockerImage attr + <*> pure (map (\a -> a hn) (_dockerRunParams attr)) + where + attr = hostAttr h' + h' = h + -- expose propellor directory inside the container + & volume (localdir++":"++localdir) + -- name the container in a predictable way so we + -- and the user can easily find it later + & name (fromContainerId cid) + -- | Causes *any* docker images that are not in use by running containers to -- be deleted. And deletes any containers that propellor has set up -- before that are not currently running. Does not delete any containers @@ -98,30 +131,7 @@ garbageCollected = propertyList "docker garbage collected" gcimages = Property "docker images garbage collected" $ do liftIO $ report <$> (mapM removeImage =<< listImages) --- | Pass to defaultMain to add docker containers. --- You need to provide the function mapping from --- HostName and ContainerName to the Container to use. -containerProperties - :: (HostName -> ContainerName -> Maybe (Container)) - -> (HostName -> Maybe [Property]) -containerProperties findcontainer = \h -> case toContainerId h of - Nothing -> Nothing - Just cid@(ContainerId hn cn) -> - case findcontainer hn cn of - Nothing -> Nothing - Just (Container _ cprops) -> - Just $ map (containerDesc cid) $ - fromContainerized cprops - --- | This type is used to configure a docker container. --- It has an image, and a list of Properties, but these --- properties are Containerized; they can specify --- things about the container's configuration, in --- addition to properties of the system inside the --- container. -data Container = Container Image [Containerized Property] - -data Containerized a = Containerized [HostName -> RunParam] a +data Container = Container Image [RunParam] -- | Parameters to pass to `docker run` when creating a container. type RunParam = String @@ -129,62 +139,50 @@ type RunParam = String -- | A docker image, that can be used to run a container. type Image = String --- | A short descriptive name for a container. --- Should not contain whitespace or other unusual characters, --- only [a-zA-Z0-9_.-] are allowed -type ContainerName = String - --- | Lift a Property to apply inside a container. -inside1 :: Property -> Containerized Property -inside1 = Containerized [] - -inside :: [Property] -> Containerized Property -inside = Containerized [] . combineProperties "provision" - -- | Set custom dns server for container. -dns :: String -> Containerized Property +dns :: String -> AttrProperty dns = runProp "dns" -- | Set container host name. -hostname :: String -> Containerized Property +hostname :: String -> AttrProperty hostname = runProp "hostname" -- | Set name for container. (Normally done automatically.) -name :: String -> Containerized Property +name :: String -> AttrProperty name = runProp "name" -- | Publish a container's port to the host -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Containerized Property +publish :: String -> AttrProperty publish = runProp "publish" -- | Username or UID for container. -user :: String -> Containerized Property +user :: String -> AttrProperty user = runProp "user" -- | Mount a volume -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- With just a directory, creates a volume in the container. -volume :: String -> Containerized Property +volume :: String -> AttrProperty volume = runProp "volume" -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Containerized Property +volumes_from :: ContainerName -> AttrProperty volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> Containerized Property +workdir :: String -> AttrProperty workdir = runProp "workdir" -- | Memory limit for container. --Format: , where unit = b, k, m or g -memory :: String -> Containerized Property +memory :: String -> AttrProperty memory = runProp "memory" -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Containerized Property +link :: ContainerName -> ContainerAlias -> AttrProperty link linkwith alias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias @@ -203,16 +201,6 @@ data ContainerId = ContainerId HostName ContainerName data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] deriving (Read, Show, Eq) -getRunParams :: HostName -> [Containerized a] -> [RunParam] -getRunParams hn l = concatMap get l - where - get (Containerized ps _) = map (\a -> a hn ) ps - -fromContainerized :: forall a. [Containerized a] -> [a] -fromContainerized l = map get l - where - get (Containerized _ a) = a - ident2id :: ContainerIdent -> ContainerId ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn @@ -233,16 +221,13 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix myContainerSuffix :: String myContainerSuffix = ".propellor" -containerFrom :: Image -> [Containerized Property] -> Container -containerFrom = Container - containerDesc :: ContainerId -> Property -> Property containerDesc cid p = p `describe` desc where desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p -runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property -runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do +runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ Property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l then do @@ -275,14 +260,6 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci extractident :: [Resp] -> Maybe ContainerIdent extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout - runps = getRunParams hn $ containerprops ++ - -- expose propellor directory inside the container - [ volume (localdir++":"++localdir) - -- name the container in a predictable way so we - -- and the user can easily find it later - , name (fromContainerId cid) - ] - go img = do liftIO $ do clearProvisionedFlag cid @@ -425,17 +402,18 @@ listContainers status = listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Containerized Property -runProp field val = Containerized - [\_ -> "--" ++ param] - (Property (param) (return NoChange)) +runProp :: String -> RunParam -> AttrProperty +runProp field val = AttrProperty prop $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] } where param = field++"="++val + prop = Property (param) (return NoChange) -genProp :: String -> (HostName -> RunParam) -> Containerized Property -genProp field mkval = Containerized - [\h -> "--" ++ field ++ "=" ++ mkval h] - (Property field (return NoChange)) +genProp :: String -> (HostName -> RunParam) -> AttrProperty +genProp field mkval = AttrProperty prop $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] } + where + prop = Property field (return NoChange) -- | The ContainerIdent of a container is written to -- /.propellor-ident inside it. This can be checked to see if diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs index 20e5e63..7016172 100644 --- a/Propellor/Types/Attr.hs +++ b/Propellor/Types/Attr.hs @@ -6,11 +6,23 @@ import qualified Data.Set as S data Attr = Attr { _hostname :: HostName , _cnames :: S.Set Domain + + , _dockerImage :: Maybe String + , _dockerRunParams :: [HostName -> String] } - deriving (Eq, Show) + +instance Eq Attr where + x == y = and + [ _hostname x == _hostname y + , _cnames x == _cnames y + + , _dockerImage x == _dockerImage y + , let simpl v = map (\a -> a "") (_dockerRunParams v) + in simpl x == simpl y + ] newAttr :: HostName -> Attr -newAttr hn = Attr hn S.empty +newAttr hn = Attr hn S.empty Nothing [] type HostName = String type Domain = String diff --git a/config-joey.hs b/config-joey.hs index 92aa909..093ed8a 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -11,7 +11,7 @@ import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User import qualified Propellor.Property.Hostname as Hostname -import qualified Propellor.Property.Reboot as Reboot +--import qualified Propellor.Property.Reboot as Reboot import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Dns as Dns import qualified Propellor.Property.OpenId as OpenId @@ -23,7 +23,13 @@ import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites hosts :: [Host] hosts = - [ host "clam.kitenet.net" + -- My laptop + [ host "darkstar.kitenet.net" + & Docker.configured + & Apt.buildDep ["git-annex"] `period` Daily + + -- Nothing super-important lives here. + , host "clam.kitenet.net" & cleanCloudAtCost & standardSystem Unstable & Apt.unattendedUpgrades @@ -31,26 +37,31 @@ hosts = & Tor.isBridge & Docker.configured & cname "shell.olduse.net" - `requires` JoeySites.oldUseNetShellBox - & "openid.kitenet.net" - `cnameFor` Docker.docked container + & JoeySites.oldUseNetShellBox + + & cname "openid.kitenet.net" + & Docker.docked hosts "openid-provider" `requires` Apt.installed ["ntp"] - & "ancient.kitenet.net" - `cnameFor` Docker.docked container + + & cname "ancient.kitenet.net" + & Docker.docked hosts "ancient-kitenet" + & Docker.garbageCollected `period` Daily & Apt.installed ["git-annex", "mtr", "screen"] + -- Orca is the main git-annex build box. , host "orca.kitenet.net" & standardSystem Unstable & Hostname.sane & Apt.unattendedUpgrades & Docker.configured - & Docker.docked container "amd64-git-annex-builder" - & Docker.docked container "i386-git-annex-builder" - ! Docker.docked container "armel-git-annex-builder-companion" - ! Docker.docked container "armel-git-annex-builder" + & Docker.docked hosts "amd64-git-annex-builder" + & Docker.docked hosts "i386-git-annex-builder" + ! Docker.docked hosts "armel-git-annex-builder-companion" + ! Docker.docked hosts "armel-git-annex-builder" & Docker.garbageCollected `period` Daily & Apt.buildDep ["git-annex"] `period` Daily + -- Important stuff that needs not too much memory or CPU. , host "diatom.kitenet.net" & standardSystem Stable @@ -71,83 +82,60 @@ hosts = -- ssh keys for branchable and github repo hooks -- gitweb -- downloads.kitenet.net setup (including ssh key to turtle) - -- My laptop - , host "darkstar.kitenet.net" - & Docker.configured - & Apt.buildDep ["git-annex"] `period` Daily - ] --- | This is where Docker containers are set up. A container --- can vary by hostname where it's used, or be the same everywhere. -container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) -container _parenthost name -{- + -------------------------------------------------------------------- + -- Docker Containers ----------------------------------- \o/ ----- + -------------------------------------------------------------------- + -- Simple web server, publishing the outside host's /var/www - | name == "webserver" = Just $ standardContainer Stable "amd64" - [ Docker.publish "8080:80" - , Docker.volume "/var/www:/var/www" - , Docker.inside $ props - & Apt.serviceInstalledRunning "apache2" - ] + , standardContainer "webserver" Stable "amd64" + & Docker.publish "8080:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" -- My own openid provider. Uses php, so containerized for security -- and administrative sanity. - | name == "openid-provider" = Just $ standardContainer Stable "amd64" - [ Docker.publish "8081:80" - , Docker.inside $ props - & OpenId.providerFor ["joey", "liw"] - "openid.kitenet.net:8081" - ] + , standardContainer "openid-provider" Stable "amd64" + & Docker.publish "8081:80" + & OpenId.providerFor ["joey", "liw"] + "openid.kitenet.net:8081" - | name == "ancient-kitenet" = Just $ standardContainer Stable "amd64" - [ Docker.publish "1994:80" - , Docker.inside $ props - & Apt.serviceInstalledRunning "apache2" - & Apt.installed ["git"] - & scriptProperty - [ "cd /var/" - , "rm -rf www" - , "git clone git://git.kitenet.net/kitewiki www" - , "cd www" - , "git checkout remotes/origin/old-kitenet.net" - ] `flagFile` "/var/www/blastfromthepast.html" - ] + , standardContainer "ancient-kitenet" Stable "amd64" + & Docker.publish "1994:80" + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["git"] + & scriptProperty + [ "cd /var/" + , "rm -rf www" + , "git clone git://git.kitenet.net/kitewiki www" + , "cd www" + , "git checkout remotes/origin/old-kitenet.net" + ] `flagFile` "/var/www/blastfromthepast.html" + -- git-annex autobuilder containers + , gitAnnexBuilder "amd64" 15 + , gitAnnexBuilder "i386" 45 -- armel builder has a companion container that run amd64 and -- runs the build first to get TH splices. They share a home -- directory, and need to have the same versions of all haskell -- libraries installed. - | name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom + , Docker.container "armel-git-annex-builder-companion" (image $ System (Debian Unstable) "amd64") - [ Docker.volume GitAnnexBuilder.homedir - , Docker.inside $ props - & Apt.unattendedUpgrades - ] - | name == "armel-git-annex-builder" = Just $ Docker.containerFrom + & Docker.volume GitAnnexBuilder.homedir + & Apt.unattendedUpgrades + , Docker.container "armel-git-annex-builder" (image $ System (Debian Unstable) "armel") - [ Docker.link (name ++ "-companion") "companion" - , Docker.volumes_from (name ++ "-companion") - , Docker.inside $ props --- & GitAnnexBuilder.builder "armel" "15 * * * *" True - & Apt.unattendedUpgrades - ] - - | "-git-annex-builder" `isSuffixOf` name = - let arch = takeWhile (/= '-') name - in Just $ Docker.containerFrom - (image $ System (Debian Unstable) arch) - [ Docker.inside $ props - & GitAnnexBuilder.builder arch "15 * * * *" True - & Apt.unattendedUpgrades - ] --} - | otherwise = Nothing + & Docker.link "armel-git-annex-builder-companion" "companion" + & Docker.volumes_from "armel-git-annex-builder-companion" +-- & GitAnnexBuilder.builder "armel" "15 * * * *" True + & Apt.unattendedUpgrades + ] --- | Docker images I prefer to use. -image :: System -> Docker.Image -image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch -image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch -image _ = "debian-stable-official" -- does not currently exist! +gitAnnexBuilder :: Architecture -> Int -> Host +gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder") + (image $ System (Debian Unstable) arch) + & GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True + & Apt.unattendedUpgrades -- This is my standard system setup standardSystem :: DebianSuite -> Property @@ -171,16 +159,19 @@ standardSystem suite = template "standard system" $ props & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] `onChange` Apt.autoRemove -{- -- This is my standard container setup, featuring automatic upgrades. -standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container -standardContainer suite arch ps = Docker.containerFrom - (image $ System (Debian suite) arch) $ - [ Docker.inside $ props - & Apt.stdSourcesList suite - & Apt.unattendedUpgrades - ] ++ ps --} +standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host +standardContainer name suite arch = Docker.container name (image system) + & Apt.stdSourcesList suite + & Apt.unattendedUpgrades + where + system = System (Debian suite) arch + +-- | Docker images I prefer to use. +image :: System -> Docker.Image +image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch +image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch +image _ = "debian-stable-official" -- does not currently exist! -- Clean up a system as installed by cloudatcost.com cleanCloudAtCost :: Property diff --git a/config-simple.hs b/config-simple.hs index 8011e97..23a760c 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -16,38 +16,32 @@ import qualified Propellor.Property.User as User --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker -main :: IO () -main = defaultMain [host, Docker.containerProperties container] - --- | This is where the system's HostName, either as returned by uname --- or one specified on the command line, is converted into a list of --- Properties for that system. --- +-- The hosts propellor knows about. -- Edit this to configure propellor! -host :: HostName -> Maybe [Property] -host "mybox.example.com" = Just $ props - & Apt.stdSourcesList Unstable - `onChange` Apt.upgrade - & Apt.unattendedUpgrades - & Apt.installed ["etckeeper"] - & Apt.installed ["ssh"] - & User.hasSomePassword "root" - & Network.ipv6to4 - & File.dirExists "/var/www" - & Docker.docked container "webserver" - & Docker.garbageCollected `period` Daily - & Cron.runPropellor "30 * * * *" --- add more hosts here... ---host "foo.example.com" = -host _ = Nothing +hosts :: [Host] +hosts = + [ host "mybox.example.com" + & Apt.stdSourcesList Unstable + `onChange` Apt.upgrade + & Apt.unattendedUpgrades + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh"] + & User.hasSomePassword "root" + & Network.ipv6to4 + & File.dirExists "/var/www" + & Docker.docked hosts "webserver" + & Docker.garbageCollected `period` Daily + & Cron.runPropellor "30 * * * *" --- | This is where Docker containers are set up. A container --- can vary by hostname where it's used, or be the same everywhere. -container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) -container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable" - [ Docker.publish "80:80" - , Docker.volume "/var/www:/var/www" - , Docker.inside $ props + -- A generic webserver in a Docker container. + , Docker.container "webserver" "joeyh/debian-unstable" + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" & Apt.serviceInstalledRunning "apache2" + + -- add more hosts here... + --, host "foo.example.com" = ... ] -container _ _ = Nothing + +main :: IO () +main = defaultMain hosts