propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Docker.hs (24611B)


      1 {-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
      2 
      3 -- | Maintainer: currently unmaintained; your name here!
      4 --
      5 -- Docker support for propellor
      6 --
      7 -- The existance of a docker container is just another Property of a system,
      8 -- which propellor can set up. See config.hs for an example.
      9 
     10 module Propellor.Property.Docker (
     11 	-- * Host properties
     12 	installed,
     13 	configured,
     14 	container,
     15 	docked,
     16 	imageBuilt,
     17 	imagePulled,
     18 	memoryLimited,
     19 	garbageCollected,
     20 	tweaked,
     21 	Image(..),
     22 	latestImage,
     23 	ContainerName,
     24 	Container(..),
     25 	HasImage(..),
     26 	-- * Container configuration
     27 	dns,
     28 	hostname,
     29 	Publishable,
     30 	publish,
     31 	expose,
     32 	user,
     33 	Mountable,
     34 	volume,
     35 	volumes_from,
     36 	workdir,
     37 	memory,
     38 	cpuShares,
     39 	link,
     40 	environment,
     41 	ContainerAlias,
     42 	restartAlways,
     43 	restartOnFailure,
     44 	restartNever,
     45 	-- * Internal use
     46 	init,
     47 	chain,
     48 ) where
     49 
     50 import Propellor.Base hiding (init)
     51 import Propellor.Types.Docker
     52 import Propellor.Types.Container
     53 import Propellor.Types.Core
     54 import Propellor.Types.CmdLine
     55 import Propellor.Types.Info
     56 import Propellor.Container
     57 import qualified Propellor.Property.File as File
     58 import qualified Propellor.Property.Apt as Apt
     59 import qualified Propellor.Property.Cmd as Cmd
     60 import qualified Propellor.Property.Pacman as Pacman
     61 import qualified Propellor.Shim as Shim
     62 import Utility.Path
     63 import Utility.ThreadScheduler
     64 import Utility.Split
     65 
     66 import Control.Concurrent.Async hiding (link)
     67 import System.Posix.Directory
     68 import System.Posix.Process
     69 import Prelude hiding (init)
     70 import Data.List hiding (init)
     71 import qualified Data.Map as M
     72 import System.Console.Concurrent
     73 
     74 installed :: Property (DebianLike + ArchLinux)
     75 installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"]
     76 
     77 -- | Configures docker with an authentication file, so that images can be
     78 -- pushed to index.docker.io. Optional.
     79 configured :: Property (HasInfo + DebianLike)
     80 configured = prop `requires` installed
     81   where
     82 	prop :: Property (HasInfo + DebianLike)
     83 	prop = withPrivData src anyContext $ \getcfg ->
     84 		property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
     85 			"/root/.dockercfg" `File.hasContent` privDataLines cfg
     86 	src = PrivDataSourceFileFromCommand DockerAuthentication
     87 		"/root/.dockercfg" "docker login"
     88 
     89 -- | A short descriptive name for a container.
     90 -- Should not contain whitespace or other unusual characters,
     91 -- only [a-zA-Z0-9_-] are allowed
     92 type ContainerName = String
     93 
     94 -- | A docker container.
     95 data Container = Container Image Host
     96 
     97 instance IsContainer Container where
     98 	containerProperties (Container _ h) = containerProperties h
     99 	containerInfo (Container _ h) = containerInfo h
    100 	setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps)
    101 
    102 class HasImage a where
    103 	getImageName :: a -> Image
    104 
    105 instance HasImage Image where
    106 	getImageName = id
    107 
    108 instance HasImage Container where
    109 	getImageName (Container i _) = i
    110 
    111 -- | Defines a Container with a given name, image, and properties.
    112 -- Add properties to configure the Container.
    113 --
    114 -- > container "web-server" (latestImage "debian") $ props
    115 -- >    & publish "80:80"
    116 -- >    & Apt.installed {"apache2"]
    117 -- >    & ...
    118 container :: ContainerName -> Image -> Props metatypes -> Container
    119 container cn image (Props ps) = Container image (Host cn ps info)
    120   where
    121 	info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
    122 
    123 -- | Ensures that a docker container is set up and running.
    124 --
    125 -- The container has its own Properties which are handled by running
    126 -- propellor inside the container.
    127 --
    128 -- When the container's Properties include DNS info, such as a CNAME,
    129 -- that is propagated to the Info of the Host it's docked in.
    130 --
    131 -- Reverting this property ensures that the container is stopped and
    132 -- removed.
    133 docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
    134 docked ctr@(Container _ h) =
    135 	(propagateContainerInfo ctr (go "docked" setup))
    136 		<!>
    137 	(go "undocked" teardown)
    138   where
    139 	cn = hostName h
    140 
    141 	go desc a = property' (desc ++ " " ++ cn) $ \w -> do
    142 		hn <- asks hostName
    143 		let cid = ContainerId hn cn
    144 		ensureProperty w $ a cid (mkContainerInfo cid ctr)
    145 
    146 	setup :: ContainerId -> ContainerInfo -> Property Linux
    147 	setup cid (ContainerInfo image runparams) =
    148 		provisionContainer cid
    149 			`requires`
    150 		runningContainer cid image runparams
    151 			`requires`
    152 		installed
    153 
    154 	teardown :: ContainerId -> ContainerInfo -> Property Linux
    155 	teardown cid (ContainerInfo image _runparams) =
    156 		combineProperties ("undocked " ++ fromContainerId cid) $ toProps
    157 			[ stoppedContainer cid
    158 			, property ("cleaned up " ++ fromContainerId cid) $
    159 				liftIO $ report <$> mapM id
    160 					[ removeContainer cid
    161 					, removeImage image
    162 					]
    163 			]
    164 
    165 -- | Build the image from a directory containing a Dockerfile.
    166 imageBuilt :: HasImage c => FilePath -> c -> Property Linux
    167 imageBuilt directory ctr = built `describe` msg
    168   where
    169 	msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
    170 	built :: Property Linux
    171 	built = tightenTargets $
    172 		Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
    173 			`assume` MadeChange
    174 	workDir p = p { cwd = Just directory }
    175 	image = getImageName ctr
    176 
    177 -- | Pull the image from the standard Docker Hub registry.
    178 imagePulled :: HasImage c => c -> Property Linux
    179 imagePulled ctr = pulled `describe` msg
    180   where
    181 	msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
    182 	pulled :: Property Linux
    183 	pulled = tightenTargets $ 
    184 		Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
    185 			`assume` MadeChange
    186 	image = getImageName ctr
    187 
    188 propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
    189 propagateContainerInfo ctr@(Container _ h) p = 
    190 	propagateContainer cn ctr normalContainerInfo $
    191 		p `addInfoProperty` dockerinfo
    192   where
    193 	dockerinfo = dockerInfo $
    194 		mempty { _dockerContainers = M.singleton cn h }
    195 	cn = hostName h
    196 
    197 mkContainerInfo :: ContainerId -> Container -> ContainerInfo
    198 mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
    199 	ContainerInfo img runparams
    200   where
    201 	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
    202 		(_dockerRunParams info)
    203 	info = fromInfo $ hostInfo h'
    204 	h' = setContainerProps h $ containerProps h
    205 		-- Restart by default so container comes up on
    206 		-- boot or when docker is upgraded.
    207 		&^ restartAlways
    208 		-- Expose propellor directory inside the container.
    209 		& volume (localdir++":"++localdir)
    210 		-- Name the container in a predictable way so we
    211 		-- and the user can easily find it later. This property
    212 		-- comes last, so it cannot be overridden.
    213 		& name (fromContainerId cid)
    214 
    215 -- | Causes *any* docker images that are not in use by running containers to
    216 -- be deleted. And deletes any containers that propellor has set up
    217 -- before that are not currently running. Does not delete any containers
    218 -- that were not set up using propellor.
    219 --
    220 -- Generally, should come after the properties for the desired containers.
    221 garbageCollected :: Property Linux
    222 garbageCollected = propertyList "docker garbage collected" $ props
    223 	& gccontainers
    224 	& gcimages
    225   where
    226 	gccontainers :: Property Linux
    227 	gccontainers = property "docker containers garbage collected" $
    228 		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
    229 	gcimages :: Property Linux
    230 	gcimages = property "docker images garbage collected" $
    231 		liftIO $ report <$> (mapM removeImage =<< listImages)
    232 
    233 -- | Tweaks a container to work well with docker.
    234 --
    235 -- Currently, this consists of making pam_loginuid lines optional in
    236 -- the pam config, to work around <https://github.com/docker/docker/issues/5663>
    237 -- which affects docker 1.2.0.
    238 tweaked :: Property Linux
    239 tweaked = tightenTargets $ cmdProperty "sh"
    240 	[ "-c"
    241 	, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
    242 	]
    243 	`assume` NoChange
    244 	`describe` "tweaked for docker"
    245 
    246 -- | Configures the kernel to respect docker memory limits.
    247 --
    248 -- This assumes the system boots using grub 2. And that you don't need any
    249 -- other GRUB_CMDLINE_LINUX_DEFAULT settings.
    250 --
    251 -- Only takes effect after reboot. (Not automated.)
    252 memoryLimited :: Property DebianLike
    253 memoryLimited = tightenTargets $
    254 	"/etc/default/grub" `File.containsLine` cfg
    255 		`describe` "docker memory limited"
    256 		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
    257   where
    258 	cmdline = "cgroup_enable=memory swapaccount=1"
    259 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
    260 
    261 data ContainerInfo = ContainerInfo Image [RunParam]
    262 
    263 -- | Parameters to pass to `docker run` when creating a container.
    264 type RunParam = String
    265 
    266 -- | ImageID is an image identifier to perform action on images. An
    267 -- ImageID can be the name of an container image, a UID, etc.
    268 --
    269 -- It just encapsulates a String to avoid the definition of a String
    270 -- instance of ImageIdentifier.
    271 newtype ImageID = ImageID String
    272 
    273 -- | Used to perform Docker action on an image.
    274 --
    275 -- Minimal complete definition: `imageIdentifier`
    276 class ImageIdentifier i where
    277 	-- | For internal purposes only.
    278 	toImageID :: i -> ImageID
    279 	toImageID = ImageID . imageIdentifier
    280 	-- | A string that Docker can use as an image identifier.
    281 	imageIdentifier :: i -> String
    282 
    283 instance ImageIdentifier ImageID where
    284 	imageIdentifier (ImageID i) = i
    285 	toImageID = id
    286 
    287 -- | A docker image, that can be used to run a container. The user has
    288 -- to specify a name and can provide an optional tag.
    289 -- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention>
    290 -- for more information.
    291 data Image = Image
    292 	{ repository :: String
    293 	, tag :: Maybe String
    294 	}
    295 	deriving (Eq, Read, Show)
    296 
    297 -- | Defines a Docker image without any tag. This is considered by
    298 -- Docker as the latest image of the provided repository.
    299 latestImage :: String -> Image
    300 latestImage repo = Image repo Nothing
    301 
    302 instance ImageIdentifier Image where
    303 	-- | The format of the imageIdentifier of an `Image` is:
    304 	-- repository | repository:tag
    305 	imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i)
    306 
    307 -- | The UID of an image. This UID is generated by Docker.
    308 newtype ImageUID = ImageUID String
    309 
    310 instance ImageIdentifier ImageUID where
    311 	imageIdentifier (ImageUID uid) = uid
    312 
    313 -- | Set custom dns server for container.
    314 dns :: String -> Property (HasInfo + Linux)
    315 dns = runProp "dns"
    316 
    317 -- | Set container host name.
    318 hostname :: String -> Property (HasInfo + Linux)
    319 hostname = runProp "hostname"
    320 
    321 -- | Set name of container.
    322 name :: String -> Property (HasInfo + Linux)
    323 name = runProp "name"
    324 
    325 class Publishable p where
    326 	toPublish :: p -> String
    327 
    328 instance Publishable (Bound Port) where
    329 	toPublish p = val (hostSide p) ++ ":" ++ val (containerSide p)
    330 
    331 -- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
    332 instance Publishable String where
    333 	toPublish = id
    334 
    335 -- | Publish a container's port to the host
    336 publish :: Publishable p => p -> Property (HasInfo + Linux)
    337 publish = runProp "publish" . toPublish
    338 
    339 -- | Expose a container's port without publishing it.
    340 expose :: String -> Property (HasInfo + Linux)
    341 expose = runProp "expose"
    342 
    343 -- | Username or UID for container.
    344 user :: String -> Property (HasInfo + Linux)
    345 user = runProp "user"
    346 
    347 class Mountable p where
    348 	toMount :: p -> String
    349 
    350 instance Mountable (Bound FilePath) where
    351 	toMount p = hostSide p ++ ":" ++ containerSide p
    352 
    353 -- | string format: [host-dir]:[container-dir]:[rw|ro]
    354 --
    355 -- With just a directory, creates a volume in the container.
    356 instance Mountable String where
    357 	toMount = id
    358 
    359 -- | Mount a volume
    360 volume :: Mountable v => v -> Property (HasInfo + Linux)
    361 volume = runProp "volume" . toMount
    362 
    363 -- | Mount a volume from the specified container into the current
    364 -- container.
    365 volumes_from :: ContainerName -> Property (HasInfo + Linux)
    366 volumes_from cn = genProp "volumes-from" $ \hn ->
    367 	fromContainerId (ContainerId hn cn)
    368 
    369 -- | Work dir inside the container.
    370 workdir :: String -> Property (HasInfo + Linux)
    371 workdir = runProp "workdir"
    372 
    373 -- | Memory limit for container.
    374 -- Format: <number><optional unit>, where unit = b, k, m or g
    375 --
    376 -- Note: Only takes effect when the host has the memoryLimited property
    377 -- enabled.
    378 memory :: String -> Property (HasInfo + Linux)
    379 memory = runProp "memory"
    380 
    381 -- | CPU shares (relative weight).
    382 --
    383 -- By default, all containers run at the same priority, but you can tell
    384 -- the kernel to give more CPU time to a container using this property.
    385 cpuShares :: Int -> Property (HasInfo + Linux)
    386 cpuShares = runProp "cpu-shares" . show
    387 
    388 -- | Link with another container on the same host.
    389 link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
    390 link linkwith calias = genProp "link" $ \hn ->
    391 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
    392 
    393 -- | A short alias for a linked container.
    394 -- Each container has its own alias namespace.
    395 type ContainerAlias = String
    396 
    397 -- | This property is enabled by default for docker containers configured by
    398 -- propellor; as well as keeping badly behaved containers running,
    399 -- it ensures that containers get started back up after reboot or
    400 -- after docker is upgraded.
    401 restartAlways :: Property (HasInfo + Linux)
    402 restartAlways = runProp "restart" "always"
    403 
    404 -- | Docker will restart the container if it exits nonzero.
    405 -- If a number is provided, it will be restarted only up to that many
    406 -- times.
    407 restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
    408 restartOnFailure Nothing = runProp "restart" "on-failure"
    409 restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
    410 
    411 -- | Makes docker not restart a container when it exits
    412 -- Note that this includes not restarting it on boot!
    413 restartNever :: Property (HasInfo + Linux)
    414 restartNever = runProp "restart" "no"
    415 
    416 -- | Set environment variable with a tuple composed by the environment
    417 -- variable name and its value.
    418 environment :: (String, String) -> Property (HasInfo + Linux)
    419 environment (k, v) = runProp "env" $ k ++ "=" ++ v
    420 
    421 -- | A container is identified by its name, and the host
    422 -- on which it's deployed.
    423 data ContainerId = ContainerId
    424 	{ containerHostName :: HostName
    425 	, containerName :: ContainerName
    426 	}
    427 	deriving (Eq, Read, Show)
    428 
    429 -- | Two containers with the same ContainerIdent were started from
    430 -- the same base image (possibly a different version though), and
    431 -- with the same RunParams.
    432 data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
    433 	deriving (Read, Show, Eq)
    434 
    435 toContainerId :: String -> Maybe ContainerId
    436 toContainerId s
    437 	| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of
    438 		(cn, hn)
    439 			| null hn || null cn -> Nothing
    440 			| otherwise -> Just $ ContainerId hn cn
    441 	| otherwise = Nothing
    442   where
    443 	desuffix = reverse . drop len . reverse
    444 	len = length myContainerSuffix
    445 
    446 fromContainerId :: ContainerId -> String
    447 fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
    448 
    449 myContainerSuffix :: String
    450 myContainerSuffix = ".propellor"
    451 
    452 containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
    453 containerDesc cid p = p `describe` desc
    454   where
    455 	desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p
    456 
    457 runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
    458 runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
    459 	l <- liftIO $ listContainers RunningContainers
    460 	if cid `elem` l
    461 		then checkident =<< liftIO getrunningident
    462 		else ifM (liftIO $ elem cid <$> listContainers AllContainers)
    463 			( do
    464 				-- The container exists, but is not
    465 				-- running. Its parameters may have
    466 				-- changed, but we cannot tell without
    467 				-- starting it up first.
    468 				void $ liftIO $ startContainer cid
    469 				-- It can take a while for the container to
    470 				-- start up enough for its ident file to be
    471 				-- written, so retry for up to 60 seconds.
    472 				checkident =<< liftIO (retry 60 $ getrunningident)
    473 			, go image
    474 			)
    475   where
    476 	ident = ContainerIdent image hn cn runps
    477 
    478 	-- Check if the ident has changed; if so the
    479 	-- parameters of the container differ and it must
    480 	-- be restarted.
    481 	checkident (Right runningident)
    482 		| runningident == Just ident = noChange
    483 		| otherwise = do
    484 			void $ liftIO $ stopContainer cid
    485 			restartcontainer
    486 	checkident (Left errmsg) = do
    487 		warningMessage errmsg
    488 		return FailedChange
    489 
    490 	restartcontainer = do
    491 		oldimage <- liftIO $
    492 			maybe (toImageID image) toImageID <$> commitContainer cid
    493 		void $ liftIO $ removeContainer cid
    494 		go oldimage
    495 
    496 	getrunningident = withTmpFile "dockerrunsane" $ \t h -> do
    497 		-- detect #774376 which caused docker exec to not enter
    498 		-- the container namespace, and be able to access files
    499 		-- outside
    500 		hClose h
    501 		void . checkSuccessProcess . processHandle =<<
    502 			createProcess (inContainerProcess cid []
    503 				["rm", "-f", t])
    504 		ifM (doesFileExist t)
    505 			( Right . readish <$>
    506 				readProcess' (inContainerProcess cid []
    507 					["cat", propellorIdent])
    508 			, return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)"
    509 			)
    510 
    511 	retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
    512 	retry 0 _ = return (Right Nothing)
    513 	retry n a = do
    514 		v <- a
    515 		case v of
    516 			Right Nothing -> do
    517 				threadDelaySeconds (Seconds 1)
    518 				retry (n-1) a
    519 			_ -> return v
    520 
    521 	go :: ImageIdentifier i => i -> Propellor Result
    522 	go img = liftIO $ do
    523 		clearProvisionedFlag cid
    524 		createDirectoryIfMissing True (takeDirectory $ identFile cid)
    525 		shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
    526 		writeFile (identFile cid) (show ident)
    527 		toResult <$> runContainer img
    528 			(runps ++ ["-i", "-d", "-t"])
    529 			[shim, "--continue", show (DockerInit (fromContainerId cid))]
    530 
    531 -- | Called when propellor is running inside a docker container.
    532 -- The string should be the container's ContainerId.
    533 --
    534 -- This process is effectively init inside the container.
    535 -- It even needs to wait on zombie processes!
    536 --
    537 -- In the foreground, run an interactive bash (or sh) shell,
    538 -- so that the user can interact with it when attached to the container.
    539 --
    540 -- When the system reboots, docker restarts the container, and this is run
    541 -- again. So, to make the necessary services get started on boot, this needs
    542 -- to provision the container then. However, if the container is already
    543 -- being provisioned by the calling propellor, it would be redundant and
    544 -- problimatic to also provisoon it here, when not booting up.
    545 --
    546 -- The solution is a flag file. If the flag file exists, then the container
    547 -- was already provisioned. So, it must be a reboot, and time to provision
    548 -- again. If the flag file doesn't exist, don't provision here.
    549 init :: String -> IO ()
    550 init s = case toContainerId s of
    551 	Nothing -> error $ "Invalid ContainerId: " ++ s
    552 	Just cid -> do
    553 		changeWorkingDirectory localdir
    554 		writeFile propellorIdent . show =<< readIdentFile cid
    555 		whenM (checkProvisionedFlag cid) $ do
    556 			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
    557 			unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $
    558 				warningMessage "Boot provision failed!"
    559 		void $ async $ job reapzombies
    560 		job $ do
    561 			flushConcurrentOutput
    562 			void $ tryIO $ ifM (inPath "bash")
    563 				( boolSystem "bash" [Param "-l"]
    564 				, boolSystem "/bin/sh" []
    565 				)
    566 			putStrLn "Container is still running. Press ^P^Q to detach."
    567   where
    568 	job = forever . void . tryIO
    569 	reapzombies = void $ getAnyProcessStatus True False
    570 
    571 -- | Once a container is running, propellor can be run inside
    572 -- it to provision it.
    573 provisionContainer :: ContainerId -> Property Linux
    574 provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
    575 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
    576 	let params = ["--continue", show $ toChain cid]
    577 	msgh <- getMessageHandle
    578 	let p = inContainerProcess cid
    579 		(if isConsole msgh then ["-it"] else [])
    580 		(shim : params)
    581 	r <- chainPropellor p
    582 	when (r /= FailedChange) $
    583 		setProvisionedFlag cid
    584 	return r
    585 
    586 toChain :: ContainerId -> CmdLine
    587 toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
    588 
    589 chain :: [Host] -> HostName -> String -> IO ()
    590 chain hostlist hn s = case toContainerId s of
    591 	Nothing -> errorMessage "bad container id"
    592 	Just cid -> case findHostNoAlias hostlist hn of
    593 		Nothing -> errorMessage ("cannot find host " ++ hn)
    594 		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of
    595 			Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
    596 			Just h -> go cid h
    597   where
    598 	go cid h = do
    599 		changeWorkingDirectory localdir
    600 		onlyProcess (provisioningLock cid) $
    601 			runChainPropellor (setcaps h) $ 
    602 				ensureChildProperties $ hostProperties h
    603 	setcaps h = h { hostInfo = hostInfo h `addInfo` [HostnameContained, FilesystemContained] }
    604 
    605 stopContainer :: ContainerId -> IO Bool
    606 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
    607 
    608 startContainer :: ContainerId -> IO Bool
    609 startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
    610 
    611 stoppedContainer :: ContainerId -> Property Linux
    612 stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
    613 	ifM (liftIO $ elem cid <$> listContainers RunningContainers)
    614 		( liftIO cleanup `after` ensureProperty w stop
    615 		, return NoChange
    616 		)
    617   where
    618 	desc = "stopped"
    619 	stop :: Property Linux
    620 	stop = property desc $ liftIO $ toResult <$> stopContainer cid
    621 	cleanup = do
    622 		nukeFile $ identFile cid
    623 		removeDirectoryRecursive $ shimdir cid
    624 		clearProvisionedFlag cid
    625 
    626 removeContainer :: ContainerId -> IO Bool
    627 removeContainer cid = catchBoolIO $
    628 	snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
    629 
    630 removeImage :: ImageIdentifier i => i -> IO Bool
    631 removeImage image = catchBoolIO $
    632 	snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing
    633 
    634 runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
    635 runContainer image ps cmd = boolSystem dockercmd $ map Param $
    636 	"run" : (ps ++ (imageIdentifier image) : cmd)
    637 
    638 inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
    639 inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
    640 
    641 commitContainer :: ContainerId -> IO (Maybe ImageUID)
    642 commitContainer cid = catchMaybeIO $
    643 	ImageUID . takeWhile (/= '\n')
    644 		<$> readProcess dockercmd ["commit", fromContainerId cid]
    645 
    646 data ContainerFilter = RunningContainers | AllContainers
    647 	deriving (Eq)
    648 
    649 -- | Only lists propellor managed containers.
    650 listContainers :: ContainerFilter -> IO [ContainerId]
    651 listContainers status =
    652 	mapMaybe toContainerId . concatMap (split ",")
    653 		. mapMaybe (lastMaybe . words) . lines
    654 		<$> readProcess dockercmd ps
    655   where
    656 	ps
    657 		| status == AllContainers = baseps ++ ["--all"]
    658 		| otherwise = baseps
    659 	baseps = ["ps", "--no-trunc"]
    660 
    661 listImages :: IO [ImageUID]
    662 listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
    663 
    664 runProp :: String -> RunParam -> Property (HasInfo + Linux)
    665 runProp field v = tightenTargets $ pureInfoProperty (param) $
    666 	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
    667   where
    668 	param = field++"="++v
    669 
    670 genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
    671 genProp field mkval = tightenTargets $ pureInfoProperty field $
    672 	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
    673 
    674 dockerInfo :: DockerInfo -> Info
    675 dockerInfo i = mempty `addInfo` i
    676 
    677 -- | The ContainerIdent of a container is written to
    678 -- </.propellor-ident> inside it. This can be checked to see if
    679 -- the container has the same ident later.
    680 propellorIdent :: FilePath
    681 propellorIdent = "/.propellor-ident"
    682 
    683 provisionedFlag :: ContainerId -> FilePath
    684 provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
    685 
    686 clearProvisionedFlag :: ContainerId -> IO ()
    687 clearProvisionedFlag = nukeFile . provisionedFlag
    688 
    689 setProvisionedFlag :: ContainerId -> IO ()
    690 setProvisionedFlag cid = do
    691 	createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))
    692 	writeFile (provisionedFlag cid) "1"
    693 
    694 checkProvisionedFlag :: ContainerId -> IO Bool
    695 checkProvisionedFlag = doesFileExist . provisionedFlag
    696 
    697 provisioningLock :: ContainerId -> FilePath
    698 provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
    699 
    700 shimdir :: ContainerId -> FilePath
    701 shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
    702 
    703 identFile :: ContainerId -> FilePath
    704 identFile cid = "docker" </> fromContainerId cid ++ ".ident"
    705 
    706 readIdentFile :: ContainerId -> IO ContainerIdent
    707 readIdentFile cid = fromMaybe (error "bad ident in identFile")
    708 	. readish <$> readFile (identFile cid)
    709 
    710 dockercmd :: String
    711 dockercmd = "docker"
    712 
    713 report :: [Bool] -> Result
    714 report rmed
    715 	| or rmed = MadeChange
    716 	| otherwise = NoChange
    717