{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}

-- | Maintainer: currently unmaintained; your name here!
--
-- Docker support for propellor
--
-- The existance of a docker container is just another Property of a system,
-- which propellor can set up. See config.hs for an example.

module Propellor.Property.Docker (
	-- * Host properties
	installed,
	configured,
	container,
	docked,
	imageBuilt,
	imagePulled,
	memoryLimited,
	garbageCollected,
	tweaked,
	Image(..),
	latestImage,
	ContainerName,
	Container(..),
	HasImage(..),
	-- * Container configuration
	dns,
	hostname,
	Publishable,
	publish,
	expose,
	user,
	Mountable,
	volume,
	volumes_from,
	workdir,
	memory,
	cpuShares,
	link,
	environment,
	ContainerAlias,
	restartAlways,
	restartOnFailure,
	restartNever,
	-- * Internal use
	init,
	chain,
) where

import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
import Utility.Split

import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Prelude hiding (init)
import Data.List hiding (init)
import qualified Data.Map as M
import System.Console.Concurrent

installed :: Property (DebianLike + ArchLinux)
installed :: Property (DebianLike + ArchLinux)
installed = [ContainerName] -> Property DebianLike
Apt.installed [ContainerName
"docker.io"] forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
(HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
 DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
 SingI c) =>
Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
`pickOS` [ContainerName] -> Property ArchLinux
Pacman.installed [ContainerName
"docker"]

-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
configured :: Property (HasInfo + DebianLike)
configured :: Property (HasInfo + DebianLike)
configured = Property (HasInfo + DebianLike)
prop forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property (DebianLike + ArchLinux)
installed
  where
	prop :: Property (HasInfo + DebianLike)
	prop :: Property (HasInfo + DebianLike)
prop = forall c s metatypes.
(IsContext c, IsPrivDataSource s,
 IncludesInfo metatypes ~ 'True) =>
s
-> c
-> (((PrivData -> Propellor Result) -> Propellor Result)
    -> Property metatypes)
-> Property metatypes
withPrivData PrivDataSource
src Context
anyContext forall a b. (a -> b) -> a -> b
$ \(PrivData -> Propellor Result) -> Propellor Result
getcfg ->
		forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' ContainerName
"docker configured" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> (PrivData -> Propellor Result) -> Propellor Result
getcfg forall a b. (a -> b) -> a -> b
$ \PrivData
cfg -> forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$
			ContainerName
"/root/.dockercfg" ContainerName -> [ContainerName] -> Property UnixLike
`File.hasContent` PrivData -> [ContainerName]
privDataLines PrivData
cfg
	src :: PrivDataSource
src = PrivDataField -> ContainerName -> ContainerName -> PrivDataSource
PrivDataSourceFileFromCommand PrivDataField
DockerAuthentication
		ContainerName
"/root/.dockercfg" ContainerName
"docker login"

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

-- | A docker container.
data Container = Container Image Host

instance IsContainer Container where
	containerProperties :: Container -> [ChildProperty]
containerProperties (Container Image
_ Host
h) = forall c. IsContainer c => c -> [ChildProperty]
containerProperties Host
h
	containerInfo :: Container -> Info
containerInfo (Container Image
_ Host
h) = forall c. IsContainer c => c -> Info
containerInfo Host
h
	setContainerProperties :: Container -> [ChildProperty] -> Container
setContainerProperties (Container Image
i Host
h) [ChildProperty]
ps = Image -> Host -> Container
Container Image
i (forall c. IsContainer c => c -> [ChildProperty] -> c
setContainerProperties Host
h [ChildProperty]
ps)

class HasImage a where
	getImageName :: a -> Image

instance HasImage Image where
	getImageName :: Image -> Image
getImageName = forall a. a -> a
id

instance HasImage Container where
	getImageName :: Container -> Image
getImageName (Container Image
i Host
_) = Image
i

-- | Defines a Container with a given name, image, and properties.
-- Add properties to configure the Container.
--
-- > container "web-server" (latestImage "debian") $ props
-- >    & publish "80:80"
-- >    & Apt.installed {"apache2"]
-- >    & ...
container :: ContainerName -> Image -> Props metatypes -> Container
container :: forall metatypes.
ContainerName -> Image -> Props metatypes -> Container
container ContainerName
cn Image
image (Props [ChildProperty]
ps) = Image -> Host -> Container
Container Image
image (ContainerName -> [ChildProperty] -> Info -> Host
Host ContainerName
cn [ChildProperty]
ps Info
info)
  where
	info :: Info
info = DockerInfo -> Info
dockerInfo forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map forall p. IsProp p => p -> Info
getInfoRecursive [ChildProperty]
ps)

-- | 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 propagated to the Info of the Host it's docked in.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr :: Container
ctr@(Container Image
_ Host
h) =
	(Container
-> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo Container
ctr (ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go ContainerName
"docked" ContainerId -> ContainerInfo -> Property Linux
setup))
		forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!>
	(ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go ContainerName
"undocked" ContainerId -> ContainerInfo -> Property Linux
teardown)
  where
	cn :: ContainerName
cn = Host -> ContainerName
hostName Host
h

	go :: ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go ContainerName
desc ContainerId -> ContainerInfo -> Property Linux
a = forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (ContainerName
desc forall a. [a] -> [a] -> [a]
++ ContainerName
" " forall a. [a] -> [a] -> [a]
++ ContainerName
cn) forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w -> do
		ContainerName
hn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> ContainerName
hostName
		let cid :: ContainerId
cid = ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
cn
		forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerInfo -> Property Linux
a ContainerId
cid (ContainerId -> Container -> ContainerInfo
mkContainerInfo ContainerId
cid Container
ctr)

	setup :: ContainerId -> ContainerInfo -> Property Linux
	setup :: ContainerId -> ContainerInfo -> Property Linux
setup ContainerId
cid (ContainerInfo Image
image [ContainerName]
runparams) =
		ContainerId -> Property Linux
