summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-04-10 23:20:12 -0400
committerJoey Hess2014-04-10 23:20:12 -0400
commit839e60bbcedf99efb7ec7fc8330585006ea1f222 (patch)
tree3e7c90939f6b1dc4a10a4372c8fa0768017f3a1f
parent50cd59cb3e6d20afe48a50fa9dc0c3a9cf9d9960 (diff)
propellor spin
-rw-r--r--Propellor/Property/Docker.hs160
-rw-r--r--Propellor/Types/Attr.hs16
-rw-r--r--config-joey.hs157
-rw-r--r--config-simple.hs56
4 files changed, 182 insertions, 207 deletions
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index 3828535c..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: <number><optional unit>, 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 20e5e631..70161725 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 92aa9093..093ed8a2 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 8011e97e..23a760c8 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