provisionContainer ContainerId
cid
			forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		ContainerId -> Image -> [ContainerName] -> Property Linux
runningContainer ContainerId
cid Image
image [ContainerName]
runparams
			forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		Property (DebianLike + ArchLinux)
installed

	teardown :: ContainerId -> ContainerInfo -> Property Linux
	teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown ContainerId
cid (ContainerInfo Image
image [ContainerName]
_runparams) =
		forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties (ContainerName
"undocked " forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid) forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps
			[ ContainerId -> Property Linux
stoppedContainer ContainerId
cid
			, forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property (ContainerName
"cleaned up " forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid) forall a b. (a -> b) -> a -> b
$
				forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. a -> a
id
					[ ContainerId -> IO Bool
removeContainer ContainerId
cid
					, forall i. ImageIdentifier i => i -> IO Bool
removeImage Image
image
					]
			]

-- | Build the image from a directory containing a Dockerfile.
imageBuilt :: HasImage c => FilePath -> c -> Property Linux
imageBuilt :: forall c. HasImage c => ContainerName -> c -> Property Linux
imageBuilt ContainerName
directory c
ctr = Property Linux
built forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
msg
  where
	msg :: ContainerName
msg = ContainerName
"docker image " forall a. [a] -> [a] -> [a]
++ (forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image) forall a. [a] -> [a] -> [a]
++ ContainerName
" built from " forall a. [a] -> [a] -> [a]
++ ContainerName
directory
	built :: Property Linux
	built :: Property Linux
built = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$
		ContainerName
-> [ContainerName]
-> (CreateProcess -> CreateProcess)
-> UncheckedProperty UnixLike
Cmd.cmdProperty' ContainerName
dockercmd [ContainerName
"build", ContainerName
"--tag", forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image, ContainerName
"./"] CreateProcess -> CreateProcess
workDir
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	workDir :: CreateProcess -> CreateProcess
workDir CreateProcess
p = CreateProcess
p { cwd :: Maybe ContainerName
cwd = forall a. a -> Maybe a
Just ContainerName
directory }
	image :: Image
image = forall a. HasImage a => a -> Image
getImageName c
ctr

-- | Pull the image from the standard Docker Hub registry.
imagePulled :: HasImage c => c -> Property Linux
imagePulled :: forall c. HasImage c => c -> Property Linux
imagePulled c
ctr = Property Linux
pulled forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
msg
  where
	msg :: ContainerName
msg = ContainerName
"docker image " forall a. [a] -> [a] -> [a]
++ (forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image) forall a. [a] -> [a] -> [a]
++ ContainerName
" pulled"
	pulled :: Property Linux
	pulled :: Property Linux
pulled = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ 
		ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
Cmd.cmdProperty ContainerName
dockercmd [ContainerName
"pull", forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image]
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	image :: Image
image = forall a. HasImage a => a -> Image
getImageName c
ctr

propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo :: Container
-> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo ctr :: Container
ctr@(Container Image
_ Host
h) Property (HasInfo + Linux)
p = 
	forall metatypes c.
(IncludesInfo metatypes ~ 'True, IsContainer c) =>
ContainerName
-> c
-> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
propagateContainer ContainerName
cn Container
ctr PropagateInfo -> Bool
normalContainerInfo forall a b. (a -> b) -> a -> b
$
		Property (HasInfo + Linux)
p forall metatypes.
(IncludesInfo metatypes ~ 'True) =>
Property metatypes -> Info -> Property metatypes
`addInfoProperty` Info
dockerinfo
  where
	dockerinfo :: Info
dockerinfo = DockerInfo -> Info
dockerInfo forall a b. (a -> b) -> a -> b
$
		forall a. Monoid a => a
mempty { _dockerContainers :: Map ContainerName Host
_dockerContainers = forall k a. k -> a -> Map k a
M.singleton ContainerName
cn Host
h }
	cn :: ContainerName
cn = Host -> ContainerName
hostName Host
h

mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo cid :: ContainerId
cid@(ContainerId ContainerName
hn ContainerName
_cn) (Container Image
img Host
h) =
	Image -> [ContainerName] -> ContainerInfo
ContainerInfo Image
img [ContainerName]
runparams
  where
	runparams :: [ContainerName]
runparams = forall a b. (a -> b) -> [a] -> [b]
map (\(DockerRunParam ContainerName -> ContainerName
mkparam) -> ContainerName -> ContainerName
mkparam ContainerName
hn)
		(DockerInfo -> [DockerRunParam]
_dockerRunParams DockerInfo
info)
	info :: DockerInfo
info = forall v. IsInfo v => Info -> v
fromInfo forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
h'
	h' :: Host
h' = forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Host
h forall a b. (a -> b) -> a -> b
$ forall c. IsContainer c => c -> Props UnixLike
containerProps Host
h
		-- Restart by default so container comes up on
		-- boot or when docker is upgraded.
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&^"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
&^ Property (HasInfo + Linux)
restartAlways
		-- Expose propellor directory inside the container.
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall v. Mountable v => v -> Property (HasInfo + Linux)
volume (ContainerName
localdirforall a. [a] -> [a] -> [a]
++ContainerName
":"forall a. [a] -> [a] -> [a]
++ContainerName
localdir)
		-- Name the container in a predictable way so we
		-- and the user can easily find it later. This property
		-- comes last, so it cannot be overridden.
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& ContainerName -> Property (HasInfo + Linux)
name (ContainerId -> ContainerName
fromContainerId ContainerId
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
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
garbageCollected :: Property Linux
garbageCollected :: Property Linux
garbageCollected = forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList ContainerName
"docker garbage collected" forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
gccontainers
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
gcimages
  where
	gccontainers :: Property Linux
	gccontainers :: Property Linux
gccontainers = forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"docker containers garbage collected" forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ContainerId -> IO Bool
removeContainer forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
AllContainers)
	gcimages :: Property Linux
	gcimages :: Property Linux
gcimages = forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"docker images garbage collected" forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall i. ImageIdentifier i => i -> IO Bool
removeImage forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [ImageUID]
listImages)

-- | Tweaks a container to work well with docker.
--
-- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
tweaked :: Property Linux
tweaked :: Property Linux
tweaked = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
cmdProperty ContainerName
"sh"
	[ ContainerName
"-c"
	, ContainerName
"sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
	]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
"tweaked for docker"

-- | Configures the kernel to respect docker memory limits.
--
-- This assumes the system boots using grub 2. And that you don't need any
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
--
-- Only takes effect after reboot. (Not automated.)
memoryLimited :: Property DebianLike
memoryLimited :: Property DebianLike
memoryLimited = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$
	ContainerName
"/etc/default/grub" ContainerName -> ContainerName -> Property UnixLike
`File.containsLine` ContainerName
cfg
		forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
"docker memory limited"
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` (ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
cmdProperty ContainerName
"update-grub" [] forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange)
  where
	cmdline :: ContainerName
cmdline = ContainerName
"cgroup_enable=memory swapaccount=1"
	cfg :: ContainerName
cfg = ContainerName
"GRUB_CMDLINE_LINUX_DEFAULT=\""forall a. [a] -> [a] -> [a]
++ContainerName
cmdlineforall a. [a] -> [a] -> [a]
++ContainerName
"\""

data ContainerInfo = ContainerInfo Image [RunParam]

-- | Parameters to pass to `docker run` when creating a container.
type RunParam = String

-- | ImageID is an image identifier to perform action on images. An
-- ImageID can be the name of an container image, a UID, etc.
--
-- It just encapsulates a String to avoid the definition of a String
-- instance of ImageIdentifier.
newtype ImageID = ImageID String

-- | Used to perform Docker action on an image.
--
-- Minimal complete definition: `imageIdentifier`
class ImageIdentifier i where
	-- | For internal purposes only.
	toImageID :: i -> ImageID
	toImageID = ContainerName -> ImageID
ImageID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier
	-- | A string that Docker can use as an image identifier.
	imageIdentifier :: i -> String

instance ImageIdentifier ImageID where
	imageIdentifier :: ImageID -> ContainerName
imageIdentifier (ImageID ContainerName
i) = ContainerName
i
	toImageID :: ImageID -> ImageID
toImageID = forall a. a -> a
id

-- | A docker image, that can be used to run a container. The user has
-- to specify a name and can provide an optional tag.
-- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention>
-- for more information.
data Image = Image
	{ Image -> ContainerName
repository :: String
	, Image -> Maybe ContainerName
tag :: Maybe String
	}
	deriving (Image -> Image -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Image -> Image -> Bool
$c/= :: Image -> Image -> Bool
== :: Image -> Image -> Bool
$c== :: Image -> Image -> Bool
Eq, ReadPrec [Image]
ReadPrec Image
Int -> ReadS Image
ReadS [Image]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Image]
$creadListPrec :: ReadPrec [Image]
readPrec :: ReadPrec Image
$creadPrec :: ReadPrec Image
readList :: ReadS [Image]
$creadList :: ReadS [Image]
readsPrec :: Int -> ReadS Image
$creadsPrec :: Int -> ReadS Image
Read, Int -> Image -> ContainerName -> ContainerName
[Image] -> ContainerName -> ContainerName
Image -> ContainerName
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
showList :: [Image] -> ContainerName -> ContainerName
$cshowList :: [Image] -> ContainerName -> ContainerName
show :: Image -> ContainerName
$cshow :: Image -> ContainerName
showsPrec :: Int -> Image -> ContainerName -> ContainerName
$cshowsPrec :: Int -> Image -> ContainerName -> ContainerName
Show)

-- | Defines a Docker image without any tag. This is considered by
-- Docker as the latest image of the provided repository.
latestImage :: String -> Image
latestImage :: ContainerName -> Image
latestImage ContainerName
repo = ContainerName -> Maybe ContainerName -> Image
Image ContainerName
repo forall a. Maybe a
Nothing

instance ImageIdentifier Image where
	-- | The format of the imageIdentifier of an `Image` is:
	-- repository | repository:tag
	imageIdentifier :: Image -> ContainerName
imageIdentifier Image
i = Image -> ContainerName
repository Image
i forall a. [a] -> [a] -> [a]
++ (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContainerName
"" (forall a. [a] -> [a] -> [a]
(++) ContainerName
":") forall a b. (a -> b) -> a -> b
$ Image -> Maybe ContainerName
tag Image
i)

-- | The UID of an image. This UID is generated by Docker.
newtype ImageUID = ImageUID String

instance ImageIdentifier ImageUID where
	imageIdentifier :: ImageUID -> ContainerName
imageIdentifier (ImageUID ContainerName
uid) = ContainerName
uid

-- | Set custom dns server for container.
dns :: String -> Property (HasInfo + Linux)
dns :: ContainerName -> Property (HasInfo + Linux)
dns = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"dns"

-- | Set container host name.
hostname :: String -> Property (HasInfo + Linux)
hostname :: ContainerName -> Property (HasInfo + Linux)
hostname = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"hostname"

-- | Set name of container.
name :: String -> Property (HasInfo + Linux)
name :: ContainerName -> Property (HasInfo + Linux)
name = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"name"

class Publishable p where
	toPublish :: p -> String

instance Publishable (Bound Port) where
	toPublish :: Bound Port -> ContainerName
toPublish Bound Port
p = forall t. ConfigurableValue t => t -> ContainerName
val (forall v. Bound v -> v
hostSide Bound Port
p) forall a. [a] -> [a] -> [a]
++ ContainerName
":" forall a. [a] -> [a] -> [a]
++ forall t. ConfigurableValue t => t -> ContainerName
val (forall v. Bound v -> v
containerSide Bound Port
p)

-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
instance Publishable String where
	toPublish :: ContainerName -> ContainerName
toPublish = forall a. a -> a
id

-- | Publish a container's port to the host
publish :: Publishable p => p -> Property (HasInfo + Linux)
publish :: forall p. Publishable p => p -> Property (HasInfo + Linux)
publish = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"publish" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Publishable p => p -> ContainerName
toPublish

-- | Expose a container's port without publishing it.
expose :: String -> Property (HasInfo + Linux)
expose :: ContainerName -> Property (HasInfo + Linux)
expose = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"expose"

-- | Username or UID for container.
user :: String -> Property (HasInfo + Linux)
user :: ContainerName -> Property (HasInfo + Linux)
user = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"user"

class Mountable p where
	toMount :: p -> String

instance Mountable (Bound FilePath) where
	toMount :: Bound ContainerName -> ContainerName
toMount Bound ContainerName
p = forall v. Bound v -> v
hostSide Bound ContainerName
p forall a. [a] -> [a] -> [a]
++ ContainerName
":" forall a. [a] -> [a] -> [a]
++ forall v. Bound v -> v
containerSide Bound ContainerName
p

-- | string format: [host-dir]:[container-dir]:[rw|ro]
--
-- With just a directory, creates a volume in the container.
instance Mountable String where
	toMount :: ContainerName -> ContainerName
toMount = forall a. a -> a
id

-- | Mount a volume
volume :: Mountable v => v -> Property (HasInfo + Linux)
volume :: forall v. Mountable v => v -> Property (HasInfo + Linux)
volume = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"volume" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Mountable p => p -> ContainerName
toMount

-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from ContainerName
cn = ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
"volumes-from" forall a b. (a -> b) -> a -> b
$ \ContainerName
hn ->
	ContainerId -> ContainerName
fromContainerId (ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
cn)

-- | Work dir inside the container.
workdir :: String -> Property (HasInfo + Linux)
workdir :: ContainerName -> Property (HasInfo + Linux)
workdir = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"workdir"

-- | Memory limit for container.
-- Format: <number><optional unit>, where unit = b, k, m or g
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
memory :: String -> Property (HasInfo + Linux)
memory :: ContainerName -> Property (HasInfo + Linux)
memory = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"memory"

-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"cpu-shares" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ContainerName
show

-- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link :: ContainerName -> ContainerName -> Property (HasInfo + Linux)
link ContainerName
linkwith ContainerName
calias = ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
"link" forall a b. (a -> b) -> a -> b
$ \ContainerName
hn ->
	ContainerId -> ContainerName
fromContainerId (ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
linkwith) forall a. [a] -> [a] -> [a]
++ ContainerName
":" forall a. [a] -> [a] -> [a]
++ ContainerName
calias

-- | A short alias for a linked container.
-- Each container has its own alias namespace.
type ContainerAlias = String

-- | This property is enabled by default for docker containers configured by
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
restartAlways :: Property (HasInfo + Linux)
restartAlways :: Property (HasInfo + Linux)
restartAlways = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"always"

-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Maybe Int
Nothing = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"on-failure"
restartOnFailure (Just Int
n) = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" (ContainerName
"on-failure:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ContainerName
show Int
n)

-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
restartNever :: Property (HasInfo + Linux)
restartNever :: Property (HasInfo + Linux)
restartNever = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"no"

-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
environment :: (String, String) -> Property (HasInfo + Linux)
environment :: (ContainerName, ContainerName) -> Property (HasInfo + Linux)
environment (ContainerName
k, ContainerName
v) = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"env" forall a b. (a -> b) -> a -> b
$ ContainerName
k forall a. [a] -> [a] -> [a]
++ ContainerName
"=" forall a. [a] -> [a] -> [a]
++ ContainerName
v

-- | A container is identified by its name, and the host
-- on which it's deployed.
data ContainerId = ContainerId
	{ ContainerId -> ContainerName
containerHostName :: HostName
	, ContainerId -> ContainerName
containerName :: ContainerName
	}
	deriving (ContainerId -> ContainerId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContainerId -> ContainerId -> Bool
$c/= :: ContainerId -> ContainerId -> Bool
== :: ContainerId -> ContainerId -> Bool
$c== :: ContainerId -> ContainerId -> Bool
Eq, ReadPrec [ContainerId]
ReadPrec ContainerId
Int -> ReadS ContainerId
ReadS [ContainerId]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContainerId]
$creadListPrec :: ReadPrec [ContainerId]
readPrec :: ReadPrec ContainerId
$creadPrec :: ReadPrec ContainerId
readList :: ReadS [ContainerId]
$creadList :: ReadS [ContainerId]
readsPrec :: Int -> ReadS ContainerId
$creadsPrec :: Int -> ReadS ContainerId
Read, Int -> ContainerId -> ContainerName -> ContainerName
[ContainerId] -> ContainerName -> ContainerName
ContainerId -> ContainerName
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
showList :: [ContainerId] -> ContainerName -> ContainerName
$cshowList :: [ContainerId] -> ContainerName -> ContainerName
show :: ContainerId -> ContainerName
$cshow :: ContainerId -> ContainerName
showsPrec :: Int -> ContainerId -> ContainerName -> ContainerName
$cshowsPrec :: Int -> ContainerId -> ContainerName -> ContainerName
Show)

-- | Two containers with the same ContainerIdent were started from
-- the same base image (possibly a different version though), and
-- with the same RunParams.
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
	deriving (ReadPrec [ContainerIdent]
ReadPrec ContainerIdent
Int -> ReadS ContainerIdent
ReadS [ContainerIdent]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContainerIdent]
$creadListPrec :: ReadPrec [ContainerIdent]
readPrec :: ReadPrec ContainerIdent
$creadPrec :: ReadPrec ContainerIdent
readList :: ReadS [ContainerIdent]
$creadList :: ReadS [ContainerIdent]
readsPrec :: Int -> ReadS ContainerIdent
$creadsPrec :: Int -> ReadS ContainerIdent
Read, Int -> ContainerIdent -> ContainerName -> ContainerName
[ContainerIdent] -> ContainerName -> ContainerName
ContainerIdent -> ContainerName
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
showList :: [ContainerIdent] -> ContainerName -> ContainerName
$cshowList :: [ContainerIdent] -> ContainerName -> ContainerName
show :: ContainerIdent -> ContainerName
$cshow :: ContainerIdent -> ContainerName
showsPrec :: Int -> ContainerIdent -> ContainerName -> ContainerName
$cshowsPrec :: Int -> ContainerIdent -> ContainerName -> ContainerName
Show, ContainerIdent -> ContainerIdent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContainerIdent -> ContainerIdent -> Bool
$c/= :: ContainerIdent -> ContainerIdent -> Bool
== :: ContainerIdent -> ContainerIdent -> Bool
$c== :: ContainerIdent -> ContainerIdent -> Bool
Eq)

toContainerId :: String -> Maybe ContainerId
toContainerId :: ContainerName -> Maybe ContainerId
toContainerId ContainerName
s
	| ContainerName
myContainerSuffix forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ContainerName
s = case forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (forall a. Eq a => a -> a -> Bool
== Char
'.') (forall {a}. [a] -> [a]
desuffix ContainerName
s) of
		(ContainerName
cn, ContainerName
hn)
			| forall (t :: * -> *) a. Foldable t => t a -> Bool
null ContainerName
hn Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null ContainerName
cn -> forall a. Maybe a
Nothing
			| Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
cn
	| Bool
otherwise = forall a. Maybe a
Nothing
  where
	desuffix :: [a] -> [a]
desuffix = forall {a}. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
len forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
reverse
	len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length ContainerName
myContainerSuffix

fromContainerId :: ContainerId -> String
fromContainerId :: ContainerId -> ContainerName
fromContainerId (ContainerId ContainerName
hn ContainerName
cn) = ContainerName
cnforall a. [a] -> [a] -> [a]
++ContainerName
"."forall a. [a] -> [a] -> [a]
++ContainerName
hnforall a. [a] -> [a] -> [a]
++ContainerName
myContainerSuffix

myContainerSuffix :: String
myContainerSuffix :: ContainerName
myContainerSuffix = ContainerName
".propellor"

containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc :: forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid Property i
p = Property i
p forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
desc
  where
	desc :: ContainerName
desc = ContainerName
"container " forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
" " forall a. [a] -> [a] -> [a]
++ forall p. IsProp p => p -> ContainerName
getDesc Property i
p

runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer :: ContainerId -> Image -> [ContainerName] -> Property Linux
runningContainer cid :: ContainerId
cid@(ContainerId ContainerName
hn ContainerName
cn) Image
image [ContainerName]
runps = forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"running" forall a b. (a -> b) -> a -> b
$ do
	[ContainerId]
l <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
RunningContainers
	if ContainerId
cid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ContainerId]
l
		then Either ContainerName (Maybe ContainerIdent) -> Propellor Result
checkident forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either ContainerName (Maybe ContainerIdent))
getrunningident
		else forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ContainerId
cid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
AllContainers)
			( do
				-- The container exists, but is not
				-- running. Its parameters may have
				-- changed, but we cannot tell without
				-- starting it up first.
				forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ContainerId -> IO Bool
startContainer ContainerId
cid
				-- It can take a while for the container to
				-- start up enough for its ident file to be
				-- written, so retry for up to 60 seconds.
				Either ContainerName (Maybe ContainerIdent) -> Propellor Result
checkident forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
60 forall a b. (a -> b) -> a -> b
$ IO (Either ContainerName (Maybe ContainerIdent))
getrunningident)
			, forall i. ImageIdentifier i => i -> Propellor Result
go Image
image
			)
  where
	ident :: ContainerIdent
ident = Image
-> ContainerName
-> ContainerName
-> [ContainerName]
-> ContainerIdent
ContainerIdent Image
image ContainerName
hn ContainerName
cn [ContainerName]
runps

	-- Check if the ident has changed; if so the
	-- parameters of the container differ and it must
	-- be restarted.
	checkident :: Either ContainerName (Maybe ContainerIdent) -> Propellor Result
checkident (Right Maybe ContainerIdent
runningident)
		| Maybe ContainerIdent
runningident forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ContainerIdent
ident = Propellor Result
noChange
		| Bool
otherwise = do
			forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ContainerId -> IO Bool
stopContainer ContainerId
cid
			Propellor Result
restartcontainer
	checkident (Left ContainerName
errmsg) = do
		forall (m :: * -> *). MonadIO m => ContainerName -> m ()
warningMessage ContainerName
errmsg
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange

	restartcontainer :: Propellor Result
restartcontainer = do
		ImageID
oldimage <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
			forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall i. ImageIdentifier i => i -> ImageID
toImageID Image
image) forall i. ImageIdentifier i => i -> ImageID
toImageID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerId -> IO (Maybe ImageUID)
commitContainer ContainerId
cid
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ContainerId -> IO Bool
removeContainer ContainerId
cid
		forall i. ImageIdentifier i => i -> Propellor Result
go ImageID
oldimage

	getrunningident :: IO (Either ContainerName (Maybe ContainerIdent))
getrunningident = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ContainerName -> (ContainerName -> Handle -> m a) -> m a
withTmpFile ContainerName
"dockerrunsane" forall a b. (a -> b) -> a -> b
$ \ContainerName
t Handle
h -> do
		-- detect #774376 which caused docker exec to not enter
		-- the container namespace, and be able to access files
		-- outside
		Handle -> IO ()
hClose Handle
h
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessHandle -> IO Bool
checkSuccessProcess forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ProcessHandle
processHandle forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
			CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid []
				[ContainerName
"rm", ContainerName
"-f", ContainerName
t])
		forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (ContainerName -> IO Bool
doesFileExist ContainerName
t)
			( forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ContainerName -> Maybe a
readish forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
				CreateProcess -> IO ContainerName
readProcess' (ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid []
					[ContainerName
"cat", ContainerName
propellorIdent])
			, forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ContainerName
"docker exec failed to enter chroot properly (maybe an old kernel version?)"
			)

	retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
	retry :: forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
0 IO (Either e (Maybe a))
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing)
	retry Int
n IO (Either e (Maybe a))
a = do
		Either e (Maybe a)
v <- IO (Either e (Maybe a))
a
		case Either e (Maybe a)
v of
			Right Maybe a
Nothing -> do
				Seconds -> IO ()
threadDelaySeconds (Int -> Seconds
Seconds Int
1)
				forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry (Int
nforall a. Num a => a -> a -> a
-Int
1) IO (Either e (Maybe a))
a
			Either e (Maybe a)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Either e (Maybe a)
v

	go :: ImageIdentifier i => i -> Propellor Result
	go :: forall i. ImageIdentifier i => i -> Propellor Result
go i
img = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
		ContainerId -> IO ()
clearProvisionedFlag ContainerId
cid
		Bool -> ContainerName -> IO ()
createDirectoryIfMissing Bool
True (ContainerName -> ContainerName
takeDirectory forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
identFile ContainerId
cid)
		ContainerName
shim <- ContainerName
-> Maybe ContainerName -> ContainerName -> IO ContainerName
Shim.setup (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") forall a. Maybe a
Nothing (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
		ContainerName -> ContainerName -> IO ()
writeFile (ContainerId -> ContainerName
identFile ContainerId
cid) (forall a. Show a => a -> ContainerName
show ContainerIdent
ident)
		forall t. ToResult t => t -> Result
toResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i.
ImageIdentifier i =>
i -> [ContainerName] -> [ContainerName] -> IO Bool
runContainer i
img
			([ContainerName]
runps forall a. [a] -> [a] -> [a]
++ [ContainerName
"-i", ContainerName
"-d", ContainerName
"-t"])
			[ContainerName
shim, ContainerName
"--continue", forall a. Show a => a -> ContainerName
show (ContainerName -> CmdLine
DockerInit (ContainerId -> ContainerName
fromContainerId ContainerId
cid))]

-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
--
-- This process is effectively init inside the container.
-- It even needs to wait on zombie processes!
--
-- In the foreground, run an interactive bash (or sh) shell,
-- so that the user can interact with it when attached to the container.
--
-- When the system reboots, docker restarts the container, and this is run
-- again. So, to make the necessary services get started on boot, this needs
-- to provision the container then. However, if the container is already
-- being provisioned by the calling propellor, it would be redundant and
-- problimatic to also provisoon it here, when not booting up.
--
-- The solution is a flag file. If the flag file exists, then the container
-- was already provisioned. So, it must be a reboot, and time to provision
-- again. If the flag file doesn't exist, don't provision here.
init :: String -> IO ()
init :: ContainerName -> IO ()
init ContainerName
s = case ContainerName -> Maybe ContainerId
toContainerId ContainerName
s of
	Maybe ContainerId
Nothing -> forall a. HasCallStack => ContainerName -> a
error forall a b. (a -> b) -> a -> b
$ ContainerName
"Invalid ContainerId: " forall a. [a] -> [a] -> [a]
++ ContainerName
s
	Just ContainerId
cid -> do
		ContainerName -> IO ()
changeWorkingDirectory ContainerName
localdir
		ContainerName -> ContainerName -> IO ()
writeFile ContainerName
propellorIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ContainerName
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ContainerId -> IO ContainerIdent
readIdentFile ContainerId
cid
		forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ContainerId -> IO Bool
checkProvisionedFlag ContainerId
cid) forall a b. (a -> b) -> a -> b
$ do
			let shim :: ContainerName
shim = ContainerName -> ContainerName -> ContainerName
Shim.file (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
			forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
shim [ContainerName -> CommandParam
Param ContainerName
"--continue", ContainerName -> CommandParam
Param forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ContainerName
show forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]) forall a b. (a -> b) -> a -> b
$
				forall (m :: * -> *). MonadIO m => ContainerName -> m ()
warningMessage ContainerName
"Boot provision failed!"
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall {a} {b}. IO a -> IO b
job IO ()
reapzombies
		forall {a} {b}. IO a -> IO b
job forall a b. (a -> b) -> a -> b
$ do
			IO ()
flushConcurrentOutput
			forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (ContainerName -> IO Bool
inPath ContainerName
"bash")
				( ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
"bash" [ContainerName -> CommandParam
Param ContainerName
"-l"]
				, ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
"/bin/sh" []
				)
			ContainerName -> IO ()
putStrLn ContainerName
"Container is still running. Press ^P^Q to detach."
  where
	job :: IO a -> IO b
job = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO
	reapzombies :: IO ()
reapzombies = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus Bool
True Bool
False

-- | Once a container is running, propellor can be run inside
-- it to provision it.
provisionContainer :: ContainerId -> Property Linux
provisionContainer :: ContainerId -> Property Linux
provisionContainer ContainerId
cid = forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"provisioned" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
	let shim :: ContainerName
shim = ContainerName -> ContainerName -> ContainerName
Shim.file (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
	let params :: [ContainerName]
params = [ContainerName
"--continue", forall a. Show a => a -> ContainerName
show forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]
	MessageHandle
msgh <- IO MessageHandle
getMessageHandle
	let p :: CreateProcess
p = ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid
		(if MessageHandle -> Bool
isConsole MessageHandle
msgh then [ContainerName
"-it"] else [])
		(ContainerName
shim forall a. a -> [a] -> [a]
: [ContainerName]
params)
	Result
r <- CreateProcess -> IO Result
chainPropellor CreateProcess
p
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result
r forall a. Eq a => a -> a -> Bool
/= Result
FailedChange) forall a b. (a -> b) -> a -> b
$
		ContainerId -> IO ()
setProvisionedFlag ContainerId
cid
	forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

toChain :: ContainerId -> CmdLine
toChain :: ContainerId -> CmdLine
toChain ContainerId
cid = ContainerName -> ContainerName -> CmdLine
DockerChain (ContainerId -> ContainerName
containerHostName ContainerId
cid) (ContainerId -> ContainerName
fromContainerId ContainerId
cid)

chain :: [Host] -> HostName -> String -> IO ()
chain :: [Host] -> ContainerName -> ContainerName -> IO ()
chain [Host]
hostlist ContainerName
hn ContainerName
s = case ContainerName -> Maybe ContainerId
toContainerId ContainerName
s of
	Maybe ContainerId
Nothing -> forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage ContainerName
"bad container id"
	Just ContainerId
cid -> case [Host] -> ContainerName -> Maybe Host
findHostNoAlias [Host]
hostlist ContainerName
hn of
		Maybe Host
Nothing -> forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage (ContainerName
"cannot find host " forall a. [a] -> [a] -> [a]
++ ContainerName
hn)
		Just Host
parenthost -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ContainerId -> ContainerName
containerName ContainerId
cid) (DockerInfo -> Map ContainerName Host
_dockerContainers forall a b. (a -> b) -> a -> b
$ forall v. IsInfo v => Info -> v
fromInfo forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
parenthost) of
			Maybe Host
Nothing -> forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage (ContainerName
"cannot find container " forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
containerName ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
" docked on host " forall a. [a] -> [a] -> [a]
++ ContainerName
hn)
			Just Host
h -> ContainerId -> Host -> IO ()
go ContainerId
cid Host
h
  where
	go :: ContainerId -> Host -> IO ()
go ContainerId
cid Host
h = do
		ContainerName -> IO ()
changeWorkingDirectory ContainerName
localdir
		forall a. ContainerName -> IO a -> IO a
onlyProcess (ContainerId -> ContainerName
provisioningLock ContainerId
cid) forall a b. (a -> b) -> a -> b
$
			Host -> Propellor Result -> IO ()
runChainPropellor (Host -> Host
setcaps Host
h) forall a b. (a -> b) -> a -> b
$ 
				[ChildProperty] -> Propellor Result
ensureChildProperties forall a b. (a -> b) -> a -> b
$ Host -> [ChildProperty]
hostProperties Host
h
	setcaps :: Host -> Host
setcaps Host
h = Host
h { hostInfo :: Info
hostInfo = Host -> Info
hostInfo Host
h forall v. IsInfo v => Info -> v -> Info
`addInfo` [ContainerCapability
HostnameContained, ContainerCapability
FilesystemContained] }

stopContainer :: ContainerId -> IO Bool
stopContainer :: ContainerId -> IO Bool
stopContainer ContainerId
cid = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd [ContainerName -> CommandParam
Param ContainerName
"stop", ContainerName -> CommandParam
Param forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
fromContainerId ContainerId
cid ]

startContainer :: ContainerId -> IO Bool
startContainer :: ContainerId -> IO Bool
startContainer ContainerId
cid = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd [ContainerName -> CommandParam
Param ContainerName
"start", ContainerName -> CommandParam
Param forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
fromContainerId ContainerId
cid ]

stoppedContainer :: ContainerId -> Property Linux
stoppedContainer :: ContainerId -> Property Linux
stoppedContainer ContainerId
cid = forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' ContainerName
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w ->
	forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ContainerId
cid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
RunningContainers)
		( forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
cleanup forall (m :: * -> *) b a. Monad m => m b -> m a -> m a
`after` forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w Property Linux
stop
		, forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
		)
  where
	desc :: ContainerName
desc = ContainerName
"stopped"
	stop :: Property Linux
	stop :: Property Linux
stop = forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
desc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t. ToResult t => t -> Result
toResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerId -> IO Bool
stopContainer ContainerId
cid
	cleanup :: IO ()
cleanup = do
		ContainerName -> IO ()
nukeFile forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
identFile ContainerId
cid
		ContainerName -> IO ()
removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
shimdir ContainerId
cid
		ContainerId -> IO ()
clearProvisionedFlag ContainerId
cid

removeContainer :: ContainerId -> IO Bool
removeContainer :: ContainerId -> IO Bool
removeContainer ContainerId
cid = forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO forall a b. (a -> b) -> a -> b
$
	forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName
-> [ContainerName]
-> Maybe ContainerName
-> IO (ContainerName, Bool)
processTranscript ContainerName
dockercmd [ContainerName
"rm", ContainerId -> ContainerName
fromContainerId ContainerId
cid ] forall a. Maybe a
Nothing

removeImage :: ImageIdentifier i => i -> IO Bool
removeImage :: forall i. ImageIdentifier i => i -> IO Bool
removeImage i
image = forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO forall a b. (a -> b) -> a -> b
$
	forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName
-> [ContainerName]
-> Maybe ContainerName
-> IO (ContainerName, Bool)
processTranscript ContainerName
dockercmd [ContainerName
"rmi", forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier i
image] forall a. Maybe a
Nothing

runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
runContainer :: forall i.
ImageIdentifier i =>
i -> [ContainerName] -> [ContainerName] -> IO Bool
runContainer i
image [ContainerName]
ps [ContainerName]
cmd = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ContainerName -> CommandParam
Param forall a b. (a -> b) -> a -> b
$
	ContainerName
"run" forall a. a -> [a] -> [a]
: ([ContainerName]
ps forall a. [a] -> [a] -> [a]
++ (forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier i
image) forall a. a -> [a] -> [a]
: [ContainerName]
cmd)

inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
inContainerProcess :: ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid [ContainerName]
ps [ContainerName]
cmd = ContainerName -> [ContainerName] -> CreateProcess
proc ContainerName
dockercmd (ContainerName
"exec" forall a. a -> [a] -> [a]
: [ContainerName]
ps forall a. [a] -> [a] -> [a]
++ [ContainerId -> ContainerName
fromContainerId ContainerId
cid] forall a. [a] -> [a] -> [a]
++ [ContainerName]
cmd)

commitContainer :: ContainerId -> IO (Maybe ImageUID)
commitContainer :: ContainerId -> IO (Maybe ImageUID)
commitContainer ContainerId
cid = forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO forall a b. (a -> b) -> a -> b
$
	ContainerName -> ImageUID
ImageUID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName
"commit", ContainerId -> ContainerName
fromContainerId ContainerId
cid]

data ContainerFilter = RunningContainers | AllContainers
	deriving (ContainerFilter -> ContainerFilter -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContainerFilter -> ContainerFilter -> Bool
$c/= :: ContainerFilter -> ContainerFilter -> Bool
== :: ContainerFilter -> ContainerFilter -> Bool
$c== :: ContainerFilter -> ContainerFilter -> Bool
Eq)

-- | Only lists propellor managed containers.
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
status =
	forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ContainerName -> Maybe ContainerId
toContainerId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Eq a => [a] -> [a] -> [[a]]
split ContainerName
",")
		forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> Maybe a
lastMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
lines
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName]
ps
  where
	ps :: [ContainerName]
ps
		| ContainerFilter
status forall a. Eq a => a -> a -> Bool
== ContainerFilter
AllContainers = [ContainerName]
baseps forall a. [a] -> [a] -> [a]
++ [ContainerName
"--all"]
		| Bool
otherwise = [ContainerName]
baseps
	baseps :: [ContainerName]
baseps = [ContainerName
"ps", ContainerName
"--no-trunc"]

listImages :: IO [ImageUID]
listImages :: IO [ImageUID]
listImages = forall a b. (a -> b) -> [a] -> [b]
map ContainerName -> ImageUID
ImageUID forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName
"images", ContainerName
"--all", ContainerName
"--quiet"]

runProp :: String -> RunParam -> Property (HasInfo + Linux)
runProp :: ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
field ContainerName
v = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ forall v.
IsInfo v =>
ContainerName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty (ContainerName
param) forall a b. (a -> b) -> a -> b
$
	forall a. Monoid a => a
mempty { _dockerRunParams :: [DockerRunParam]
_dockerRunParams = [(ContainerName -> ContainerName) -> DockerRunParam
DockerRunParam (\ContainerName
_ -> ContainerName
"--"forall a. [a] -> [a] -> [a]
++ContainerName
param)] }
  where
	param :: ContainerName
param = ContainerName
fieldforall a. [a] -> [a] -> [a]
++ContainerName
"="forall a. [a] -> [a] -> [a]
++ContainerName
v

genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp :: ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
field ContainerName -> ContainerName
mkval = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ forall v.
IsInfo v =>
ContainerName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty ContainerName
field forall a b. (a -> b) -> a -> b
$
	forall a. Monoid a => a
mempty { _dockerRunParams :: [DockerRunParam]
_dockerRunParams = [(ContainerName -> ContainerName) -> DockerRunParam
DockerRunParam (\ContainerName
hn -> ContainerName
"--"forall a. [a] -> [a] -> [a]
++ContainerName
fieldforall a. [a] -> [a] -> [a]
++ContainerName
"=" forall a. [a] -> [a] -> [a]
++ ContainerName -> ContainerName
mkval ContainerName
hn)] }

dockerInfo :: DockerInfo -> Info
dockerInfo :: DockerInfo -> Info
dockerInfo DockerInfo
i = forall a. Monoid a => a
mempty forall v. IsInfo v => Info -> v -> Info
`addInfo` DockerInfo
i

-- | The ContainerIdent of a container is written to
-- </.propellor-ident> inside it. This can be checked to see if
-- the container has the same ident later.
propellorIdent :: FilePath
propellorIdent :: ContainerName
propellorIdent = ContainerName
"/.propellor-ident"

provisionedFlag :: ContainerId -> FilePath
provisionedFlag :: ContainerId -> ContainerName
provisionedFlag ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
".provisioned"

clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag = ContainerName -> IO ()
nukeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerId -> ContainerName
provisionedFlag

setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag ContainerId
cid = do
	Bool -> ContainerName -> IO ()
createDirectoryIfMissing Bool
True (ContainerName -> ContainerName
takeDirectory (ContainerId -> ContainerName
provisionedFlag ContainerId
cid))
	ContainerName -> ContainerName -> IO ()
writeFile (ContainerId -> ContainerName
provisionedFlag ContainerId
cid) ContainerName
"1"

checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = ContainerName -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerId -> ContainerName
provisionedFlag

provisioningLock :: ContainerId -> FilePath
provisioningLock :: ContainerId -> ContainerName
provisioningLock ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
".lock"

shimdir :: ContainerId -> FilePath
shimdir :: ContainerId -> ContainerName
shimdir ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
".shim"

identFile :: ContainerId -> FilePath
identFile :: ContainerId -> ContainerName
identFile ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid forall a. [a] -> [a] -> [a]
++ ContainerName
".ident"

readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile ContainerId
cid = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => ContainerName -> a
error ContainerName
"bad ident in identFile")
	forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ContainerName -> Maybe a
readish forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> IO ContainerName
readFile (ContainerId -> ContainerName
identFile ContainerId
cid)

dockercmd :: String
dockercmd :: ContainerName
dockercmd = ContainerName
"docker"

report :: [Bool] -> Result
report :: [Bool] -> Result
report [Bool]
rmed
	| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
rmed = Result
MadeChange
	| Bool
otherwise = Result
NoChange